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

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