git.gag.com Git - debian/pforth/blob - fth/misc1.fth

   1 \ @(#) misc1.fth 98/01/26 1.2
   2 \ miscellaneous words
   3 \
   4 \ Author: Phil Burk
   5 \ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom
   6 \
   7 \ The pForth software code is dedicated to the public domain,
   8 \ and any third party may reproduce, distribute and modify
   9 \ the pForth software code or any derivative works thereof
  10 \ without any compensation or license.  The pForth software
  11 \ code is provided on an "as is" basis without any warranty
  12 \ of any kind, including, without limitation, the implied
  13 \ warranties of merchantability and fitness for a particular
  14 \ purpose and their equivalents under the laws of any jurisdiction.
  15
  16 anew task-misc1.fth
  17 decimal
  18
  19 : >> rshift ;
  20 : << lshift ;
  21
  22 : (WARNING")  ( flag $message -- )
  23     swap
  24     IF count type
  25     ELSE drop
  26     THEN
  27 ;
  28
  29 : WARNING" ( flag <message> -- , print warning if true. )
  30     [compile] "  ( compile message )
  31     state @
  32     IF  compile (warning")
  33     ELSE (warning")
  34     THEN
  35 ; IMMEDIATE
  36
  37 : (ABORT")  ( flag $message -- )
  38     swap
  39     IF
  40         count type cr
  41         err_abortq throw
  42     ELSE drop
  43     THEN
  44 ;
  45
  46 : ABORT" ( flag <message> -- , print warning if true. )
  47     [compile] "  ( compile message )
  48     state @
  49     IF  compile (abort")
  50     ELSE (abort")
  51     THEN
  52 ; IMMEDIATE
  53
  54
  55 : ?PAUSE ( -- , Pause if key hit. )
  56     ?terminal
  57     IF  key drop cr ." Hit space to continue, any other key to abort:"
  58         key dup emit BL = not abort" Terminated"
  59     THEN
  60 ;
  61
  62 60 constant #cols
  63
  64 : CR?  ( -- , do CR if near end )
  65     OUT @ #cols 16 - 10 max >
  66     IF cr
  67     THEN
  68 ;
  69
  70 : CLS ( -- clear screen )
  71     40 0 do cr loop
  72 ;
  73 : PAGE ( -- , clear screen, compatible with Brodie )
  74     cls
  75 ;
  76
  77 : $ ( <number> -- N , convert next number as hex )
  78     base @ hex
  79     bl lword number? num_type_single = not
  80     abort" Not a single number!"
  81     swap base !
  82     state @
  83     IF [compile] literal
  84     THEN
  85 ; immediate
  86
  87 : .HX   ( nibble -- )
  88     dup 9 >
  89     IF    $ 37
  90     ELSE  $ 30
  91     THEN  + emit
  92 ;
  93
  94 variable TAB-WIDTH  8 TAB-WIDTH !
  95 : TAB  ( -- , tab over to next stop )
  96     out @ tab-width @ mod
  97     tab-width @   swap - spaces
  98 ;
  99
 100 \ Vocabulary listing
 101 : WORDS  ( -- )
 102     0 latest
 103     BEGIN  dup 0<>
 104     WHILE  dup id. tab cr? ?pause
 105         prevname
 106         swap 1+ swap
 107     REPEAT drop
 108     cr . ."  words" cr
 109 ;
 110
 111 : VLIST words ;
 112
 113 variable CLOSEST-NFA
 114 variable CLOSEST-XT
 115
 116 : >NAME  ( xt -- nfa , scans dictionary for closest nfa, SLOW! )
 117     0 closest-nfa !
 118     0 closest-xt !
 119     latest
 120     BEGIN  dup 0<>
 121         IF ( -- addr nfa ) 2dup name> ( addr nfa addr xt ) <
 122             IF true  ( addr below this cfa, can't be it)
 123             ELSE ( -- addr nfa )
 124                 2dup name>  ( addr nfa addr xt ) =
 125                 IF ( found it ! ) dup closest-nfa ! false
 126                 ELSE dup name> closest-xt @ >
 127                     IF dup closest-nfa ! dup name> closest-xt !
 128                     THEN
 129                     true
 130                 THEN
 131             THEN
 132         ELSE false
 133         THEN
 134     WHILE
 135         prevname
 136     REPEAT ( -- cfa nfa )
 137     2drop
 138     closest-nfa @
 139 ;
 140
 141 : @EXECUTE  ( addr -- , execute if non-zero )
 142     x@ ?dup
 143     IF execute
 144     THEN
 145 ;
 146
 147 : TOLOWER ( char -- char_lower )
 148     dup ascii [ <
 149     IF  dup ascii @ >
 150         IF ascii A - ascii a +
 151         THEN
 152     THEN
 153 ;
 154
 155 : EVALUATE ( i*x c-addr num -- j*x , evaluate string of Forth )
 156 \ save current input state and switch to passed in string
 157     source >r >r
 158     set-source
 159     -1 push-source-id
 160     >in @ >r
 161     0 >in !
 162 \ interpret the string
 163     interpret
 164 \ restore input state
 165     pop-source-id drop
 166     r> >in !
 167     r> r> set-source
 168 ;
 169
 170 : \S ( -- , comment out rest of file )
 171     source-id
 172     IF
 173         BEGIN \ using REFILL is safer than popping SOURCE-ID
 174             refill 0=
 175         UNTIL
 176     THEN
 177 ;