| 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 |