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