X-Git-Url: http://git.subgeniuskitty.com/pforth/.git/blobdiff_plain/bb6b2dcdd9acffabfd373c4c3f6b64a9cc43f335..1f99f95d6a7eecc05cae8fb357f9b7bf564c2725:/fth/misc1.fth diff --git a/fth/misc1.fth b/fth/misc1.fth index 29e8ede..a90bf6f 100644 --- a/fth/misc1.fth +++ b/fth/misc1.fth @@ -1,176 +1,180 @@ -\ @(#) misc1.fth 98/01/26 1.2 -\ miscellaneous words -\ -\ Author: Phil Burk -\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom -\ -\ The pForth software code is dedicated to the public domain, -\ and any third party may reproduce, distribute and modify -\ the pForth software code or any derivative works thereof -\ without any compensation or license. The pForth software -\ code is provided on an "as is" basis without any warranty -\ of any kind, including, without limitation, the implied -\ warranties of merchantability and fitness for a particular -\ purpose and their equivalents under the laws of any jurisdiction. - -anew task-misc1.fth -decimal - -: >> rshift ; -: << lshift ; -: CELL* ( n -- n*cell ) 2 lshift ; - -: (WARNING") ( flag $message -- ) - swap - IF count type - ELSE drop - THEN -; - -: WARNING" ( flag -- , print warning if true. ) - [compile] " ( compile message ) - state @ - IF compile (warning") - ELSE (warning") - THEN -; IMMEDIATE - -: (ABORT") ( flag $message -- ) - swap - IF count type cr abort - ELSE drop - THEN -; - -: ABORT" ( flag -- , 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 -; - -: $ ( -- N , convert next number as hex ) - base @ hex - 32 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 -; +\ @(#) 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 -- , 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 -- , 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 +; + +: $ ( -- 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 +;