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, David Rosenboom
   6 \
   7 \ Permission to use, copy, modify, and/or distribute this
   8 \ software for any purpose with or without fee is hereby granted.
   9 \
  10 \ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
  11 \ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
  12 \ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL
  13 \ THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
  14 \ CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING
  15 \ FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF
  16 \ CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
  17 \ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  18
  19 anew task-misc1.fth
  20 decimal
  21
  22 : >> rshift ;
  23 : << lshift ;
  24
  25 : (WARNING")  ( flag $message -- )
  26     swap
  27     IF count type
  28     ELSE drop
  29     THEN
  30 ;
  31
  32 : WARNING" ( flag <message> -- , print warning if true. )
  33     [compile] "  ( compile message )
  34     state @
  35     IF  compile (warning")
  36     ELSE (warning")
  37     THEN
  38 ; IMMEDIATE
  39
  40 : (ABORT")  ( flag $message -- )
  41     swap
  42     IF
  43         count type cr
  44         err_abortq throw
  45     ELSE drop
  46     THEN
  47 ;
  48
  49 : ABORT" ( flag <message> -- , print warning if true. )
  50     [compile] "  ( compile message )
  51     state @
  52     IF  compile (abort")
  53     ELSE (abort")
  54     THEN
  55 ; IMMEDIATE
  56
  57
  58 : ?PAUSE ( -- , Pause if key hit. )
  59     ?terminal
  60     IF  key drop cr ." Hit space to continue, any other key to abort:"
  61         key dup emit BL = not abort" Terminated"
  62     THEN
  63 ;
  64
  65 60 constant #cols
  66
  67 : CR?  ( -- , do CR if near end )
  68     OUT @ #cols 16 - 10 max >
  69     IF cr
  70     THEN
  71 ;
  72
  73 : CLS ( -- clear screen )
  74     40 0 do cr loop
  75 ;
  76 : PAGE ( -- , clear screen, compatible with Brodie )
  77     cls
  78 ;
  79
  80 : $ ( <number> -- N , convert next number as hex )
  81     base @ hex
  82     bl lword number? num_type_single = not
  83     abort" Not a single number!"
  84     swap base !
  85     state @
  86     IF [compile] literal
  87     THEN
  88 ; immediate
  89
  90 : .HX   ( nibble -- )
  91     dup 9 >
  92     IF    $ 37
  93     ELSE  $ 30
  94     THEN  + emit
  95 ;
  96
  97 variable TAB-WIDTH  8 TAB-WIDTH !
  98 : TAB  ( -- , tab over to next stop )
  99     out @ tab-width @ mod
 100     tab-width @   swap - spaces
 101 ;
 102
 103 $ 20 constant FLAG_SMUDGE
 104
 105 \ Vocabulary listing
 106 : WORDS  ( -- )
 107     0 latest
 108     BEGIN  dup 0<>
 109     WHILE ( -- count NFA )
 110         dup c@ flag_smudge and 0=
 111         IF
 112             dup id. tab cr? ?pause
 113             swap 1+ swap
 114         THEN
 115         prevname
 116     REPEAT drop
 117     cr . ."  words" cr
 118 ;
 119
 120 : VLIST words ;
 121
 122 variable CLOSEST-NFA
 123 variable CLOSEST-XT
 124
 125 : >NAME  ( xt -- nfa , scans dictionary for closest nfa, SLOW! )
 126     0 closest-nfa !
 127     0 closest-xt !
 128     latest
 129     BEGIN  dup 0<>
 130         IF ( -- addr nfa ) 2dup name> ( addr nfa addr xt ) <
 131             IF true  ( addr below this cfa, can't be it)
 132             ELSE ( -- addr nfa )
 133                 2dup name>  ( addr nfa addr xt ) =
 134                 IF ( found it ! ) dup closest-nfa ! false
 135                 ELSE dup name> closest-xt @ >
 136                     IF dup closest-nfa ! dup name> closest-xt !
 137                     THEN
 138                     true
 139                 THEN
 140             THEN
 141         ELSE false
 142         THEN
 143     WHILE
 144         prevname
 145     REPEAT ( -- cfa nfa )
 146     2drop
 147     closest-nfa @
 148 ;
 149
 150 : @EXECUTE  ( addr -- , execute if non-zero )
 151     x@ ?dup
 152     IF execute
 153     THEN
 154 ;
 155
 156 : TOLOWER ( char -- char_lower )
 157     dup ascii [ <
 158     IF  dup ascii @ >
 159         IF ascii A - ascii a +
 160         THEN
 161     THEN
 162 ;
 163
 164 : EVALUATE ( i*x c-addr num -- j*x , evaluate string of Forth )
 165 \ save current input state and switch to passed in string
 166     source >r >r
 167     set-source
 168     -1 push-source-id
 169     >in @ >r
 170     0 >in !
 171 \ interpret the string
 172     interpret
 173 \ restore input state
 174     pop-source-id drop
 175     r> >in !
 176     r> r> set-source
 177 ;
 178
 179 : \S ( -- , comment out rest of file )
 180     source-id
 181     IF
 182         BEGIN \ using REFILL is safer than popping SOURCE-ID
 183             refill 0=
 184         UNTIL
 185     THEN
 186 ;