Powered by ViewCVS 1.0-dev
| 1 : | pazsan | 1.1 | \ definitions needed for interpreter only |
| 2 : | |||
| 3 : | anton | 1.177 | \ Copyright (C) 1995-2000,2004,2005,2007,2009,2010 Free Software Foundation, Inc. |
| 4 : | anton | 1.11 | |
| 5 : | \ This file is part of Gforth. | ||
| 6 : | |||
| 7 : | \ Gforth is free software; you can redistribute it and/or | ||
| 8 : | \ modify it under the terms of the GNU General Public License | ||
| 9 : | anton | 1.161 | \ as published by the Free Software Foundation, either version 3 |
| 10 : | anton | 1.11 | \ of the License, or (at your option) any later version. |
| 11 : | |||
| 12 : | \ This program is distributed in the hope that it will be useful, | ||
| 13 : | \ but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 14 : | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 15 : | \ GNU General Public License for more details. | ||
| 16 : | |||
| 17 : | \ You should have received a copy of the GNU General Public License | ||
| 18 : | anton | 1.161 | \ along with this program. If not, see http://www.gnu.org/licenses/. |
| 19 : | anton | 1.11 | |
| 20 : | pazsan | 1.1 | \ \ Revision-Log |
| 21 : | |||
| 22 : | \ put in seperate file 14sep97jaw | ||
| 23 : | |||
| 24 : | \ \ input stream primitives 23feb93py | ||
| 25 : | |||
| 26 : | jwilke | 1.33 | require ./basics.fs \ bounds decimal hex ... |
| 27 : | require ./io.fs \ type ... | ||
| 28 : | require ./nio.fs \ . <# ... | ||
| 29 : | require ./errore.fs \ .error ... | ||
| 30 : | anton | 1.165 | require kernel/version.fs \ version-string |
| 31 : | jwilke | 1.33 | |
| 32 : | pazsan | 1.64 | has? new-input 0= [IF] |
| 33 : | crook | 1.43 | : tib ( -- c-addr ) \ core-ext t-i-b |
| 34 : | crook | 1.40 | \G @i{c-addr} is the address of the Terminal Input Buffer. |
| 35 : | crook | 1.29 | \G OBSOLESCENT: @code{source} superceeds the function of this word. |
| 36 : | pazsan | 1.1 | >tib @ ; |
| 37 : | |||
| 38 : | crook | 1.29 | Defer source ( -- c-addr u ) \ core |
| 39 : | pazsan | 1.1 | \ used by dodefer:, must be defer |
| 40 : | crook | 1.40 | \G @i{c-addr} is the address of the input buffer and @i{u} is the |
| 41 : | crook | 1.29 | \G number of characters in it. |
| 42 : | pazsan | 1.1 | |
| 43 : | crook | 1.29 | : (source) ( -- c-addr u ) |
| 44 : | pazsan | 1.1 | tib #tib @ ; |
| 45 : | ' (source) IS source | ||
| 46 : | pazsan | 1.64 | [THEN] |
| 47 : | pazsan | 1.1 | |
| 48 : | : (word) ( addr1 n1 char -- addr2 n2 ) | ||
| 49 : | dup >r skip 2dup r> scan nip - ; | ||
| 50 : | |||
| 51 : | \ (word) should fold white spaces | ||
| 52 : | \ this is what (parse-white) does | ||
| 53 : | |||
| 54 : | anton | 1.174 | \ parse 23feb93py |
| 55 : | crook | 1.29 | |
| 56 : | : parse ( char "ccc<char>" -- c-addr u ) \ core-ext | ||
| 57 : | anton | 1.80 | \G Parse @i{ccc}, delimited by @i{char}, in the parse |
| 58 : | \G area. @i{c-addr u} specifies the parsed string within the | ||
| 59 : | \G parse area. If the parse area was empty, @i{u} is 0. | ||
| 60 : | anton | 1.132 | >r source >in @ over min /string ( c-addr1 u1 ) |
| 61 : | anton | 1.130 | over swap r> scan >r |
| 62 : | anton | 1.132 | over - dup r> IF 1+ THEN >in +! |
| 63 : | pazsan | 1.138 | [ has? new-input [IF] ] |
| 64 : | 2dup input-lexeme! | ||
| 65 : | [ [THEN] ] ; | ||
| 66 : | pazsan | 1.1 | |
| 67 : | \ name 13feb93py | ||
| 68 : | |||
| 69 : | [IFUNDEF] (name) \ name might be a primitive | ||
| 70 : | |||
| 71 : | crook | 1.40 | : (name) ( -- c-addr count ) \ gforth |
| 72 : | pazsan | 1.1 | source 2dup >r >r >in @ /string (parse-white) |
| 73 : | pazsan | 1.138 | [ has? new-input [IF] ] |
| 74 : | anton | 1.132 | 2dup input-lexeme! |
| 75 : | pazsan | 1.138 | [ [THEN] ] |
| 76 : | pazsan | 1.1 | 2dup + r> - 1+ r> min >in ! ; |
| 77 : | \ name count ; | ||
| 78 : | [THEN] | ||
| 79 : | |||
| 80 : | : name-too-short? ( c-addr u -- c-addr u ) | ||
| 81 : | dup 0= -&16 and throw ; | ||
| 82 : | |||
| 83 : | : name-too-long? ( c-addr u -- c-addr u ) | ||
| 84 : | anton | 1.67 | dup lcount-mask u> -&19 and throw ; |
| 85 : | pazsan | 1.1 | |
| 86 : | \ \ Number parsing 23feb93py | ||
| 87 : | |||
| 88 : | anton | 1.167 | \ (number?) number 23feb93py |
| 89 : | pazsan | 1.1 | |
| 90 : | hex | ||
| 91 : | anton | 1.110 | const Create bases 0A , 10 , 2 , 0A , |
| 92 : | anton | 1.109 | \ 10 16 2 10 |
| 93 : | pazsan | 1.1 | |
| 94 : | anton | 1.18 | \ !! protect BASE saving wrapper against exceptions |
| 95 : | pazsan | 1.1 | : getbase ( addr u -- addr' u' ) |
| 96 : | anton | 1.108 | 2dup s" 0x" string-prefix? >r |
| 97 : | 2dup s" 0X" string-prefix? r> or | ||
| 98 : | anton | 1.117 | base @ &34 < and if |
| 99 : | anton | 1.108 | hex 2 /string |
| 100 : | endif | ||
| 101 : | anton | 1.109 | over c@ [char] # - dup 4 u< |
| 102 : | pazsan | 1.1 | IF |
| 103 : | cells bases + @ base ! 1 /string | ||
| 104 : | ELSE | ||
| 105 : | drop | ||
| 106 : | THEN ; | ||
| 107 : | |||
| 108 : | anton | 1.124 | : sign? ( addr u -- addr1 u1 flag ) |
| 109 : | jwilke | 1.33 | over c@ [char] - = dup >r |
| 110 : | pazsan | 1.1 | IF |
| 111 : | 1 /string | ||
| 112 : | THEN | ||
| 113 : | pazsan | 1.20 | r> ; |
| 114 : | |||
| 115 : | anton | 1.159 | : ?dnegate ( d1 f -- d2 ) |
| 116 : | if | ||
| 117 : | dnegate | ||
| 118 : | then ; | ||
| 119 : | |||
| 120 : | pazsan | 1.157 | has? os 0= [IF] |
| 121 : | : x@+/string ( addr u -- addr' u' c ) | ||
| 122 : | over c@ >r 1 /string r> ; | ||
| 123 : | [THEN] | ||
| 124 : | |||
| 125 : | anton | 1.109 | : s'>unumber? ( addr u -- ud flag ) |
| 126 : | \ convert string "C" or "C'" to character code | ||
| 127 : | dup 0= if | ||
| 128 : | false exit | ||
| 129 : | endif | ||
| 130 : | anton | 1.116 | x@+/string 0 s" '" 2rot string-prefix? ; |
| 131 : | anton | 1.109 | |
| 132 : | anton | 1.159 | : s>unumber? ( c-addr u -- ud flag ) \ gforth |
| 133 : | \G converts string c-addr u into ud, flag indicates success | ||
| 134 : | anton | 1.121 | dpl on |
| 135 : | anton | 1.109 | over c@ '' = if |
| 136 : | 1 /string s'>unumber? exit | ||
| 137 : | endif | ||
| 138 : | anton | 1.166 | base @ >r getbase sign? |
| 139 : | over if | ||
| 140 : | >r 0. 2swap | ||
| 141 : | BEGIN ( d addr len ) | ||
| 142 : | dup >r >number dup | ||
| 143 : | WHILE \ there are characters left | ||
| 144 : | dup r> - | ||
| 145 : | WHILE \ the last >number parsed something | ||
| 146 : | dup 1- dpl ! over c@ [char] . = | ||
| 147 : | WHILE \ the current char is '.' | ||
| 148 : | 1 /string | ||
| 149 : | REPEAT THEN \ there are unparseable characters left | ||
| 150 : | 2drop rdrop false | ||
| 151 : | ELSE | ||
| 152 : | rdrop 2drop r> ?dnegate true | ||
| 153 : | THEN | ||
| 154 : | pazsan | 1.20 | ELSE |
| 155 : | anton | 1.166 | drop 2drop 0. false THEN |
| 156 : | pazsan | 1.21 | r> base ! ; |
| 157 : | pazsan | 1.20 | |
| 158 : | \ ouch, this is complicated; there must be a simpler way - anton | ||
| 159 : | anton | 1.125 | : s>number? ( addr u -- d f ) \ gforth |
| 160 : | \G converts string addr u into d, flag indicates success | ||
| 161 : | pazsan | 1.21 | sign? >r |
| 162 : | pazsan | 1.20 | s>unumber? |
| 163 : | 0= IF | ||
| 164 : | pazsan | 1.21 | rdrop false |
| 165 : | anton | 1.18 | ELSE \ no characters left, all ok |
| 166 : | anton | 1.159 | r> ?dnegate |
| 167 : | anton | 1.18 | true |
| 168 : | pazsan | 1.21 | THEN ; |
| 169 : | pazsan | 1.1 | |
| 170 : | anton | 1.18 | : s>number ( addr len -- d ) |
| 171 : | \ don't use this, there is no way to tell success | ||
| 172 : | s>number? drop ; | ||
| 173 : | |||
| 174 : | pazsan | 1.1 | : snumber? ( c-addr u -- 0 / n -1 / d 0> ) |
| 175 : | anton | 1.18 | s>number? 0= |
| 176 : | pazsan | 1.1 | IF |
| 177 : | 2drop false EXIT | ||
| 178 : | THEN | ||
| 179 : | anton | 1.18 | dpl @ dup 0< IF |
| 180 : | pazsan | 1.1 | nip |
| 181 : | anton | 1.18 | ELSE |
| 182 : | 1+ | ||
| 183 : | pazsan | 1.1 | THEN ; |
| 184 : | |||
| 185 : | anton | 1.167 | : (number?) ( string -- string 0 / n -1 / d 0> ) |
| 186 : | pazsan | 1.1 | dup >r count snumber? dup if |
| 187 : | rdrop | ||
| 188 : | else | ||
| 189 : | r> swap | ||
| 190 : | then ; | ||
| 191 : | |||
| 192 : | : number ( string -- d ) | ||
| 193 : | anton | 1.167 | (number?) ?dup 0= abort" ?" 0< |
| 194 : | pazsan | 1.1 | IF |
| 195 : | s>d | ||
| 196 : | THEN ; | ||
| 197 : | |||
| 198 : | \ \ Comments ( \ \G | ||
| 199 : | |||
| 200 : | crook | 1.29 | : ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ thisone- core,file paren |
| 201 : | crook | 1.17 | \G ** this will not get annotated. The alias in glocals.fs will instead ** |
| 202 : | crook | 1.29 | \G It does not work to use "wordset-" prefix since this file is glossed |
| 203 : | \G by cross.fs which doesn't have the same functionalty as makedoc.fs | ||
| 204 : | pazsan | 1.1 | [char] ) parse 2drop ; immediate |
| 205 : | |||
| 206 : | anton | 1.51 | : \ ( compilation 'ccc<newline>' -- ; run-time -- ) \ thisone- core-ext,block-ext backslash |
| 207 : | crook | 1.29 | \G ** this will not get annotated. The alias in glocals.fs will instead ** |
| 208 : | \G It does not work to use "wordset-" prefix since this file is glossed | ||
| 209 : | \G by cross.fs which doesn't have the same functionalty as makedoc.fs | ||
| 210 : | pazsan | 1.12 | [ has? file [IF] ] |
| 211 : | pazsan | 1.1 | blk @ |
| 212 : | IF | ||
| 213 : | >in @ c/l / 1+ c/l * >in ! | ||
| 214 : | EXIT | ||
| 215 : | THEN | ||
| 216 : | pazsan | 1.12 | [ [THEN] ] |
| 217 : | pazsan | 1.1 | source >in ! drop ; immediate |
| 218 : | |||
| 219 : | anton | 1.51 | : \G ( compilation 'ccc<newline>' -- ; run-time -- ) \ gforth backslash-gee |
| 220 : | crook | 1.19 | \G Equivalent to @code{\} but used as a tag to annotate definition |
| 221 : | \G comments into documentation. | ||
| 222 : | pazsan | 1.1 | POSTPONE \ ; immediate |
| 223 : | |||
| 224 : | pazsan | 1.139 | has? ec [IF] |
| 225 : | AVariable forth-wordlist | ||
| 226 : | : find-name ( c-addr u -- nt | 0 ) \ gforth | ||
| 227 : | \g Find the name @i{c-addr u} in the current search | ||
| 228 : | \g order. Return its @i{nt}, if found, otherwise 0. | ||
| 229 : | pazsan | 1.149 | forth-wordlist (f83find) ; |
| 230 : | pazsan | 1.139 | [ELSE] |
| 231 : | pazsan | 1.1 | \ \ object oriented search list 17mar93py |
| 232 : | |||
| 233 : | \ word list structure: | ||
| 234 : | |||
| 235 : | struct | ||
| 236 : | cell% field find-method \ xt: ( c_addr u wid -- nt ) | ||
| 237 : | cell% field reveal-method \ xt: ( nt wid -- ) \ used by dofield:, must be field | ||
| 238 : | cell% field rehash-method \ xt: ( wid -- ) \ re-initializes a "search-data" (hashtables) | ||
| 239 : | cell% field hash-method \ xt: ( wid -- ) \ initializes "" | ||
| 240 : | \ \ !! what else | ||
| 241 : | end-struct wordlist-map-struct | ||
| 242 : | |||
| 243 : | struct | ||
| 244 : | pazsan | 1.6 | cell% field wordlist-map \ pointer to a wordlist-map-struct |
| 245 : | anton | 1.13 | cell% field wordlist-id \ linked list of words (for WORDS etc.) |
| 246 : | pazsan | 1.1 | cell% field wordlist-link \ link field to other wordlists |
| 247 : | anton | 1.13 | cell% field wordlist-extend \ wordlist extensions (eg bucket offset) |
| 248 : | pazsan | 1.1 | end-struct wordlist-struct |
| 249 : | |||
| 250 : | pazsan | 1.103 | has? f83headerstring [IF] |
| 251 : | : f83find ( addr len wordlist -- nt / false ) | ||
| 252 : | wordlist-id @ (f83find) ; | ||
| 253 : | [ELSE] | ||
| 254 : | pazsan | 1.1 | : f83find ( addr len wordlist -- nt / false ) |
| 255 : | anton | 1.67 | wordlist-id @ (listlfind) ; |
| 256 : | pazsan | 1.103 | [THEN] |
| 257 : | pazsan | 1.1 | |
| 258 : | : initvoc ( wid -- ) | ||
| 259 : | dup wordlist-map @ hash-method perform ; | ||
| 260 : | |||
| 261 : | \ Search list table: find reveal | ||
| 262 : | Create f83search ( -- wordlist-map ) | ||
| 263 : | ' f83find A, ' drop A, ' drop A, ' drop A, | ||
| 264 : | |||
| 265 : | pazsan | 1.168 | here f83search A, NIL A, NIL A, NIL A, |
| 266 : | pazsan | 1.1 | AValue forth-wordlist \ variable, will be redefined by search.fs |
| 267 : | |||
| 268 : | AVariable lookup forth-wordlist lookup ! | ||
| 269 : | \ !! last is user and lookup?! jaw | ||
| 270 : | AVariable current ( -- addr ) \ gforth | ||
| 271 : | crook | 1.43 | \G @code{Variable} -- holds the @i{wid} of the compilation word list. |
| 272 : | pazsan | 1.1 | AVariable voclink forth-wordlist wordlist-link voclink ! |
| 273 : | anton | 1.38 | \ lookup AValue context ( -- addr ) \ gforth |
| 274 : | Defer context ( -- addr ) \ gforth | ||
| 275 : | crook | 1.43 | \G @code{context} @code{@@} is the @i{wid} of the word list at the |
| 276 : | \G top of the search order. | ||
| 277 : | pazsan | 1.1 | |
| 278 : | anton | 1.38 | ' lookup is context |
| 279 : | pazsan | 1.1 | forth-wordlist current ! |
| 280 : | |||
| 281 : | pazsan | 1.139 | : (search-wordlist) ( addr count wid -- nt | false ) |
| 282 : | dup wordlist-map @ find-method perform ; | ||
| 283 : | |||
| 284 : | : search-wordlist ( c-addr count wid -- 0 | xt +-1 ) \ search | ||
| 285 : | \G Search the word list identified by @i{wid} for the definition | ||
| 286 : | \G named by the string at @i{c-addr count}. If the definition is | ||
| 287 : | \G not found, return 0. If the definition is found return 1 (if | ||
| 288 : | \G the definition is immediate) or -1 (if the definition is not | ||
| 289 : | \G immediate) together with the @i{xt}. In Gforth, the @i{xt} | ||
| 290 : | \G returned represents the interpretation semantics. ANS Forth | ||
| 291 : | \G does not specify clearly what @i{xt} represents. | ||
| 292 : | (search-wordlist) dup if | ||
| 293 : | (name>intn) | ||
| 294 : | then ; | ||
| 295 : | |||
| 296 : | : find-name ( c-addr u -- nt | 0 ) \ gforth | ||
| 297 : | \g Find the name @i{c-addr u} in the current search | ||
| 298 : | \g order. Return its @i{nt}, if found, otherwise 0. | ||
| 299 : | lookup @ (search-wordlist) ; | ||
| 300 : | [THEN] | ||
| 301 : | |||
| 302 : | pazsan | 1.1 | \ \ header, finding, ticks 17dec92py |
| 303 : | |||
| 304 : | pazsan | 1.69 | \ The constants are defined as 32 bits, but then erased |
| 305 : | \ and overwritten by the right ones | ||
| 306 : | anton | 1.67 | |
| 307 : | pazsan | 1.103 | has? f83headerstring [IF] |
| 308 : | \ to save space, Gforth EC limits words to 31 characters | ||
| 309 : | pazsan | 1.173 | \ also, there's no predule concept in Gforth EC |
| 310 : | pazsan | 1.103 | $80 constant alias-mask |
| 311 : | $40 constant immediate-mask | ||
| 312 : | $20 constant restrict-mask | ||
| 313 : | $1f constant lcount-mask | ||
| 314 : | anton | 1.169 | [ELSE] |
| 315 : | \ 32-bit systems cannot generate large 64-bit constant in the | ||
| 316 : | \ cross-compiler, so we kludge it by generating a constant and then | ||
| 317 : | \ storing the proper value into it (and that's another kludge). | ||
| 318 : | anton | 1.67 | $80000000 constant alias-mask |
| 319 : | pazsan | 1.69 | 1 bits/char 1 - lshift |
| 320 : | -1 cells allot bigendian [IF] c, 0 1 cells 1- times | ||
| 321 : | [ELSE] 0 1 cells 1- times c, [THEN] | ||
| 322 : | anton | 1.67 | $40000000 constant immediate-mask |
| 323 : | pazsan | 1.69 | 1 bits/char 2 - lshift |
| 324 : | -1 cells allot bigendian [IF] c, 0 1 cells 1- times | ||
| 325 : | [ELSE] 0 1 cells 1- times c, [THEN] | ||
| 326 : | anton | 1.67 | $20000000 constant restrict-mask |
| 327 : | pazsan | 1.69 | 1 bits/char 3 - lshift |
| 328 : | -1 cells allot bigendian [IF] c, 0 1 cells 1- times | ||
| 329 : | [ELSE] 0 1 cells 1- times c, [THEN] | ||
| 330 : | anton | 1.169 | $10000000 constant prelude-mask |
| 331 : | 1 bits/char 4 - lshift | ||
| 332 : | -1 cells allot bigendian [IF] c, 0 1 cells 1- times | ||
| 333 : | [ELSE] 0 1 cells 1- times c, [THEN] | ||
| 334 : | $0fffffff constant lcount-mask | ||
| 335 : | 1 bits/char 4 - lshift 1 - | ||
| 336 : | pazsan | 1.71 | -1 cells allot bigendian [IF] c, -1 1 cells 1- times |
| 337 : | [ELSE] -1 1 cells 1- times c, [THEN] | ||
| 338 : | pazsan | 1.103 | [THEN] |
| 339 : | pazsan | 1.1 | |
| 340 : | \ higher level parts of find | ||
| 341 : | |||
| 342 : | : flag-sign ( f -- 1|-1 ) | ||
| 343 : | \ true becomes 1, false -1 | ||
| 344 : | 0= 2* 1+ ; | ||
| 345 : | |||
| 346 : | anton | 1.79 | : ticking-compile-only-error ( ... -- ) |
| 347 : | -&2048 throw ; | ||
| 348 : | pazsan | 1.1 | |
| 349 : | anton | 1.93 | : compile-only-error ( ... -- ) |
| 350 : | -&14 throw ; | ||
| 351 : | |||
| 352 : | pazsan | 1.1 | : (cfa>int) ( cfa -- xt ) |
| 353 : | [ has? compiler [IF] ] | ||
| 354 : | dup interpret/compile? | ||
| 355 : | if | ||
| 356 : | interpret/compile-int @ | ||
| 357 : | then | ||
| 358 : | [ [THEN] ] ; | ||
| 359 : | |||
| 360 : | anton | 1.67 | : (x>int) ( cfa w -- xt ) |
| 361 : | pazsan | 1.1 | \ get interpretation semantics of name |
| 362 : | pazsan | 1.141 | restrict-mask and [ has? rom [IF] ] 0= [ [THEN] ] |
| 363 : | pazsan | 1.1 | if |
| 364 : | anton | 1.93 | drop ['] compile-only-error |
| 365 : | pazsan | 1.1 | else |
| 366 : | (cfa>int) | ||
| 367 : | then ; | ||
| 368 : | |||
| 369 : | pazsan | 1.103 | has? f83headerstring [IF] |
| 370 : | anton | 1.155 | : name>string ( nt -- addr count ) \ gforth name-to-string |
| 371 : | pazsan | 1.103 | \g @i{addr count} is the name of the word represented by @i{nt}. |
| 372 : | cell+ count lcount-mask and ; | ||
| 373 : | |||
| 374 : | : ((name>)) ( nfa -- cfa ) | ||
| 375 : | name>string + cfaligned ; | ||
| 376 : | |||
| 377 : | : (name>x) ( nfa -- cfa w ) | ||
| 378 : | \ cfa is an intermediate cfa and w is the flags cell of nfa | ||
| 379 : | dup ((name>)) | ||
| 380 : | swap cell+ c@ dup alias-mask and 0= | ||
| 381 : | IF | ||
| 382 : | swap @ swap | ||
| 383 : | THEN ; | ||
| 384 : | [ELSE] | ||
| 385 : | anton | 1.155 | : name>string ( nt -- addr count ) \ gforth name-to-string |
| 386 : | crook | 1.40 | \g @i{addr count} is the name of the word represented by @i{nt}. |
| 387 : | anton | 1.67 | cell+ dup cell+ swap @ lcount-mask and ; |
| 388 : | pazsan | 1.1 | |
| 389 : | : ((name>)) ( nfa -- cfa ) | ||
| 390 : | name>string + cfaligned ; | ||
| 391 : | |||
| 392 : | anton | 1.67 | : (name>x) ( nfa -- cfa w ) |
| 393 : | \ cfa is an intermediate cfa and w is the flags cell of nfa | ||
| 394 : | pazsan | 1.1 | dup ((name>)) |
| 395 : | anton | 1.67 | swap cell+ @ dup alias-mask and 0= |
| 396 : | pazsan | 1.1 | IF |
| 397 : | swap @ swap | ||
| 398 : | THEN ; | ||
| 399 : | pazsan | 1.103 | [THEN] |
| 400 : | pazsan | 1.1 | |
| 401 : | anton | 1.155 | : name>int ( nt -- xt ) \ gforth name-to-int |
| 402 : | crook | 1.31 | \G @i{xt} represents the interpretation semantics of the word |
| 403 : | \G @i{nt}. If @i{nt} has no interpretation semantics (i.e. is | ||
| 404 : | \G @code{compile-only}), @i{xt} is the execution token for | ||
| 405 : | anton | 1.79 | \G @code{ticking-compile-only-error}, which performs @code{-2048 throw}. |
| 406 : | pazsan | 1.1 | (name>x) (x>int) ; |
| 407 : | |||
| 408 : | anton | 1.155 | : name?int ( nt -- xt ) \ gforth name-question-int |
| 409 : | anton | 1.79 | \G Like @code{name>int}, but perform @code{-2048 throw} if @i{nt} |
| 410 : | crook | 1.31 | \G has no interpretation semantics. |
| 411 : | pazsan | 1.141 | (name>x) restrict-mask and [ has? rom [IF] ] 0= [ [THEN] ] |
| 412 : | pazsan | 1.1 | if |
| 413 : | anton | 1.79 | ticking-compile-only-error \ does not return |
| 414 : | pazsan | 1.1 | then |
| 415 : | (cfa>int) ; | ||
| 416 : | |||
| 417 : | : (name>comp) ( nt -- w +-1 ) \ gforth | ||
| 418 : | crook | 1.31 | \G @i{w xt} is the compilation token for the word @i{nt}. |
| 419 : | pazsan | 1.1 | (name>x) >r |
| 420 : | [ has? compiler [IF] ] | ||
| 421 : | dup interpret/compile? | ||
| 422 : | if | ||
| 423 : | interpret/compile-comp @ | ||
| 424 : | then | ||
| 425 : | [ [THEN] ] | ||
| 426 : | pazsan | 1.141 | r> immediate-mask and [ has? rom [IF] ] 0= [ [THEN] ] flag-sign |
| 427 : | pazsan | 1.1 | ; |
| 428 : | |||
| 429 : | : (name>intn) ( nfa -- xt +-1 ) | ||
| 430 : | anton | 1.67 | (name>x) tuck (x>int) ( w xt ) |
| 431 : | pazsan | 1.141 | swap immediate-mask and [ has? rom [IF] ] 0= [ [THEN] ] flag-sign ; |
| 432 : | pazsan | 1.1 | |
| 433 : | pazsan | 1.173 | [IFDEF] prelude-mask |
| 434 : | anton | 1.169 | : name>prelude ( nt -- xt ) |
| 435 : | dup cell+ @ prelude-mask and if | ||
| 436 : | [ -1 cells ] literal + @ | ||
| 437 : | else | ||
| 438 : | drop ['] noop | ||
| 439 : | then ; | ||
| 440 : | pazsan | 1.173 | [THEN] |
| 441 : | anton | 1.169 | |
| 442 : | pazsan | 1.72 | const Create ??? 0 , 3 , char ? c, char ? c, char ? c, |
| 443 : | jwilke | 1.30 | \ ??? is used by dovar:, must be created/:dovar |
| 444 : | |||
| 445 : | [IFDEF] forthstart | ||
| 446 : | \ if we have a forthstart we can define head? with it | ||
| 447 : | \ otherwise leave out the head? check | ||
| 448 : | |||
| 449 : | anton | 1.185 | : one-head? ( addr -- f ) |
| 450 : | anton | 1.82 | \G heuristic check whether addr is a name token; may deliver false |
| 451 : | pazsan | 1.182 | \G positives; addr must be a valid address |
| 452 : | dup dup aligned <> | ||
| 453 : | if | ||
| 454 : | pazsan | 1.184 | drop false exit \ heads are aligned |
| 455 : | pazsan | 1.182 | then |
| 456 : | pazsan | 1.184 | dup cell+ @ alias-mask and 0= >r |
| 457 : | pazsan | 1.183 | name>string dup $20 $1 within if |
| 458 : | pazsan | 1.184 | rdrop 2drop false exit \ realistically the name is short |
| 459 : | pazsan | 1.182 | then |
| 460 : | pazsan | 1.184 | cfaligned 2dup bounds ?do \ should be a printable string |
| 461 : | i c@ bl < if | ||
| 462 : | 2drop unloop rdrop false exit | ||
| 463 : | then | ||
| 464 : | loop | ||
| 465 : | + r> if \ check for valid aliases | ||
| 466 : | @ dup forthstart here within | ||
| 467 : | over ['] noop ['] lit-execute 1+ within or | ||
| 468 : | over dup aligned = and | ||
| 469 : | 0= if | ||
| 470 : | drop false exit | ||
| 471 : | then | ||
| 472 : | then \ check for cfa - must be code field or primitive | ||
| 473 : | dup @ tuck 2 cells - = swap | ||
| 474 : | docol: ['] lit-execute @ 1+ within or ; | ||
| 475 : | anton | 1.14 | |
| 476 : | anton | 1.185 | : head? ( addr -- f ) |
| 477 : | \G heuristic check whether addr is a name token; may deliver false | ||
| 478 : | \G positives; addr must be a valid address; returns 1 for | ||
| 479 : | \G particularly unsafe positives | ||
| 480 : | \ we follow the link fields and check for plausibility; two | ||
| 481 : | \ iterations should catch most false addresses: on the first | ||
| 482 : | \ iteration, we may get an xt, on the second a code address (or | ||
| 483 : | \ some code), which is typically not in the dictionary. | ||
| 484 : | \ we added a third iteration for working with code and ;code words. | ||
| 485 : | 3 0 do | ||
| 486 : | dup one-head? 0= if | ||
| 487 : | drop false unloop exit | ||
| 488 : | endif | ||
| 489 : | dup @ dup 0= if | ||
| 490 : | 2drop 1 unloop exit | ||
| 491 : | else | ||
| 492 : | dup rot forthstart within if | ||
| 493 : | drop false unloop exit | ||
| 494 : | then | ||
| 495 : | then | ||
| 496 : | loop | ||
| 497 : | drop true ; | ||
| 498 : | |||
| 499 : | anton | 1.48 | : >head-noprim ( cfa -- nt ) \ gforth to-head-noprim |
| 500 : | anton | 1.97 | \ also heuristic |
| 501 : | pazsan | 1.157 | dup forthstart - max-name-length @ |
| 502 : | [ has? float [IF] ] float+ [ [ELSE] ] cell+ [ [THEN] ] cell+ min | ||
| 503 : | cell max cell ?do ( cfa ) | ||
| 504 : | pazsan | 1.70 | dup i - dup @ [ alias-mask lcount-mask or ] literal |
| 505 : | [ 1 bits/char 3 - lshift 1 - 1 bits/char 1 - lshift or | ||
| 506 : | pazsan | 1.71 | -1 cells allot bigendian [IF] c, -1 1 cells 1- times |
| 507 : | [ELSE] -1 1 cells 1- times c, [THEN] ] | ||
| 508 : | pazsan | 1.70 | and ( cfa len|alias ) |
| 509 : | anton | 1.97 | swap + cell+ cfaligned over alias-mask + = |
| 510 : | anton | 1.14 | if ( cfa ) |
| 511 : | dup i - cell - dup head? | ||
| 512 : | if | ||
| 513 : | nip unloop exit | ||
| 514 : | then | ||
| 515 : | drop | ||
| 516 : | then | ||
| 517 : | cell +loop | ||
| 518 : | drop ??? ( wouldn't 0 be better? ) ; | ||
| 519 : | pazsan | 1.1 | |
| 520 : | jwilke | 1.30 | [ELSE] |
| 521 : | |||
| 522 : | anton | 1.48 | : >head-noprim ( cfa -- nt ) \ gforth to-head-noprim |
| 523 : | pazsan | 1.45 | $25 cell do ( cfa ) |
| 524 : | pazsan | 1.70 | dup i - dup @ [ alias-mask lcount-mask or ] literal |
| 525 : | [ 1 bits/char 3 - lshift 1 - 1 bits/char 1 - lshift or | ||
| 526 : | pazsan | 1.71 | -1 cells allot bigendian [IF] c, -1 1 cells 1- times |
| 527 : | [ELSE] -1 1 cells 1- times c, [THEN] ] | ||
| 528 : | pazsan | 1.70 | and ( cfa len|alias ) |
| 529 : | anton | 1.67 | swap + cell + cfaligned over alias-mask + = |
| 530 : | jwilke | 1.30 | if ( cfa ) i - cell - unloop exit |
| 531 : | then | ||
| 532 : | cell +loop | ||
| 533 : | drop ??? ( wouldn't 0 be better? ) ; | ||
| 534 : | |||
| 535 : | [THEN] | ||
| 536 : | pazsan | 1.1 | |
| 537 : | anton | 1.158 | cell% 2* 0 0 field >body ( xt -- a_addr ) \ core to-body |
| 538 : | anton | 1.83 | \G Get the address of the body of the word represented by @i{xt} (the |
| 539 : | \G address of the word's data field). | ||
| 540 : | drop drop | ||
| 541 : | |||
| 542 : | cell% -2 * 0 0 field body> ( xt -- a_addr ) | ||
| 543 : | anton | 1.84 | drop drop |
| 544 : | |||
| 545 : | has? standardthreading has? compiler and [IF] | ||
| 546 : | |||
| 547 : | ' @ alias >code-address ( xt -- c_addr ) \ gforth | ||
| 548 : | \G @i{c-addr} is the code address of the word @i{xt}. | ||
| 549 : | |||
| 550 : | : >does-code ( xt -- a_addr ) \ gforth | ||
| 551 : | \G If @i{xt} is the execution token of a child of a @code{DOES>} word, | ||
| 552 : | \G @i{a-addr} is the start of the Forth code after the @code{DOES>}; | ||
| 553 : | \G Otherwise @i{a-addr} is 0. | ||
| 554 : | dup @ dodoes: = if | ||
| 555 : | cell+ @ | ||
| 556 : | else | ||
| 557 : | drop 0 | ||
| 558 : | endif ; | ||
| 559 : | |||
| 560 : | pazsan | 1.157 | has? prims [IF] |
| 561 : | : flash! ! ; | ||
| 562 : | : flashc! c! ; | ||
| 563 : | [THEN] | ||
| 564 : | |||
| 565 : | pazsan | 1.142 | has? flash [IF] ' flash! [ELSE] ' ! [THEN] |
| 566 : | alias code-address! ( c_addr xt -- ) \ gforth | ||
| 567 : | anton | 1.85 | \G Create a code field with code address @i{c-addr} at @i{xt}. |
| 568 : | |||
| 569 : | anton | 1.176 | : any-code! ( a-addr cfa code-addr -- ) |
| 570 : | \ for implementing DOES> and ;ABI-CODE, maybe : | ||
| 571 : | \ code-address is stored at cfa, a-addr at cfa+cell | ||
| 572 : | over ! cell+ ! ; | ||
| 573 : | |||
| 574 : | : does-code! ( a-addr xt -- ) \ gforth | ||
| 575 : | anton | 1.85 | \G Create a code field at @i{xt} for a child of a @code{DOES>}-word; |
| 576 : | \G @i{a-addr} is the start of the Forth code after @code{DOES>}. | ||
| 577 : | pazsan | 1.142 | [ has? flash [IF] ] |
| 578 : | dodoes: over flash! cell+ flash! | ||
| 579 : | [ [ELSE] ] | ||
| 580 : | anton | 1.176 | dodoes: any-code! |
| 581 : | pazsan | 1.142 | [ [THEN] ] ; |
| 582 : | anton | 1.85 | |
| 583 : | 2 cells constant /does-handler ( -- n ) \ gforth | ||
| 584 : | \G The size of a @code{DOES>}-handler (includes possible padding). | ||
| 585 : | |||
| 586 : | anton | 1.84 | [THEN] |
| 587 : | pazsan | 1.1 | |
| 588 : | : sfind ( c-addr u -- 0 / xt +-1 ) \ gforth-obsolete | ||
| 589 : | find-name dup | ||
| 590 : | if ( nt ) | ||
| 591 : | state @ | ||
| 592 : | if | ||
| 593 : | (name>comp) | ||
| 594 : | else | ||
| 595 : | (name>intn) | ||
| 596 : | then | ||
| 597 : | then ; | ||
| 598 : | |||
| 599 : | crook | 1.31 | : find ( c-addr -- xt +-1 | c-addr 0 ) \ core,search |
| 600 : | anton | 1.53 | \G Search all word lists in the current search order for the |
| 601 : | \G definition named by the counted string at @i{c-addr}. If the | ||
| 602 : | \G definition is not found, return 0. If the definition is found | ||
| 603 : | \G return 1 (if the definition has non-default compilation | ||
| 604 : | \G semantics) or -1 (if the definition has default compilation | ||
| 605 : | \G semantics). The @i{xt} returned in interpret state represents | ||
| 606 : | \G the interpretation semantics. The @i{xt} returned in compile | ||
| 607 : | \G state represented either the compilation semantics (for | ||
| 608 : | \G non-default compilation semantics) or the run-time semantics | ||
| 609 : | \G that the compilation semantics would @code{compile,} (for | ||
| 610 : | \G default compilation semantics). The ANS Forth standard does | ||
| 611 : | \G not specify clearly what the returned @i{xt} represents (and | ||
| 612 : | \G also talks about immediacy instead of non-default compilation | ||
| 613 : | \G semantics), so this word is questionable in portable programs. | ||
| 614 : | \G If non-portability is ok, @code{find-name} and friends are | ||
| 615 : | \G better (@pxref{Name token}). | ||
| 616 : | pazsan | 1.1 | dup count sfind dup |
| 617 : | if | ||
| 618 : | rot drop | ||
| 619 : | then ; | ||
| 620 : | |||
| 621 : | jwilke | 1.34 | \ ticks in interpreter |
| 622 : | pazsan | 1.1 | |
| 623 : | : (') ( "name" -- nt ) \ gforth | ||
| 624 : | pazsan | 1.139 | parse-name name-too-short? |
| 625 : | anton | 1.28 | find-name dup 0= |
| 626 : | pazsan | 1.1 | IF |
| 627 : | anton | 1.42 | drop -&13 throw |
| 628 : | pazsan | 1.1 | THEN ; |
| 629 : | |||
| 630 : | : ' ( "name" -- xt ) \ core tick | ||
| 631 : | crook | 1.31 | \g @i{xt} represents @i{name}'s interpretation |
| 632 : | \g semantics. Perform @code{-14 throw} if the word has no | ||
| 633 : | pazsan | 1.1 | \g interpretation semantics. |
| 634 : | (') name?int ; | ||
| 635 : | jwilke | 1.34 | |
| 636 : | has? compiler 0= [IF] \ interpreter only version of IS and TO | ||
| 637 : | |||
| 638 : | : IS ' >body ! ; | ||
| 639 : | ' IS Alias TO | ||
| 640 : | |||
| 641 : | [THEN] | ||
| 642 : | pazsan | 1.1 | |
| 643 : | \ \ the interpreter loop mar92py | ||
| 644 : | |||
| 645 : | \ interpret 10mar92py | ||
| 646 : | |||
| 647 : | anton | 1.120 | Defer parser1 ( c-addr u -- ... xt) |
| 648 : | \ "... xt" is the action to be performed by the text-interpretation of c-addr u | ||
| 649 : | |||
| 650 : | : parser ( c-addr u -- ... ) | ||
| 651 : | \ text-interpret the word/number c-addr u, possibly producing a number | ||
| 652 : | parser1 execute ; | ||
| 653 : | |||
| 654 : | pazsan | 1.139 | has? ec [IF] |
| 655 : | ' (name) Alias parse-name | ||
| 656 : | pazsan | 1.140 | : no.extensions 2drop -&13 throw ; |
| 657 : | pazsan | 1.139 | ' no.extensions Alias compiler-notfound1 |
| 658 : | ' no.extensions Alias interpreter-notfound1 | ||
| 659 : | [ELSE] | ||
| 660 : | anton | 1.119 | Defer parse-name ( "name" -- c-addr u ) \ gforth |
| 661 : | anton | 1.55 | \G Get the next word from the input buffer |
| 662 : | anton | 1.119 | ' (name) IS parse-name |
| 663 : | anton | 1.77 | |
| 664 : | anton | 1.119 | ' parse-name alias parse-word ( -- c-addr u ) \ gforth-obsolete |
| 665 : | \G old name for @code{parse-name} | ||
| 666 : | |||
| 667 : | ' parse-name alias name ( -- c-addr u ) \ gforth-obsolete | ||
| 668 : | \G old name for @code{parse-name} | ||
| 669 : | |||
| 670 : | pazsan | 1.179 | : no.extensions ( addr u -- ) |
| 671 : | 2drop -&13 throw ; | ||
| 672 : | |||
| 673 : | has? recognizer 0= [IF] | ||
| 674 : | anton | 1.120 | Defer compiler-notfound1 ( c-addr count -- ... xt ) |
| 675 : | Defer interpreter-notfound1 ( c-addr count -- ... xt ) | ||
| 676 : | pazsan | 1.1 | |
| 677 : | anton | 1.120 | ' no.extensions IS compiler-notfound1 |
| 678 : | ' no.extensions IS interpreter-notfound1 | ||
| 679 : | pazsan | 1.179 | [THEN] |
| 680 : | pazsan | 1.1 | |
| 681 : | anton | 1.106 | Defer before-word ( -- ) \ gforth |
| 682 : | \ called before the text interpreter parses the next word | ||
| 683 : | ' noop IS before-word | ||
| 684 : | pazsan | 1.139 | [THEN] |
| 685 : | anton | 1.106 | |
| 686 : | pazsan | 1.149 | has? backtrace [IF] |
| 687 : | anton | 1.66 | : interpret1 ( ... -- ... ) |
| 688 : | anton | 1.24 | rp@ backtrace-rp0 ! |
| 689 : | pazsan | 1.1 | BEGIN |
| 690 : | pazsan | 1.139 | ?stack [ has? EC 0= [IF] ] before-word [ [THEN] ] parse-name dup |
| 691 : | pazsan | 1.1 | WHILE |
| 692 : | anton | 1.120 | parser1 execute |
| 693 : | pazsan | 1.1 | REPEAT |
| 694 : | anton | 1.66 | 2drop ; |
| 695 : | |||
| 696 : | : interpret ( ?? -- ?? ) \ gforth | ||
| 697 : | \ interpret/compile the (rest of the) input buffer | ||
| 698 : | backtrace-rp0 @ >r | ||
| 699 : | ['] interpret1 catch | ||
| 700 : | anton | 1.65 | r> backtrace-rp0 ! |
| 701 : | pazsan | 1.154 | throw ; |
| 702 : | pazsan | 1.149 | [ELSE] |
| 703 : | : interpret ( ... -- ... ) | ||
| 704 : | BEGIN | ||
| 705 : | ?stack [ has? EC 0= [IF] ] before-word [ [THEN] ] parse-name dup | ||
| 706 : | WHILE | ||
| 707 : | parser1 execute | ||
| 708 : | REPEAT | ||
| 709 : | 2drop ; | ||
| 710 : | [THEN] | ||
| 711 : | pazsan | 1.1 | |
| 712 : | \ interpreter 30apr92py | ||
| 713 : | |||
| 714 : | pazsan | 1.173 | [IFDEF] prelude-mask |
| 715 : | anton | 1.171 | : run-prelude ( nt|0 -- nt|0 ) |
| 716 : | \ run the prelude of the name identified by nt (if present). This | ||
| 717 : | \ is used in the text interpreter and similar stuff. | ||
| 718 : | dup if | ||
| 719 : | dup name>prelude execute | ||
| 720 : | then ; | ||
| 721 : | pazsan | 1.173 | [THEN] |
| 722 : | anton | 1.171 | |
| 723 : | pazsan | 1.178 | has? recognizer 0= [IF] |
| 724 : | pazsan | 1.1 | \ not the most efficient implementations of interpreter and compiler |
| 725 : | anton | 1.120 | : interpreter1 ( c-addr u -- ... xt ) |
| 726 : | pazsan | 1.173 | 2dup find-name [ [IFDEF] prelude-mask ] run-prelude [ [THEN] ] dup |
| 727 : | pazsan | 1.1 | if |
| 728 : | anton | 1.120 | nip nip name>int |
| 729 : | pazsan | 1.1 | else |
| 730 : | drop | ||
| 731 : | 2dup 2>r snumber? | ||
| 732 : | IF | ||
| 733 : | anton | 1.120 | 2rdrop ['] noop |
| 734 : | pazsan | 1.1 | ELSE |
| 735 : | anton | 1.120 | 2r> interpreter-notfound1 |
| 736 : | pazsan | 1.1 | THEN |
| 737 : | then ; | ||
| 738 : | |||
| 739 : | anton | 1.120 | ' interpreter1 IS parser1 |
| 740 : | pazsan | 1.178 | [THEN] |
| 741 : | pazsan | 1.1 | |
| 742 : | \ \ Query Evaluate 07apr93py | ||
| 743 : | |||
| 744 : | has? file 0= [IF] | ||
| 745 : | pazsan | 1.12 | : sourceline# ( -- n ) 1 ; |
| 746 : | pazsan | 1.61 | [ELSE] |
| 747 : | pazsan | 1.64 | has? new-input 0= [IF] |
| 748 : | pazsan | 1.58 | Variable #fill-bytes |
| 749 : | \G number of bytes read via (read-line) by the last refill | ||
| 750 : | pazsan | 1.61 | [THEN] |
| 751 : | pazsan | 1.64 | [THEN] |
| 752 : | pazsan | 1.58 | |
| 753 : | pazsan | 1.64 | has? new-input 0= [IF] |
| 754 : | pazsan | 1.138 | : input-start-line ( -- ) >in off ; |
| 755 : | pazsan | 1.1 | : refill ( -- flag ) \ core-ext,block-ext,file-ext |
| 756 : | crook | 1.29 | \G Attempt to fill the input buffer from the input source. When |
| 757 : | \G the input source is the user input device, attempt to receive | ||
| 758 : | \G input into the terminal input device. If successful, make the | ||
| 759 : | \G result the input buffer, set @code{>IN} to 0 and return true; | ||
| 760 : | \G otherwise return false. When the input source is a block, add 1 | ||
| 761 : | \G to the value of @code{BLK} to make the next block the input | ||
| 762 : | \G source and current input buffer, and set @code{>IN} to 0; | ||
| 763 : | \G return true if the new value of @code{BLK} is a valid block | ||
| 764 : | \G number, false otherwise. When the input source is a text file, | ||
| 765 : | \G attempt to read the next line from the file. If successful, | ||
| 766 : | \G make the result the current input buffer, set @code{>IN} to 0 | ||
| 767 : | \G and return true; otherwise, return false. A successful result | ||
| 768 : | \G includes receipt of a line containing 0 characters. | ||
| 769 : | pazsan | 1.12 | [ has? file [IF] ] |
| 770 : | pazsan | 1.138 | blk @ IF 1 blk +! true EXIT THEN |
| 771 : | pazsan | 1.12 | [ [THEN] ] |
| 772 : | tib /line | ||
| 773 : | [ has? file [IF] ] | ||
| 774 : | loadfile @ ?dup | ||
| 775 : | pazsan | 1.59 | IF (read-line) throw #fill-bytes ! |
| 776 : | pazsan | 1.12 | ELSE |
| 777 : | [ [THEN] ] | ||
| 778 : | sourceline# 0< IF 2drop false EXIT THEN | ||
| 779 : | pazsan | 1.145 | accept eof @ 0= |
| 780 : | pazsan | 1.12 | [ has? file [IF] ] |
| 781 : | THEN | ||
| 782 : | 1 loadline +! | ||
| 783 : | [ [THEN] ] | ||
| 784 : | pazsan | 1.138 | swap #tib ! |
| 785 : | input-start-line ; | ||
| 786 : | pazsan | 1.1 | |
| 787 : | : query ( -- ) \ core-ext | ||
| 788 : | crook | 1.29 | \G Make the user input device the input source. Receive input into |
| 789 : | \G the Terminal Input Buffer. Set @code{>IN} to zero. OBSOLESCENT: | ||
| 790 : | \G superceeded by @code{accept}. | ||
| 791 : | pazsan | 1.12 | [ has? file [IF] ] |
| 792 : | blk off loadfile off | ||
| 793 : | [ [THEN] ] | ||
| 794 : | pazsan | 1.64 | refill drop ; |
| 795 : | [THEN] | ||
| 796 : | pazsan | 1.1 | |
| 797 : | \ save-mem extend-mem | ||
| 798 : | |||
| 799 : | has? os [IF] | ||
| 800 : | : save-mem ( addr1 u -- addr2 u ) \ gforth | ||
| 801 : | \g copy a memory block into a newly allocated region in the heap | ||
| 802 : | swap >r | ||
| 803 : | dup allocate throw | ||
| 804 : | swap 2dup r> -rot move ; | ||
| 805 : | |||
| 806 : | anton | 1.68 | : free-mem-var ( addr -- ) |
| 807 : | \ addr is the address of a 2variable containing address and size | ||
| 808 : | \ of a memory range; frees memory and clears the 2variable. | ||
| 809 : | dup 2@ drop dup | ||
| 810 : | if ( addr mem-start ) | ||
| 811 : | free throw | ||
| 812 : | 0 0 rot 2! | ||
| 813 : | else | ||
| 814 : | 2drop | ||
| 815 : | then ; | ||
| 816 : | |||
| 817 : | pazsan | 1.1 | : extend-mem ( addr1 u1 u -- addr addr2 u2 ) |
| 818 : | \ extend memory block allocated from the heap by u aus | ||
| 819 : | anton | 1.105 | \ the (possibly reallocated) piece is addr2 u2, the extension is at addr |
| 820 : | pazsan | 1.1 | over >r + dup >r resize throw |
| 821 : | r> over r> + -rot ; | ||
| 822 : | [THEN] | ||
| 823 : | |||
| 824 : | \ EVALUATE 17may93jaw | ||
| 825 : | |||
| 826 : | pazsan | 1.64 | has? file 0= has? new-input 0= and [IF] |
| 827 : | pazsan | 1.1 | : push-file ( -- ) r> |
| 828 : | pazsan | 1.12 | tibstack @ >r >tib @ >r #tib @ >r |
| 829 : | pazsan | 1.1 | >tib @ tibstack @ = IF r@ tibstack +! THEN |
| 830 : | tibstack @ >tib ! >in @ >r >r ; | ||
| 831 : | |||
| 832 : | : pop-file ( throw-code -- throw-code ) | ||
| 833 : | r> | ||
| 834 : | pazsan | 1.12 | r> >in ! r> #tib ! r> >tib ! r> tibstack ! >r ; |
| 835 : | pazsan | 1.1 | [THEN] |
| 836 : | |||
| 837 : | pazsan | 1.64 | has? new-input 0= [IF] |
| 838 : | crook | 1.29 | : evaluate ( c-addr u -- ) \ core,block |
| 839 : | crook | 1.40 | \G Save the current input source specification. Store @code{-1} in |
| 840 : | \G @code{source-id} and @code{0} in @code{blk}. Set @code{>IN} to | ||
| 841 : | \G @code{0} and make the string @i{c-addr u} the input source | ||
| 842 : | \G and input buffer. Interpret. When the parse area is empty, | ||
| 843 : | \G restore the input source specification. | ||
| 844 : | pazsan | 1.64 | [ has? file [IF] ] |
| 845 : | anton | 1.92 | s" *evaluated string*" loadfilename>r |
| 846 : | pazsan | 1.64 | [ [THEN] ] |
| 847 : | crook | 1.40 | push-file #tib ! >tib ! |
| 848 : | anton | 1.130 | input-start-line |
| 849 : | crook | 1.29 | [ has? file [IF] ] |
| 850 : | blk off loadfile off -1 loadline ! | ||
| 851 : | [ [THEN] ] | ||
| 852 : | ['] interpret catch | ||
| 853 : | anton | 1.56 | pop-file |
| 854 : | pazsan | 1.64 | [ has? file [IF] ] |
| 855 : | anton | 1.92 | r>loadfilename |
| 856 : | pazsan | 1.64 | [ [THEN] ] |
| 857 : | anton | 1.56 | throw ; |
| 858 : | pazsan | 1.64 | [THEN] |
| 859 : | pazsan | 1.1 | |
| 860 : | \ \ Quit 13feb93py | ||
| 861 : | |||
| 862 : | Defer 'quit | ||
| 863 : | |||
| 864 : | pazsan | 1.156 | has? os [IF] |
| 865 : | pazsan | 1.157 | Defer .status |
| 866 : | [ELSE] | ||
| 867 : | pazsan | 1.164 | [IFUNDEF] bye |
| 868 : | : (bye) ( 0 -- ) \ back to DOS | ||
| 869 : | drop 5 emit ; | ||
| 870 : | |||
| 871 : | : bye ( -- ) 0 (bye) ; | ||
| 872 : | [THEN] | ||
| 873 : | pazsan | 1.149 | [THEN] |
| 874 : | pazsan | 1.1 | |
| 875 : | : prompt state @ IF ." compiled" EXIT THEN ." ok" ; | ||
| 876 : | |||
| 877 : | anton | 1.39 | : (quit) ( -- ) |
| 878 : | \ exits only through THROW etc. | ||
| 879 : | BEGIN | ||
| 880 : | pazsan | 1.149 | [ has? ec [IF] ] cr [ [ELSE] ] |
| 881 : | .status ['] cr catch if | ||
| 882 : | pazsan | 1.144 | [ has? OS [IF] ] >stderr [ [THEN] ] |
| 883 : | cr ." Can't print to stdout, leaving" cr | ||
| 884 : | anton | 1.98 | \ if stderr does not work either, already DoError causes a hang |
| 885 : | 2 (bye) | ||
| 886 : | pazsan | 1.149 | endif [ [THEN] ] |
| 887 : | pazsan | 1.138 | refill WHILE |
| 888 : | anton | 1.122 | interpret prompt |
| 889 : | REPEAT | ||
| 890 : | bye ; | ||
| 891 : | pazsan | 1.1 | |
| 892 : | ' (quit) IS 'quit | ||
| 893 : | |||
| 894 : | \ \ DOERROR (DOERROR) 13jun93jaw | ||
| 895 : | |||
| 896 : | pazsan | 1.156 | has? os [IF] |
| 897 : | pazsan | 1.1 | 8 Constant max-errors |
| 898 : | anton | 1.130 | 5 has? file 2 and + Constant /error |
| 899 : | pazsan | 1.1 | Variable error-stack 0 error-stack ! |
| 900 : | pazsan | 1.112 | max-errors /error * cells allot |
| 901 : | pazsan | 1.1 | \ format of one cell: |
| 902 : | anton | 1.133 | \ source ( c-addr u ) |
| 903 : | \ last parsed lexeme ( c-addr u ) | ||
| 904 : | pazsan | 1.1 | \ line-number |
| 905 : | \ Loadfilename ( addr u ) | ||
| 906 : | |||
| 907 : | anton | 1.133 | : error> ( -- c-addr1 u1 c-addr2 u2 line# [addr u] ) |
| 908 : | pazsan | 1.64 | -1 error-stack +! |
| 909 : | error-stack dup @ | ||
| 910 : | pazsan | 1.112 | /error * cells + cell+ |
| 911 : | /error cells bounds DO | ||
| 912 : | anton | 1.130 | I @ |
| 913 : | cell +LOOP ; | ||
| 914 : | |||
| 915 : | anton | 1.133 | : >error ( c-addr1 u1 c-addr2 u2 line# [addr u] -- ) |
| 916 : | pazsan | 1.64 | error-stack dup @ dup 1+ |
| 917 : | max-errors 1- min error-stack ! | ||
| 918 : | pazsan | 1.112 | /error * cells + cell+ |
| 919 : | /error 1- cells bounds swap DO | ||
| 920 : | anton | 1.130 | I ! |
| 921 : | -1 cells +LOOP ; | ||
| 922 : | |||
| 923 : | anton | 1.133 | : input-error-data ( -- c-addr1 u1 c-addr2 u2 line# [addr u] ) |
| 924 : | anton | 1.130 | \ error data for the current input, to be used by >error or .error-frame |
| 925 : | pazsan | 1.181 | source over >r save-mem over r> - |
| 926 : | input-lexeme 2@ >r + r> sourceline# | ||
| 927 : | anton | 1.130 | [ has? file [IF] ] sourcefilename [ [THEN] ] ; |
| 928 : | pazsan | 1.64 | |
| 929 : | pazsan | 1.1 | : dec. ( n -- ) \ gforth |
| 930 : | crook | 1.40 | \G Display @i{n} as a signed decimal number, followed by a space. |
| 931 : | \ !! not used... | ||
| 932 : | pazsan | 1.1 | base @ decimal swap . base ! ; |
| 933 : | |||
| 934 : | anton | 1.111 | : dec.r ( u n -- ) \ gforth |
| 935 : | \G Display @i{u} as a unsigned decimal number in a field @i{n} | ||
| 936 : | \G characters wide. | ||
| 937 : | base @ >r decimal .r r> base ! ; | ||
| 938 : | jwilke | 1.23 | |
| 939 : | pazsan | 1.1 | : hex. ( u -- ) \ gforth |
| 940 : | crook | 1.40 | \G Display @i{u} as an unsigned hex number, prefixed with a "$" and |
| 941 : | crook | 1.17 | \G followed by a space. |
| 942 : | crook | 1.40 | \ !! not used... |
| 943 : | jwilke | 1.33 | [char] $ emit base @ swap hex u. base ! ; |
| 944 : | pazsan | 1.1 | |
| 945 : | anton | 1.94 | : -trailing ( c_addr u1 -- c_addr u2 ) \ string dash-trailing |
| 946 : | \G Adjust the string specified by @i{c-addr, u1} to remove all | ||
| 947 : | \G trailing spaces. @i{u2} is the length of the modified string. | ||
| 948 : | BEGIN | ||
| 949 : | pazsan | 1.102 | dup |
| 950 : | anton | 1.94 | WHILE |
| 951 : | pazsan | 1.102 | 1- 2dup + c@ bl <> |
| 952 : | UNTIL 1+ THEN ; | ||
| 953 : | anton | 1.94 | |
| 954 : | pazsan | 1.1 | DEFER DOERROR |
| 955 : | jwilke | 1.33 | |
| 956 : | has? backtrace [IF] | ||
| 957 : | anton | 1.15 | Defer dobacktrace ( -- ) |
| 958 : | ' noop IS dobacktrace | ||
| 959 : | jwilke | 1.33 | [THEN] |
| 960 : | pazsan | 1.1 | |
| 961 : | jwilke | 1.23 | : .error-string ( throw-code -- ) |
| 962 : | dup -2 = | ||
| 963 : | IF "error @ ?dup IF count type THEN drop | ||
| 964 : | ELSE .error | ||
| 965 : | THEN ; | ||
| 966 : | |||
| 967 : | pazsan | 1.187 | [IFUNDEF] umin |
| 968 : | anton | 1.111 | : umin ( u1 u2 -- u ) |
| 969 : | 2dup u> | ||
| 970 : | if | ||
| 971 : | swap | ||
| 972 : | then | ||
| 973 : | drop ; | ||
| 974 : | pazsan | 1.187 | [THEN] |
| 975 : | anton | 1.111 | |
| 976 : | pazsan | 1.112 | Defer mark-start |
| 977 : | Defer mark-end | ||
| 978 : | |||
| 979 : | :noname ." >>>" ; IS mark-start | ||
| 980 : | :noname ." <<<" ; IS mark-end | ||
| 981 : | |||
| 982 : | anton | 1.130 | : part-type ( addr1 u1 u -- addr2 u2 ) |
| 983 : | \ print first u characters of addr1 u1, addr2 u2 is the rest | ||
| 984 : | anton | 1.133 | over umin 2 pick over type /string ; |
| 985 : | anton | 1.130 | |
| 986 : | anton | 1.133 | : .error-line ( c-addr1 u1 c-addr2 u2 -- ) |
| 987 : | \ print error in line c-addr1 u1, where the error-causing lexeme | ||
| 988 : | \ is c-addr2 u2 | ||
| 989 : | >r 2 pick - part-type ( c-addr3 u3 R: u2 ) | ||
| 990 : | mark-start r> part-type mark-end ( c-addr4 u4 ) | ||
| 991 : | type ; | ||
| 992 : | anton | 1.130 | |
| 993 : | anton | 1.133 | : .error-frame ( throwcode addr1 u1 addr2 u2 n2 [addr3 u3] -- throwcode ) |
| 994 : | \ addr3 u3: filename of included file - optional | ||
| 995 : | anton | 1.130 | \ n2: line number |
| 996 : | anton | 1.133 | \ addr2 u2: parsed lexeme (should be marked as causing the error) |
| 997 : | anton | 1.130 | \ addr1 u1: input line |
| 998 : | error-stack @ | ||
| 999 : | IF ( throwcode addr1 u1 n0 n1 n2 [addr2 u2] ) | ||
| 1000 : | [ has? file [IF] ] \ !! unbalanced stack effect | ||
| 1001 : | pazsan | 1.129 | over IF |
| 1002 : | cr ." in file included from " | ||
| 1003 : | type ." :" | ||
| 1004 : | anton | 1.130 | 0 dec.r 2drop 2drop |
| 1005 : | ELSE | ||
| 1006 : | 2drop 2drop 2drop drop | ||
| 1007 : | THEN | ||
| 1008 : | [ [THEN] ] ( throwcode addr1 u1 n0 n1 n2 ) | ||
| 1009 : | ELSE ( throwcode addr1 u1 n0 n1 n2 [addr2 u2] ) | ||
| 1010 : | [ has? file [IF] ] | ||
| 1011 : | cr type ." :" | ||
| 1012 : | [ [THEN] ] ( throwcode addr1 u1 n0 n1 n2 ) | ||
| 1013 : | dup 0 dec.r ." : " 5 pick .error-string | ||
| 1014 : | IF \ if line# non-zero, there is a line | ||
| 1015 : | cr .error-line | ||
| 1016 : | ELSE | ||
| 1017 : | 2drop 2drop | ||
| 1018 : | THEN | ||
| 1019 : | THEN ; | ||
| 1020 : | pazsan | 1.1 | |
| 1021 : | : (DoError) ( throw-code -- ) | ||
| 1022 : | [ has? os [IF] ] | ||
| 1023 : | pazsan | 1.8 | >stderr |
| 1024 : | pazsan | 1.1 | [ [THEN] ] |
| 1025 : | anton | 1.130 | input-error-data .error-frame |
| 1026 : | pazsan | 1.1 | error-stack @ 0 ?DO |
| 1027 : | pazsan | 1.64 | error> |
| 1028 : | pazsan | 1.1 | .error-frame |
| 1029 : | LOOP | ||
| 1030 : | jwilke | 1.33 | drop |
| 1031 : | [ has? backtrace [IF] ] | ||
| 1032 : | dobacktrace | ||
| 1033 : | [ [THEN] ] | ||
| 1034 : | pazsan | 1.8 | normal-dp dpp ! ; |
| 1035 : | pazsan | 1.1 | |
| 1036 : | ' (DoError) IS DoError | ||
| 1037 : | pazsan | 1.131 | |
| 1038 : | [ELSE] | ||
| 1039 : | : dec. base @ >r decimal . r> base ! ; | ||
| 1040 : | pazsan | 1.144 | : DoError ( throw-code -- ) |
| 1041 : | pazsan | 1.145 | cr source drop >in @ type ." <<< " |
| 1042 : | pazsan | 1.144 | dup -2 = IF "error @ type drop EXIT THEN |
| 1043 : | .error ; | ||
| 1044 : | pazsan | 1.131 | [THEN] |
| 1045 : | pazsan | 1.1 | |
| 1046 : | : quit ( ?? -- ?? ) \ core | ||
| 1047 : | crook | 1.27 | \G Empty the return stack, make the user input device |
| 1048 : | \G the input source, enter interpret state and start | ||
| 1049 : | \G the text interpreter. | ||
| 1050 : | pazsan | 1.64 | rp0 @ rp! handler off clear-tibstack |
| 1051 : | [ has? new-input 0= [IF] ] >tib @ >r [ [THEN] ] | ||
| 1052 : | pazsan | 1.1 | BEGIN |
| 1053 : | [ has? compiler [IF] ] | ||
| 1054 : | anton | 1.104 | [compile] [ |
| 1055 : | pazsan | 1.1 | [ [THEN] ] |
| 1056 : | anton | 1.104 | \ stack depths may be arbitrary here |
| 1057 : | pazsan | 1.1 | ['] 'quit CATCH dup |
| 1058 : | WHILE | ||
| 1059 : | anton | 1.104 | <# \ reset hold area, or we may get another error |
| 1060 : | DoError | ||
| 1061 : | \ stack depths may be arbitrary still (or again), so clear them | ||
| 1062 : | clearstacks | ||
| 1063 : | [ has? new-input [IF] ] clear-tibstack | ||
| 1064 : | [ [ELSE] ] r@ >tib ! r@ tibstack ! | ||
| 1065 : | [ [THEN] ] | ||
| 1066 : | pazsan | 1.1 | REPEAT |
| 1067 : | pazsan | 1.64 | drop [ has? new-input [IF] ] clear-tibstack |
| 1068 : | [ [ELSE] ] r> >tib ! | ||
| 1069 : | [ [THEN] ] ; | ||
| 1070 : | pazsan | 1.1 | |
| 1071 : | \ \ Cold Boot 13feb93py | ||
| 1072 : | |||
| 1073 : | pazsan | 1.186 | : gforth ( -- ) |
| 1074 : | anton | 1.101 | ." Gforth " version-string type |
| 1075 : | pazsan | 1.180 | ." , Copyright (C) 1995-2011 Free Software Foundation, Inc." cr |
| 1076 : | anton | 1.101 | ." Gforth comes with ABSOLUTELY NO WARRANTY; for details type `license'" |
| 1077 : | pazsan | 1.1 | [ has? os [IF] ] |
| 1078 : | cr ." Type `bye' to exit" | ||
| 1079 : | [ [THEN] ] ; | ||
| 1080 : | |||
| 1081 : | anton | 1.158 | defer bootmessage ( -- ) \ gforth |
| 1082 : | anton | 1.150 | \G Hook (deferred word) executed right after interpreting the OS |
| 1083 : | \G command-line arguments. Normally prints the Gforth startup | ||
| 1084 : | \G message. | ||
| 1085 : | |||
| 1086 : | pazsan | 1.135 | has? file [IF] |
| 1087 : | pazsan | 1.1 | defer process-args |
| 1088 : | pazsan | 1.135 | [THEN] |
| 1089 : | pazsan | 1.1 | |
| 1090 : | pazsan | 1.186 | ' gforth IS bootmessage |
| 1091 : | pazsan | 1.1 | |
| 1092 : | pazsan | 1.156 | has? os [IF] |
| 1093 : | anton | 1.10 | Defer 'cold ( -- ) \ gforth tick-cold |
| 1094 : | anton | 1.150 | \G Hook (deferred word) for things to do right before interpreting the |
| 1095 : | \G OS command-line arguments. Normally does some initializations that | ||
| 1096 : | \G you also want to perform. | ||
| 1097 : | pazsan | 1.1 | ' noop IS 'cold |
| 1098 : | pazsan | 1.148 | [THEN] |
| 1099 : | pazsan | 1.1 | |
| 1100 : | : cold ( -- ) \ gforth | ||
| 1101 : | pazsan | 1.149 | [ has? backtrace [IF] ] |
| 1102 : | anton | 1.44 | rp@ backtrace-rp0 ! |
| 1103 : | [ [THEN] ] | ||
| 1104 : | pazsan | 1.1 | [ has? file [IF] ] |
| 1105 : | pazsan | 1.78 | os-cold |
| 1106 : | pazsan | 1.1 | [ [THEN] ] |
| 1107 : | pazsan | 1.156 | [ has? os [IF] ] |
| 1108 : | anton | 1.116 | set-encoding-fixed-width |
| 1109 : | pazsan | 1.136 | 'cold |
| 1110 : | pazsan | 1.126 | [ [THEN] ] |
| 1111 : | pazsan | 1.1 | [ has? file [IF] ] |
| 1112 : | pazsan | 1.8 | process-args |
| 1113 : | pazsan | 1.12 | loadline off |
| 1114 : | pazsan | 1.1 | [ [THEN] ] |
| 1115 : | bootmessage | ||
| 1116 : | pazsan | 1.12 | quit ; |
| 1117 : | pazsan | 1.1 | |
| 1118 : | pazsan | 1.64 | has? new-input 0= [IF] |
| 1119 : | anton | 1.5 | : clear-tibstack ( -- ) |
| 1120 : | [ has? glocals [IF] ] | ||
| 1121 : | lp@ forthstart 7 cells + @ - | ||
| 1122 : | [ [ELSE] ] | ||
| 1123 : | [ has? os [IF] ] | ||
| 1124 : | pazsan | 1.8 | r0 @ forthstart 6 cells + @ - |
| 1125 : | anton | 1.5 | [ [ELSE] ] |
| 1126 : | pazsan | 1.139 | sp@ cell+ |
| 1127 : | anton | 1.5 | [ [THEN] ] |
| 1128 : | [ [THEN] ] | ||
| 1129 : | pazsan | 1.138 | dup >tib ! tibstack ! #tib off |
| 1130 : | input-start-line ; | ||
| 1131 : | pazsan | 1.64 | [THEN] |
| 1132 : | anton | 1.5 | |
| 1133 : | pazsan | 1.64 | : boot ( path n **argv argc -- ) |
| 1134 : | pazsan | 1.134 | [ has? no-userspace 0= [IF] ] |
| 1135 : | pazsan | 1.1 | main-task up! |
| 1136 : | pazsan | 1.134 | [ [THEN] ] |
| 1137 : | pazsan | 1.1 | [ has? os [IF] ] |
| 1138 : | pazsan | 1.78 | os-boot |
| 1139 : | pazsan | 1.134 | [ [THEN] ] |
| 1140 : | [ has? rom [IF] ] | ||
| 1141 : | pazsan | 1.147 | ram-shadow dup @ dup -1 <> >r u> r> and IF |
| 1142 : | ram-shadow 2@ ELSE | ||
| 1143 : | ram-mirror ram-size THEN ram-start swap move | ||
| 1144 : | pazsan | 1.1 | [ [THEN] ] |
| 1145 : | sp@ sp0 ! | ||
| 1146 : | pazsan | 1.74 | [ has? peephole [IF] ] |
| 1147 : | anton | 1.87 | \ only needed for greedy static superinstruction selection |
| 1148 : | \ primtable prepare-peephole-table TO peeptable | ||
| 1149 : | pazsan | 1.74 | [ [THEN] ] |
| 1150 : | pazsan | 1.64 | [ has? new-input [IF] ] |
| 1151 : | current-input off | ||
| 1152 : | [ [THEN] ] | ||
| 1153 : | anton | 1.5 | clear-tibstack |
| 1154 : | anton | 1.127 | 0 0 includefilename 2! |
| 1155 : | pazsan | 1.1 | rp@ rp0 ! |
| 1156 : | [ has? floating [IF] ] | ||
| 1157 : | fp@ fp0 ! | ||
| 1158 : | [ [THEN] ] | ||
| 1159 : | pazsan | 1.156 | [ has? os [IF] ] |
| 1160 : | anton | 1.46 | handler off |
| 1161 : | anton | 1.98 | ['] cold catch dup -&2049 <> if \ broken pipe? |
| 1162 : | DoError cr | ||
| 1163 : | endif | ||
| 1164 : | pazsan | 1.149 | [ [ELSE] ] |
| 1165 : | cold | ||
| 1166 : | [ [THEN] ] | ||
| 1167 : | pazsan | 1.1 | [ has? os [IF] ] |
| 1168 : | anton | 1.35 | 1 (bye) \ !! determin exit code from throw code? |
| 1169 : | pazsan | 1.1 | [ [THEN] ] |
| 1170 : | ; | ||
| 1171 : | |||
| 1172 : | has? os [IF] | ||
| 1173 : | : bye ( -- ) \ tools-ext | ||
| 1174 : | [ has? file [IF] ] | ||
| 1175 : | script? 0= IF cr THEN | ||
| 1176 : | [ [ELSE] ] | ||
| 1177 : | cr | ||
| 1178 : | [ [THEN] ] | ||
| 1179 : | 0 (bye) ; | ||
| 1180 : | [THEN] | ||
| 1181 : | |||
| 1182 : | \ **argv may be scanned by the C starter to get some important | ||
| 1183 : | \ information, as -display and -geometry for an X client FORTH | ||
| 1184 : | \ or space and stackspace overrides | ||
| 1185 : | |||
| 1186 : | \ 0 arg contains, however, the name of the program. | ||
| 1187 : |
|
CVS Admin Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |