Powered by ViewCVS 1.0-dev
| 1 : | pazsan | 1.1 | \ definitions needed for interpreter only |
| 2 : | |||
| 3 : | anton | 1.11 | \ Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc. |
| 4 : | |||
| 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 : | \ as published by the Free Software Foundation; either version 2 | ||
| 10 : | \ 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 : | \ along with this program; if not, write to the Free Software | ||
| 19 : | \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. | ||
| 20 : | |||
| 21 : | pazsan | 1.1 | \ \ Revision-Log |
| 22 : | |||
| 23 : | \ put in seperate file 14sep97jaw | ||
| 24 : | |||
| 25 : | \ \ input stream primitives 23feb93py | ||
| 26 : | |||
| 27 : | : tib ( -- c-addr ) \ core-ext | ||
| 28 : | \ obsolescent | ||
| 29 : | >tib @ ; | ||
| 30 : | |||
| 31 : | Defer source ( -- addr count ) \ core | ||
| 32 : | \ used by dodefer:, must be defer | ||
| 33 : | |||
| 34 : | : (source) ( -- addr count ) | ||
| 35 : | tib #tib @ ; | ||
| 36 : | ' (source) IS source | ||
| 37 : | |||
| 38 : | : (word) ( addr1 n1 char -- addr2 n2 ) | ||
| 39 : | dup >r skip 2dup r> scan nip - ; | ||
| 40 : | |||
| 41 : | \ (word) should fold white spaces | ||
| 42 : | \ this is what (parse-white) does | ||
| 43 : | |||
| 44 : | \ word parse 23feb93py | ||
| 45 : | |||
| 46 : | anton | 1.3 | : sword ( char -- addr len ) \ gforth |
| 47 : | \G parses like @code{word}, but the output is like @code{parse} output | ||
| 48 : | \ this word was called PARSE-WORD until 0.3.0, but Open Firmware and | ||
| 49 : | \ dpANS6 A.6.2.2008 have a word with that name that behaves | ||
| 50 : | \ differently (like NAME). | ||
| 51 : | pazsan | 1.1 | source 2dup >r >r >in @ over min /string |
| 52 : | rot dup bl = IF drop (parse-white) ELSE (word) THEN | ||
| 53 : | 2dup + r> - 1+ r> min >in ! ; | ||
| 54 : | |||
| 55 : | : word ( char -- addr ) \ core | ||
| 56 : | anton | 1.3 | sword here place bl here count + c! here ; |
| 57 : | pazsan | 1.1 | |
| 58 : | : parse ( char -- addr len ) \ core-ext | ||
| 59 : | >r source >in @ over min /string over swap r> scan >r | ||
| 60 : | over - dup r> IF 1+ THEN >in +! ; | ||
| 61 : | |||
| 62 : | \ name 13feb93py | ||
| 63 : | |||
| 64 : | [IFUNDEF] (name) \ name might be a primitive | ||
| 65 : | |||
| 66 : | : (name) ( -- c-addr count ) | ||
| 67 : | source 2dup >r >r >in @ /string (parse-white) | ||
| 68 : | 2dup + r> - 1+ r> min >in ! ; | ||
| 69 : | \ name count ; | ||
| 70 : | [THEN] | ||
| 71 : | |||
| 72 : | : name-too-short? ( c-addr u -- c-addr u ) | ||
| 73 : | dup 0= -&16 and throw ; | ||
| 74 : | |||
| 75 : | : name-too-long? ( c-addr u -- c-addr u ) | ||
| 76 : | dup $1F u> -&19 and throw ; | ||
| 77 : | |||
| 78 : | \ \ Number parsing 23feb93py | ||
| 79 : | |||
| 80 : | \ number? number 23feb93py | ||
| 81 : | |||
| 82 : | hex | ||
| 83 : | const Create bases 10 , 2 , A , 100 , | ||
| 84 : | \ 16 2 10 character | ||
| 85 : | \ !! this saving and restoring base is an abomination! - anton | ||
| 86 : | |||
| 87 : | : getbase ( addr u -- addr' u' ) | ||
| 88 : | over c@ [char] $ - dup 4 u< | ||
| 89 : | IF | ||
| 90 : | cells bases + @ base ! 1 /string | ||
| 91 : | ELSE | ||
| 92 : | drop | ||
| 93 : | THEN ; | ||
| 94 : | |||
| 95 : | : s>number ( addr len -- d ) | ||
| 96 : | base @ >r dpl on | ||
| 97 : | over c@ '- = dup >r | ||
| 98 : | IF | ||
| 99 : | 1 /string | ||
| 100 : | THEN | ||
| 101 : | getbase dpl on 0 0 2swap | ||
| 102 : | BEGIN | ||
| 103 : | dup >r >number dup | ||
| 104 : | WHILE | ||
| 105 : | dup r> - | ||
| 106 : | WHILE | ||
| 107 : | dup dpl ! over c@ [char] . = | ||
| 108 : | WHILE | ||
| 109 : | 1 /string | ||
| 110 : | REPEAT THEN | ||
| 111 : | 2drop rdrop dpl off | ||
| 112 : | ELSE | ||
| 113 : | 2drop rdrop r> | ||
| 114 : | IF | ||
| 115 : | dnegate | ||
| 116 : | THEN | ||
| 117 : | THEN | ||
| 118 : | r> base ! ; | ||
| 119 : | |||
| 120 : | : snumber? ( c-addr u -- 0 / n -1 / d 0> ) | ||
| 121 : | s>number dpl @ 0= | ||
| 122 : | IF | ||
| 123 : | 2drop false EXIT | ||
| 124 : | THEN | ||
| 125 : | dpl @ dup 0> 0= IF | ||
| 126 : | nip | ||
| 127 : | THEN ; | ||
| 128 : | |||
| 129 : | : number? ( string -- string 0 / n -1 / d 0> ) | ||
| 130 : | dup >r count snumber? dup if | ||
| 131 : | rdrop | ||
| 132 : | else | ||
| 133 : | r> swap | ||
| 134 : | then ; | ||
| 135 : | |||
| 136 : | : number ( string -- d ) | ||
| 137 : | number? ?dup 0= abort" ?" 0< | ||
| 138 : | IF | ||
| 139 : | s>d | ||
| 140 : | THEN ; | ||
| 141 : | |||
| 142 : | \ \ Comments ( \ \G | ||
| 143 : | |||
| 144 : | : ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ core,file paren | ||
| 145 : | [char] ) parse 2drop ; immediate | ||
| 146 : | |||
| 147 : | : \ ( -- ) \ core-ext backslash | ||
| 148 : | pazsan | 1.12 | [ has? file [IF] ] |
| 149 : | pazsan | 1.1 | blk @ |
| 150 : | IF | ||
| 151 : | >in @ c/l / 1+ c/l * >in ! | ||
| 152 : | EXIT | ||
| 153 : | THEN | ||
| 154 : | pazsan | 1.12 | [ [THEN] ] |
| 155 : | pazsan | 1.1 | source >in ! drop ; immediate |
| 156 : | |||
| 157 : | : \G ( -- ) \ gforth backslash | ||
| 158 : | POSTPONE \ ; immediate | ||
| 159 : | |||
| 160 : | \ \ object oriented search list 17mar93py | ||
| 161 : | |||
| 162 : | \ word list structure: | ||
| 163 : | |||
| 164 : | struct | ||
| 165 : | cell% field find-method \ xt: ( c_addr u wid -- nt ) | ||
| 166 : | cell% field reveal-method \ xt: ( nt wid -- ) \ used by dofield:, must be field | ||
| 167 : | cell% field rehash-method \ xt: ( wid -- ) \ re-initializes a "search-data" (hashtables) | ||
| 168 : | cell% field hash-method \ xt: ( wid -- ) \ initializes "" | ||
| 169 : | \ \ !! what else | ||
| 170 : | end-struct wordlist-map-struct | ||
| 171 : | |||
| 172 : | struct | ||
| 173 : | pazsan | 1.6 | cell% field wordlist-map \ pointer to a wordlist-map-struct |
| 174 : | anton | 1.13 | cell% field wordlist-id \ linked list of words (for WORDS etc.) |
| 175 : | pazsan | 1.1 | cell% field wordlist-link \ link field to other wordlists |
| 176 : | anton | 1.13 | cell% field wordlist-extend \ wordlist extensions (eg bucket offset) |
| 177 : | pazsan | 1.1 | end-struct wordlist-struct |
| 178 : | |||
| 179 : | : f83find ( addr len wordlist -- nt / false ) | ||
| 180 : | pazsan | 1.6 | wordlist-id @ (f83find) ; |
| 181 : | pazsan | 1.1 | |
| 182 : | : initvoc ( wid -- ) | ||
| 183 : | dup wordlist-map @ hash-method perform ; | ||
| 184 : | |||
| 185 : | \ Search list table: find reveal | ||
| 186 : | Create f83search ( -- wordlist-map ) | ||
| 187 : | ' f83find A, ' drop A, ' drop A, ' drop A, | ||
| 188 : | |||
| 189 : | pazsan | 1.6 | here G f83search T A, NIL A, NIL A, NIL A, |
| 190 : | pazsan | 1.1 | AValue forth-wordlist \ variable, will be redefined by search.fs |
| 191 : | |||
| 192 : | AVariable lookup forth-wordlist lookup ! | ||
| 193 : | \ !! last is user and lookup?! jaw | ||
| 194 : | AVariable current ( -- addr ) \ gforth | ||
| 195 : | AVariable voclink forth-wordlist wordlist-link voclink ! | ||
| 196 : | lookup AValue context | ||
| 197 : | |||
| 198 : | forth-wordlist current ! | ||
| 199 : | |||
| 200 : | \ \ header, finding, ticks 17dec92py | ||
| 201 : | |||
| 202 : | $80 constant alias-mask \ set when the word is not an alias! | ||
| 203 : | $40 constant immediate-mask | ||
| 204 : | $20 constant restrict-mask | ||
| 205 : | |||
| 206 : | \ higher level parts of find | ||
| 207 : | |||
| 208 : | : flag-sign ( f -- 1|-1 ) | ||
| 209 : | \ true becomes 1, false -1 | ||
| 210 : | 0= 2* 1+ ; | ||
| 211 : | |||
| 212 : | : compile-only-error ( ... -- ) | ||
| 213 : | -&14 throw ; | ||
| 214 : | |||
| 215 : | : (cfa>int) ( cfa -- xt ) | ||
| 216 : | [ has? compiler [IF] ] | ||
| 217 : | dup interpret/compile? | ||
| 218 : | if | ||
| 219 : | interpret/compile-int @ | ||
| 220 : | then | ||
| 221 : | [ [THEN] ] ; | ||
| 222 : | |||
| 223 : | : (x>int) ( cfa b -- xt ) | ||
| 224 : | \ get interpretation semantics of name | ||
| 225 : | restrict-mask and | ||
| 226 : | if | ||
| 227 : | drop ['] compile-only-error | ||
| 228 : | else | ||
| 229 : | (cfa>int) | ||
| 230 : | then ; | ||
| 231 : | |||
| 232 : | : name>string ( nt -- addr count ) \ gforth head-to-string | ||
| 233 : | \g @var{addr count} is the name of the word represented by @var{nt}. | ||
| 234 : | cell+ count $1F and ; | ||
| 235 : | |||
| 236 : | : ((name>)) ( nfa -- cfa ) | ||
| 237 : | name>string + cfaligned ; | ||
| 238 : | |||
| 239 : | : (name>x) ( nfa -- cfa b ) | ||
| 240 : | \ cfa is an intermediate cfa and b is the flags byte of nfa | ||
| 241 : | dup ((name>)) | ||
| 242 : | swap cell+ c@ dup alias-mask and 0= | ||
| 243 : | IF | ||
| 244 : | swap @ swap | ||
| 245 : | THEN ; | ||
| 246 : | |||
| 247 : | : name>int ( nt -- xt ) \ gforth | ||
| 248 : | \G @var{xt} represents the interpretation semantics of the word | ||
| 249 : | \G @var{nt}. Produces @code{' compile-only-error} if | ||
| 250 : | \G @var{nt} is compile-only. | ||
| 251 : | (name>x) (x>int) ; | ||
| 252 : | |||
| 253 : | : name?int ( nt -- xt ) \ gforth | ||
| 254 : | \G Like name>int, but throws an error if compile-only. | ||
| 255 : | (name>x) restrict-mask and | ||
| 256 : | if | ||
| 257 : | compile-only-error \ does not return | ||
| 258 : | then | ||
| 259 : | (cfa>int) ; | ||
| 260 : | |||
| 261 : | : (name>comp) ( nt -- w +-1 ) \ gforth | ||
| 262 : | \G @var{w xt} is the compilation token for the word @var{nt}. | ||
| 263 : | (name>x) >r | ||
| 264 : | [ has? compiler [IF] ] | ||
| 265 : | dup interpret/compile? | ||
| 266 : | if | ||
| 267 : | interpret/compile-comp @ | ||
| 268 : | then | ||
| 269 : | [ [THEN] ] | ||
| 270 : | r> immediate-mask and flag-sign | ||
| 271 : | ; | ||
| 272 : | |||
| 273 : | : (name>intn) ( nfa -- xt +-1 ) | ||
| 274 : | (name>x) tuck (x>int) ( b xt ) | ||
| 275 : | swap immediate-mask and flag-sign ; | ||
| 276 : | |||
| 277 : | anton | 1.14 | : head? ( addr -- f ) |
| 278 : | \G heuristic check whether addr is a name token; may deliver false | ||
| 279 : | \G positives; addr must be a valid address | ||
| 280 : | \ we follow the link fields and check for plausibility; two | ||
| 281 : | \ iterations should catch most false addresses: on the first | ||
| 282 : | \ iteration, we may get an xt, on the second a code address (or | ||
| 283 : | \ some code), which is typically not in the dictionary. | ||
| 284 : | 2 0 do | ||
| 285 : | dup @ dup | ||
| 286 : | if ( addr addr1 ) | ||
| 287 : | dup rot forthstart within | ||
| 288 : | if \ addr1 is outside forthstart..addr, not a head | ||
| 289 : | drop false unloop exit | ||
| 290 : | then ( addr1 ) | ||
| 291 : | else \ 0 in the link field, no further checks | ||
| 292 : | 2drop true unloop exit | ||
| 293 : | then | ||
| 294 : | loop | ||
| 295 : | \ in dubio pro: | ||
| 296 : | drop true ; | ||
| 297 : | |||
| 298 : | pazsan | 1.1 | const Create ??? 0 , 3 c, char ? c, char ? c, char ? c, |
| 299 : | \ ??? is used by dovar:, must be created/:dovar | ||
| 300 : | |||
| 301 : | anton | 1.14 | : >head ( cfa -- nt ) \ gforth to-head |
| 302 : | $21 cell do ( cfa ) | ||
| 303 : | dup i - count $9F and + cfaligned over alias-mask + = | ||
| 304 : | if ( cfa ) | ||
| 305 : | dup i - cell - dup head? | ||
| 306 : | if | ||
| 307 : | nip unloop exit | ||
| 308 : | then | ||
| 309 : | drop | ||
| 310 : | then | ||
| 311 : | cell +loop | ||
| 312 : | drop ??? ( wouldn't 0 be better? ) ; | ||
| 313 : | pazsan | 1.1 | |
| 314 : | ' >head ALIAS >name | ||
| 315 : | |||
| 316 : | : body> 0 >body - ; | ||
| 317 : | |||
| 318 : | : (search-wordlist) ( addr count wid -- nt / false ) | ||
| 319 : | dup wordlist-map @ find-method perform ; | ||
| 320 : | |||
| 321 : | : search-wordlist ( addr count wid -- 0 / xt +-1 ) \ search | ||
| 322 : | \ xt is the interpretation semantics | ||
| 323 : | (search-wordlist) dup if | ||
| 324 : | (name>intn) | ||
| 325 : | then ; | ||
| 326 : | |||
| 327 : | : find-name ( c-addr u -- nt/0 ) \ gforth | ||
| 328 : | \g Find the name @var{c-addr u} in the current search | ||
| 329 : | \g order. Return its nt, if found, otherwise 0. | ||
| 330 : | lookup @ (search-wordlist) ; | ||
| 331 : | |||
| 332 : | : sfind ( c-addr u -- 0 / xt +-1 ) \ gforth-obsolete | ||
| 333 : | find-name dup | ||
| 334 : | if ( nt ) | ||
| 335 : | state @ | ||
| 336 : | if | ||
| 337 : | (name>comp) | ||
| 338 : | else | ||
| 339 : | (name>intn) | ||
| 340 : | then | ||
| 341 : | then ; | ||
| 342 : | |||
| 343 : | : find ( c-addr -- xt +-1 / c-addr 0 ) \ core,search | ||
| 344 : | dup count sfind dup | ||
| 345 : | if | ||
| 346 : | rot drop | ||
| 347 : | then ; | ||
| 348 : | |||
| 349 : | \ ticks | ||
| 350 : | |||
| 351 : | : (') ( "name" -- nt ) \ gforth | ||
| 352 : | name find-name dup 0= | ||
| 353 : | IF | ||
| 354 : | drop -&13 bounce | ||
| 355 : | THEN ; | ||
| 356 : | |||
| 357 : | : ' ( "name" -- xt ) \ core tick | ||
| 358 : | \g @var{xt} represents @var{name}'s interpretation | ||
| 359 : | \g semantics. Performs @code{-14 throw} if the word has no | ||
| 360 : | \g interpretation semantics. | ||
| 361 : | (') name?int ; | ||
| 362 : | |||
| 363 : | \ \ the interpreter loop mar92py | ||
| 364 : | |||
| 365 : | \ interpret 10mar92py | ||
| 366 : | |||
| 367 : | Defer parser | ||
| 368 : | Defer name ( -- c-addr count ) \ gforth | ||
| 369 : | \ get the next word from the input buffer | ||
| 370 : | ' (name) IS name | ||
| 371 : | Defer compiler-notfound ( c-addr count -- ) | ||
| 372 : | Defer interpreter-notfound ( c-addr count -- ) | ||
| 373 : | |||
| 374 : | : no.extensions ( addr u -- ) | ||
| 375 : | 2drop -&13 bounce ; | ||
| 376 : | ' no.extensions IS compiler-notfound | ||
| 377 : | ' no.extensions IS interpreter-notfound | ||
| 378 : | |||
| 379 : | : interpret ( ?? -- ?? ) \ gforth | ||
| 380 : | \ interpret/compile the (rest of the) input buffer | ||
| 381 : | BEGIN | ||
| 382 : | ?stack name dup | ||
| 383 : | WHILE | ||
| 384 : | parser | ||
| 385 : | REPEAT | ||
| 386 : | 2drop ; | ||
| 387 : | |||
| 388 : | \ interpreter 30apr92py | ||
| 389 : | |||
| 390 : | \ not the most efficient implementations of interpreter and compiler | ||
| 391 : | pazsan | 1.12 | | : interpreter ( c-addr u -- ) |
| 392 : | pazsan | 1.1 | 2dup find-name dup |
| 393 : | if | ||
| 394 : | nip nip name>int execute | ||
| 395 : | else | ||
| 396 : | drop | ||
| 397 : | 2dup 2>r snumber? | ||
| 398 : | IF | ||
| 399 : | 2rdrop | ||
| 400 : | ELSE | ||
| 401 : | 2r> interpreter-notfound | ||
| 402 : | THEN | ||
| 403 : | then ; | ||
| 404 : | |||
| 405 : | ' interpreter IS parser | ||
| 406 : | |||
| 407 : | \ \ Query Evaluate 07apr93py | ||
| 408 : | |||
| 409 : | has? file 0= [IF] | ||
| 410 : | pazsan | 1.12 | : sourceline# ( -- n ) 1 ; |
| 411 : | pazsan | 1.1 | [THEN] |
| 412 : | |||
| 413 : | : refill ( -- flag ) \ core-ext,block-ext,file-ext | ||
| 414 : | pazsan | 1.12 | [ has? file [IF] ] |
| 415 : | blk @ IF 1 blk +! true 0 >in ! EXIT THEN | ||
| 416 : | [ [THEN] ] | ||
| 417 : | tib /line | ||
| 418 : | [ has? file [IF] ] | ||
| 419 : | loadfile @ ?dup | ||
| 420 : | IF read-line throw | ||
| 421 : | ELSE | ||
| 422 : | [ [THEN] ] | ||
| 423 : | sourceline# 0< IF 2drop false EXIT THEN | ||
| 424 : | accept true | ||
| 425 : | [ has? file [IF] ] | ||
| 426 : | THEN | ||
| 427 : | 1 loadline +! | ||
| 428 : | [ [THEN] ] | ||
| 429 : | swap #tib ! 0 >in ! ; | ||
| 430 : | pazsan | 1.1 | |
| 431 : | : query ( -- ) \ core-ext | ||
| 432 : | \G obsolescent | ||
| 433 : | pazsan | 1.12 | [ has? file [IF] ] |
| 434 : | blk off loadfile off | ||
| 435 : | [ [THEN] ] | ||
| 436 : | pazsan | 1.1 | tib /line accept #tib ! 0 >in ! ; |
| 437 : | |||
| 438 : | \ save-mem extend-mem | ||
| 439 : | |||
| 440 : | has? os [IF] | ||
| 441 : | : save-mem ( addr1 u -- addr2 u ) \ gforth | ||
| 442 : | \g copy a memory block into a newly allocated region in the heap | ||
| 443 : | swap >r | ||
| 444 : | dup allocate throw | ||
| 445 : | swap 2dup r> -rot move ; | ||
| 446 : | |||
| 447 : | : extend-mem ( addr1 u1 u -- addr addr2 u2 ) | ||
| 448 : | \ extend memory block allocated from the heap by u aus | ||
| 449 : | \ the (possibly reallocated piece is addr2 u2, the extension is at addr | ||
| 450 : | over >r + dup >r resize throw | ||
| 451 : | r> over r> + -rot ; | ||
| 452 : | [THEN] | ||
| 453 : | |||
| 454 : | \ EVALUATE 17may93jaw | ||
| 455 : | |||
| 456 : | has? file 0= [IF] | ||
| 457 : | : push-file ( -- ) r> | ||
| 458 : | pazsan | 1.12 | tibstack @ >r >tib @ >r #tib @ >r |
| 459 : | pazsan | 1.1 | >tib @ tibstack @ = IF r@ tibstack +! THEN |
| 460 : | tibstack @ >tib ! >in @ >r >r ; | ||
| 461 : | |||
| 462 : | : pop-file ( throw-code -- throw-code ) | ||
| 463 : | r> | ||
| 464 : | pazsan | 1.12 | r> >in ! r> #tib ! r> >tib ! r> tibstack ! >r ; |
| 465 : | pazsan | 1.1 | [THEN] |
| 466 : | |||
| 467 : | : evaluate ( c-addr len -- ) \ core,block | ||
| 468 : | push-file #tib ! >tib ! | ||
| 469 : | pazsan | 1.12 | >in off |
| 470 : | [ has? file [IF] ] | ||
| 471 : | blk off loadfile off -1 loadline ! | ||
| 472 : | [ [THEN] ] | ||
| 473 : | pazsan | 1.1 | ['] interpret catch |
| 474 : | pop-file throw ; | ||
| 475 : | |||
| 476 : | \ \ Quit 13feb93py | ||
| 477 : | |||
| 478 : | Defer 'quit | ||
| 479 : | |||
| 480 : | Defer .status | ||
| 481 : | |||
| 482 : | : prompt state @ IF ." compiled" EXIT THEN ." ok" ; | ||
| 483 : | |||
| 484 : | : (Query) ( -- ) | ||
| 485 : | pazsan | 1.12 | [ has? file [IF] ] |
| 486 : | loadfile off blk off loadline off | ||
| 487 : | [ [THEN] ] | ||
| 488 : | refill drop ; | ||
| 489 : | pazsan | 1.1 | |
| 490 : | : (quit) BEGIN .status cr (query) interpret prompt AGAIN ; | ||
| 491 : | |||
| 492 : | ' (quit) IS 'quit | ||
| 493 : | |||
| 494 : | \ \ DOERROR (DOERROR) 13jun93jaw | ||
| 495 : | |||
| 496 : | 8 Constant max-errors | ||
| 497 : | Variable error-stack 0 error-stack ! | ||
| 498 : | max-errors 6 * cells allot | ||
| 499 : | \ format of one cell: | ||
| 500 : | \ source ( addr u ) | ||
| 501 : | \ >in | ||
| 502 : | \ line-number | ||
| 503 : | \ Loadfilename ( addr u ) | ||
| 504 : | |||
| 505 : | : dec. ( n -- ) \ gforth | ||
| 506 : | \ print value in decimal representation | ||
| 507 : | base @ decimal swap . base ! ; | ||
| 508 : | |||
| 509 : | : hex. ( u -- ) \ gforth | ||
| 510 : | \ print value as unsigned hex number | ||
| 511 : | '$ emit base @ swap hex u. base ! ; | ||
| 512 : | |||
| 513 : | : typewhite ( addr u -- ) \ gforth | ||
| 514 : | \ like type, but white space is printed instead of the characters | ||
| 515 : | bounds ?do | ||
| 516 : | i c@ #tab = if \ check for tab | ||
| 517 : | #tab | ||
| 518 : | else | ||
| 519 : | bl | ||
| 520 : | then | ||
| 521 : | emit | ||
| 522 : | loop ; | ||
| 523 : | |||
| 524 : | DEFER DOERROR | ||
| 525 : | |||
| 526 : | : .error-frame ( addr1 u1 n1 n2 addr2 u2 -- ) | ||
| 527 : | cr error-stack @ | ||
| 528 : | IF | ||
| 529 : | ." in file included from " | ||
| 530 : | type ." :" dec. drop 2drop | ||
| 531 : | ELSE | ||
| 532 : | type ." :" dec. | ||
| 533 : | cr dup 2over type cr drop | ||
| 534 : | nip -trailing 1- ( line-start index2 ) | ||
| 535 : | 0 >r BEGIN | ||
| 536 : | 2dup + c@ bl > WHILE | ||
| 537 : | r> 1+ >r 1- dup 0< UNTIL THEN 1+ | ||
| 538 : | ( line-start index1 ) | ||
| 539 : | typewhite | ||
| 540 : | r> 1 max 0 ?do \ we want at least one "^", even if the length is 0 | ||
| 541 : | [char] ^ emit | ||
| 542 : | loop | ||
| 543 : | THEN | ||
| 544 : | ; | ||
| 545 : | |||
| 546 : | : (DoError) ( throw-code -- ) | ||
| 547 : | [ has? os [IF] ] | ||
| 548 : | pazsan | 1.8 | >stderr |
| 549 : | pazsan | 1.1 | [ [THEN] ] |
| 550 : | sourceline# IF | ||
| 551 : | pazsan | 1.8 | source >in @ sourceline# 0 0 .error-frame |
| 552 : | pazsan | 1.1 | THEN |
| 553 : | error-stack @ 0 ?DO | ||
| 554 : | -1 error-stack +! | ||
| 555 : | error-stack dup @ 6 * cells + cell+ | ||
| 556 : | 6 cells bounds DO | ||
| 557 : | I @ | ||
| 558 : | cell +LOOP | ||
| 559 : | .error-frame | ||
| 560 : | LOOP | ||
| 561 : | dup -2 = | ||
| 562 : | IF | ||
| 563 : | "error @ ?dup | ||
| 564 : | IF | ||
| 565 : | cr count type | ||
| 566 : | THEN | ||
| 567 : | drop | ||
| 568 : | ELSE | ||
| 569 : | .error | ||
| 570 : | THEN | ||
| 571 : | pazsan | 1.8 | normal-dp dpp ! ; |
| 572 : | pazsan | 1.1 | |
| 573 : | ' (DoError) IS DoError | ||
| 574 : | |||
| 575 : | : quit ( ?? -- ?? ) \ core | ||
| 576 : | anton | 1.5 | rp0 @ rp! handler off clear-tibstack >tib @ >r |
| 577 : | pazsan | 1.1 | BEGIN |
| 578 : | [ has? compiler [IF] ] | ||
| 579 : | postpone [ | ||
| 580 : | [ [THEN] ] | ||
| 581 : | ['] 'quit CATCH dup | ||
| 582 : | WHILE | ||
| 583 : | DoError r@ >tib ! r@ tibstack ! | ||
| 584 : | REPEAT | ||
| 585 : | drop r> >tib ! ; | ||
| 586 : | |||
| 587 : | \ \ Cold Boot 13feb93py | ||
| 588 : | |||
| 589 : | : (bootmessage) | ||
| 590 : | ." GForth " version-string type | ||
| 591 : | anton | 1.11 | ." , Copyright (C) 1998 Free Software Foundation, Inc." cr |
| 592 : | pazsan | 1.1 | ." GForth comes with ABSOLUTELY NO WARRANTY; for details type `license'" |
| 593 : | [ has? os [IF] ] | ||
| 594 : | cr ." Type `bye' to exit" | ||
| 595 : | [ [THEN] ] ; | ||
| 596 : | |||
| 597 : | defer bootmessage | ||
| 598 : | defer process-args | ||
| 599 : | |||
| 600 : | ' (bootmessage) IS bootmessage | ||
| 601 : | |||
| 602 : | anton | 1.10 | Defer 'cold ( -- ) \ gforth tick-cold |
| 603 : | pazsan | 1.1 | \ hook (deferred word) for things to do right before interpreting the |
| 604 : | \ command-line arguments | ||
| 605 : | ' noop IS 'cold | ||
| 606 : | |||
| 607 : | anton | 1.2 | include ../chains.fs |
| 608 : | pazsan | 1.1 | |
| 609 : | Variable init8 | ||
| 610 : | |||
| 611 : | : cold ( -- ) \ gforth | ||
| 612 : | [ has? file [IF] ] | ||
| 613 : | pathstring 2@ fpath only-path | ||
| 614 : | init-included-files | ||
| 615 : | [ [THEN] ] | ||
| 616 : | 'cold | ||
| 617 : | init8 chainperform | ||
| 618 : | [ has? file [IF] ] | ||
| 619 : | pazsan | 1.8 | process-args |
| 620 : | pazsan | 1.12 | loadline off |
| 621 : | pazsan | 1.1 | [ [THEN] ] |
| 622 : | bootmessage | ||
| 623 : | pazsan | 1.12 | quit ; |
| 624 : | pazsan | 1.1 | |
| 625 : | anton | 1.5 | : clear-tibstack ( -- ) |
| 626 : | [ has? glocals [IF] ] | ||
| 627 : | lp@ forthstart 7 cells + @ - | ||
| 628 : | [ [ELSE] ] | ||
| 629 : | [ has? os [IF] ] | ||
| 630 : | pazsan | 1.8 | r0 @ forthstart 6 cells + @ - |
| 631 : | anton | 1.5 | [ [ELSE] ] |
| 632 : | sp@ $40 + | ||
| 633 : | [ [THEN] ] | ||
| 634 : | [ [THEN] ] | ||
| 635 : | dup >tib ! tibstack ! #tib off >in off ; | ||
| 636 : | |||
| 637 : | pazsan | 1.1 | : boot ( path **argv argc -- ) |
| 638 : | main-task up! | ||
| 639 : | [ has? os [IF] ] | ||
| 640 : | stdout TO outfile-id | ||
| 641 : | pazsan | 1.7 | stdin TO infile-id |
| 642 : | pazsan | 1.1 | \ !! [ [THEN] ] |
| 643 : | \ !! [ has? file [IF] ] | ||
| 644 : | argc ! argv ! pathstring 2! | ||
| 645 : | [ [THEN] ] | ||
| 646 : | sp@ sp0 ! | ||
| 647 : | anton | 1.5 | clear-tibstack |
| 648 : | pazsan | 1.1 | rp@ rp0 ! |
| 649 : | [ has? floating [IF] ] | ||
| 650 : | fp@ fp0 ! | ||
| 651 : | [ [THEN] ] | ||
| 652 : | pazsan | 1.8 | ['] cold catch DoError cr |
| 653 : | pazsan | 1.1 | [ has? os [IF] ] |
| 654 : | bye | ||
| 655 : | [ [THEN] ] | ||
| 656 : | ; | ||
| 657 : | |||
| 658 : | has? os [IF] | ||
| 659 : | : bye ( -- ) \ tools-ext | ||
| 660 : | [ has? file [IF] ] | ||
| 661 : | script? 0= IF cr THEN | ||
| 662 : | [ [ELSE] ] | ||
| 663 : | cr | ||
| 664 : | [ [THEN] ] | ||
| 665 : | 0 (bye) ; | ||
| 666 : | [THEN] | ||
| 667 : | |||
| 668 : | \ **argv may be scanned by the C starter to get some important | ||
| 669 : | \ information, as -display and -geometry for an X client FORTH | ||
| 670 : | \ or space and stackspace overrides | ||
| 671 : | |||
| 672 : | \ 0 arg contains, however, the name of the program. | ||
| 673 : |
|
CVS Admin Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |