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