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