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 \ Vocabulary listing
 104 : WORDS  ( -- )
 105     0 latest
 106     BEGIN  dup 0<>
 107     WHILE  dup id. tab cr? ?pause
 108         prevname
 109         swap 1+ swap
 110     REPEAT drop
 111     cr . ."  words" cr
 112 ;
 113
 114 : VLIST words ;
 115
 116 variable CLOSEST-NFA
 117 variable CLOSEST-XT
 118
 119 : >NAME  ( xt -- nfa , scans dictionary for closest nfa, SLOW! )
 120     0 closest-nfa !
 121     0 closest-xt !
 122     latest
 123     BEGIN  dup 0<>
 124         IF ( -- addr nfa ) 2dup name> ( addr nfa addr xt ) <
 125             IF true  ( addr below this cfa, can't be it)
 126             ELSE ( -- addr nfa )
 127                 2dup name>  ( addr nfa addr xt ) =
 128                 IF ( found it ! ) dup closest-nfa ! false
 129                 ELSE dup name> closest-xt @ >
 130                     IF dup closest-nfa ! dup name> closest-xt !
 131                     THEN
 132                     true
 133                 THEN
 134             THEN
 135         ELSE false
 136         THEN
 137     WHILE
 138         prevname
 139     REPEAT ( -- cfa nfa )
 140     2drop
 141     closest-nfa @
 142 ;
 143
 144 : @EXECUTE  ( addr -- , execute if non-zero )
 145     x@ ?dup
 146     IF execute
 147     THEN
 148 ;
 149
 150 : TOLOWER ( char -- char_lower )
 151     dup ascii [ <
 152     IF  dup ascii @ >
 153         IF ascii A - ascii a +
 154         THEN
 155     THEN
 156 ;
 157
 158 : EVALUATE ( i*x c-addr num -- j*x , evaluate string of Forth )
 159 \ save current input state and switch to passed in string
 160     source >r >r
 161     set-source
 162     -1 push-source-id
 163     >in @ >r
 164     0 >in !
 165 \ interpret the string
 166     interpret
 167 \ restore input state
 168     pop-source-id drop
 169     r> >in !
 170     r> r> set-source
 171 ;
 172
 173 : \S ( -- , comment out rest of file )
 174     source-id
 175     IF
 176         BEGIN \ using REFILL is safer than popping SOURCE-ID
 177             refill 0=
 178         UNTIL
 179     THEN
 180 ;