V25 with 64-bit support

[pforth] / fth / misc1.fth

\ @(#) misc1.fth 98/01/26 1.2\r
\ miscellaneous words\r
\\r
\ Author: Phil Burk\r
\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom\r
\\r
\ The pForth software code is dedicated to the public domain,\r
\ and any third party may reproduce, distribute and modify\r
\ the pForth software code or any derivative works thereof\r
\ without any compensation or license.  The pForth software\r
\ code is provided on an "as is" basis without any warranty\r
\ of any kind, including, without limitation, the implied\r
\ warranties of merchantability and fitness for a particular\r
\ purpose and their equivalents under the laws of any jurisdiction.\r
\r
anew task-misc1.fth\r
decimal\r
\r
: >> rshift ;\r
: << lshift ;\r
\r
: (WARNING")  ( flag $message -- )\r
    swap\r
    IF count type\r
    ELSE drop\r
    THEN\r
;\r
\r
: WARNING" ( flag <message> -- , print warning if true. )\r
	[compile] "  ( compile message )\r
	state @\r
	IF  compile (warning")\r
	ELSE (warning")\r
	THEN\r
; IMMEDIATE\r
\r
: (ABORT")  ( flag $message -- )\r
    swap\r
    IF count type cr abort\r
    ELSE drop\r
    THEN\r
;\r
\r
: ABORT" ( flag <message> -- , print warning if true. )\r
	[compile] "  ( compile message )\r
	state @\r
	IF  compile (abort")\r
	ELSE (abort")\r
	THEN\r
; IMMEDIATE\r
\r
\r
: ?PAUSE ( -- , Pause if key hit. )\r
    ?terminal\r
    IF  key drop cr ." Hit space to continue, any other key to abort:"\r
        key dup emit BL = not abort" Terminated"\r
    THEN\r
;\r
\r
60 constant #cols\r
\r
: CR?  ( -- , do CR if near end )\r
    OUT @ #cols 16 - 10 max >\r
    IF cr\r
    THEN\r
;\r
\r
: CLS ( -- clear screen )\r
	40 0 do cr loop\r
;\r
: PAGE ( -- , clear screen, compatible with Brodie )\r
	cls\r
;\r
\r
: $ ( <number> -- N , convert next number as hex )\r
    base @ hex\r
    32 lword number? num_type_single = not\r
    abort" Not a single number!"\r
    swap base !\r
    state @\r
    IF [compile] literal\r
    THEN\r
; immediate\r
\r
: .HX   ( nibble -- )\r
	dup 9 >\r
	IF    $ 37\r
	ELSE  $ 30\r
	THEN  + emit\r
;\r
\r
variable TAB-WIDTH  8 TAB-WIDTH !\r
: TAB  ( -- , tab over to next stop )\r
    out @ tab-width @ mod\r
    tab-width @   swap - spaces\r
;\r
\r
\ Vocabulary listing\r
: WORDS  ( -- )\r
	0 latest\r
	BEGIN  dup 0<>\r
	WHILE  dup id. tab cr? ?pause\r
		prevname\r
		swap 1+ swap\r
	REPEAT drop\r
	cr . ."  words" cr\r
;\r
\r
: VLIST words ;\r
\r
variable CLOSEST-NFA\r
variable CLOSEST-XT\r
\r
: >NAME  ( xt -- nfa , scans dictionary for closest nfa, SLOW! )\r
	0 closest-nfa !\r
	0 closest-xt !\r
	latest\r
	BEGIN  dup 0<>\r
		IF ( -- addr nfa ) 2dup name> ( addr nfa addr xt ) <\r
			IF true  ( addr below this cfa, can't be it)\r
			ELSE ( -- addr nfa )\r
				2dup name>  ( addr nfa addr xt ) =\r
				IF ( found it ! ) dup closest-nfa ! false\r
				ELSE dup name> closest-xt @ >\r
					IF dup closest-nfa ! dup name> closest-xt !\r
					THEN\r
					true\r
				THEN\r
			THEN\r
		ELSE false\r
		THEN\r
	WHILE  \r
	    prevname\r
	REPEAT ( -- cfa nfa )\r
	2drop\r
	closest-nfa @\r
;\r
\r
: @EXECUTE  ( addr -- , execute if non-zero )\r
	x@ ?dup\r
	IF execute\r
	THEN\r
;\r
\r
: TOLOWER ( char -- char_lower )\r
    dup ascii [ <\r
    IF  dup ascii @ >\r
		IF ascii A - ascii a +\r
		THEN\r
    THEN\r
;\r
\r
: EVALUATE ( i*x c-addr num -- j*x , evaluate string of Forth )\r
\ save current input state and switch to passed in string\r
	source >r >r\r
	set-source\r
	-1 push-source-id\r
	>in @ >r\r
	0 >in !\r
\ interpret the string\r
	interpret\r
\ restore input state\r
	pop-source-id drop\r
	r> >in !\r
	r> r> set-source\r
;\r
\r
: \S ( -- , comment out rest of file )\r
    source-id\r
    IF\r
    	BEGIN \ using REFILL is safer than popping SOURCE-ID\r
    		refill 0=\r
    	UNTIL\r
    THEN\r
;\r