-\ @(#) 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
- bl 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
+\ @(#) misc1.fth 98/01/26 1.2
+\ miscellaneous words
+\
+\ Author: Phil Burk
+\ Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
+\
+\ Permission to use, copy, modify, and/or distribute this
+\ software for any purpose with or without fee is hereby granted.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
+\ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
+\ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL
+\ THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
+\ CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING
+\ FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF
+\ CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+\ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+
+anew task-misc1.fth
+decimal
+
+: >> rshift ;
+: << lshift ;
+
+: (WARNING") ( flag $message -- )
+ swap
+ IF count type
+ ELSE drop
+ THEN
+;
+
+: WARNING" ( flag <message> -- , print warning if true. )
+ [compile] " ( compile message )
+ state @
+ IF compile (warning")
+ ELSE (warning")
+ THEN
+; IMMEDIATE
+
+: (ABORT") ( flag $message -- )
+ swap
+ IF
+ count type cr
+ err_abortq throw
+ ELSE drop
+ THEN
+;
+
+: ABORT" ( flag <message> -- , print warning if true. )
+ [compile] " ( compile message )
+ state @
+ IF compile (abort")
+ ELSE (abort")
+ THEN
+; IMMEDIATE
+
+
+: ?PAUSE ( -- , Pause if key hit. )
+ ?terminal
+ IF key drop cr ." Hit space to continue, any other key to abort:"
+ key dup emit BL = not abort" Terminated"
+ THEN
+;
+
+60 constant #cols
+
+: CR? ( -- , do CR if near end )
+ OUT @ #cols 16 - 10 max >
+ IF cr
+ THEN
+;
+
+: CLS ( -- clear screen )
+ 40 0 do cr loop
+;
+: PAGE ( -- , clear screen, compatible with Brodie )
+ cls
+;
+
+: $ ( <number> -- N , convert next number as hex )
+ base @ hex
+ bl lword number? num_type_single = not
+ abort" Not a single number!"
+ swap base !
+ state @
+ IF [compile] literal
+ THEN
+; immediate
+
+: .HX ( nibble -- )
+ dup 9 >
+ IF $ 37
+ ELSE $ 30
+ THEN + emit
+;
+
+variable TAB-WIDTH 8 TAB-WIDTH !
+: TAB ( -- , tab over to next stop )
+ out @ tab-width @ mod
+ tab-width @ swap - spaces
+;
+
+\ Vocabulary listing
+: WORDS ( -- )
+ 0 latest
+ BEGIN dup 0<>
+ WHILE dup id. tab cr? ?pause
+ prevname
+ swap 1+ swap
+ REPEAT drop
+ cr . ." words" cr
+;
+
+: VLIST words ;
+
+variable CLOSEST-NFA
+variable CLOSEST-XT
+
+: >NAME ( xt -- nfa , scans dictionary for closest nfa, SLOW! )
+ 0 closest-nfa !
+ 0 closest-xt !
+ latest
+ BEGIN dup 0<>
+ IF ( -- addr nfa ) 2dup name> ( addr nfa addr xt ) <
+ IF true ( addr below this cfa, can't be it)
+ ELSE ( -- addr nfa )
+ 2dup name> ( addr nfa addr xt ) =
+ IF ( found it ! ) dup closest-nfa ! false
+ ELSE dup name> closest-xt @ >
+ IF dup closest-nfa ! dup name> closest-xt !
+ THEN
+ true
+ THEN
+ THEN
+ ELSE false
+ THEN
+ WHILE
+ prevname
+ REPEAT ( -- cfa nfa )
+ 2drop
+ closest-nfa @
+;
+
+: @EXECUTE ( addr -- , execute if non-zero )
+ x@ ?dup
+ IF execute
+ THEN
+;
+
+: TOLOWER ( char -- char_lower )
+ dup ascii [ <
+ IF dup ascii @ >
+ IF ascii A - ascii a +
+ THEN
+ THEN
+;
+
+: EVALUATE ( i*x c-addr num -- j*x , evaluate string of Forth )
+\ save current input state and switch to passed in string
+ source >r >r
+ set-source
+ -1 push-source-id
+ >in @ >r
+ 0 >in !
+\ interpret the string
+ interpret
+\ restore input state
+ pop-source-id drop
+ r> >in !
+ r> r> set-source
+;
+
+: \S ( -- , comment out rest of file )
+ source-id
+ IF
+ BEGIN \ using REFILL is safer than popping SOURCE-ID
+ refill 0=
+ UNTIL
+ THEN
+;
projects / pforth / blobdiff