Powered by ViewCVS 1.0-dev
| 1 : | anton | 1.1 | \ definitions needed for interpreter / compiler only |
| 2 : | |||
| 3 : | doer? :docon [IF] | ||
| 4 : | : docon: ( -- addr ) \ gforth | ||
| 5 : | \G the code address of a @code{CONSTANT} | ||
| 6 : | ['] bl >code-address ; | ||
| 7 : | [THEN] | ||
| 8 : | |||
| 9 : | : docol: ( -- addr ) \ gforth | ||
| 10 : | \G the code address of a colon definition | ||
| 11 : | ['] docol: >code-address ; | ||
| 12 : | |||
| 13 : | doer? :dovar [IF] | ||
| 14 : | : dovar: ( -- addr ) \ gforth | ||
| 15 : | \G the code address of a @code{CREATE}d word | ||
| 16 : | ['] udp >code-address ; | ||
| 17 : | [THEN] | ||
| 18 : | |||
| 19 : | doer? :douser [IF] | ||
| 20 : | : douser: ( -- addr ) \ gforth | ||
| 21 : | \G the code address of a @code{USER} variable | ||
| 22 : | ['] s0 >code-address ; | ||
| 23 : | [THEN] | ||
| 24 : | |||
| 25 : | doer? :dodefer [IF] | ||
| 26 : | : dodefer: ( -- addr ) \ gforth | ||
| 27 : | \G the code address of a @code{defer}ed word | ||
| 28 : | ['] source >code-address ; | ||
| 29 : | [THEN] | ||
| 30 : | |||
| 31 : | doer? :dofield [IF] | ||
| 32 : | : dofield: ( -- addr ) \ gforth | ||
| 33 : | \G the code address of a @code{field} | ||
| 34 : | ['] reveal-method >code-address ; | ||
| 35 : | [THEN] | ||
| 36 : | |||
| 37 : | .( test1 ) | ||
| 38 : | has-prims 0= [IF] | ||
| 39 : | : dodoes: ( -- addr ) \ gforth | ||
| 40 : | \G the code address of a @code{field} | ||
| 41 : | ['] spaces >code-address ; | ||
| 42 : | .( test2 ) | ||
| 43 : | [THEN] | ||
| 44 : | |||
| 45 : | \ here allot , c, A, 17dec92py | ||
| 46 : | |||
| 47 : | : allot ( n -- ) \ core | ||
| 48 : | dp +! ; | ||
| 49 : | : c, ( c -- ) \ core | ||
| 50 : | here 1 chars allot c! ; | ||
| 51 : | : , ( x -- ) \ core | ||
| 52 : | here cell allot ! ; | ||
| 53 : | : 2, ( w1 w2 -- ) \ gforth | ||
| 54 : | here 2 cells allot 2! ; | ||
| 55 : | |||
| 56 : | \ : aligned ( addr -- addr' ) \ core | ||
| 57 : | \ [ cell 1- ] Literal + [ -1 cells ] Literal and ; | ||
| 58 : | : align ( -- ) \ core | ||
| 59 : | here dup aligned swap ?DO bl c, LOOP ; | ||
| 60 : | |||
| 61 : | \ : faligned ( addr -- f-addr ) \ float | ||
| 62 : | \ [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ; | ||
| 63 : | |||
| 64 : | : falign ( -- ) \ float | ||
| 65 : | here dup faligned swap | ||
| 66 : | ?DO | ||
| 67 : | bl c, | ||
| 68 : | LOOP ; | ||
| 69 : | |||
| 70 : | : maxalign ( -- ) \ float | ||
| 71 : | here dup maxaligned swap | ||
| 72 : | ?DO | ||
| 73 : | bl c, | ||
| 74 : | LOOP ; | ||
| 75 : | |||
| 76 : | \ the code field is aligned if its body is maxaligned | ||
| 77 : | ' maxalign Alias cfalign ( -- ) \ gforth | ||
| 78 : | |||
| 79 : | ' , alias A, ( addr -- ) \ gforth | ||
| 80 : | |||
| 81 : | \ name> found 17dec92py | ||
| 82 : | |||
| 83 : | $80 constant alias-mask \ set when the word is not an alias! | ||
| 84 : | $40 constant immediate-mask | ||
| 85 : | $20 constant restrict-mask | ||
| 86 : | |||
| 87 : | : ((name>)) ( nfa -- cfa ) | ||
| 88 : | name>string + cfaligned ; | ||
| 89 : | |||
| 90 : | : (name>x) ( nfa -- cfa b ) | ||
| 91 : | \ cfa is an intermediate cfa and b is the flags byte of nfa | ||
| 92 : | dup ((name>)) | ||
| 93 : | swap cell+ c@ dup alias-mask and 0= | ||
| 94 : | IF | ||
| 95 : | swap @ swap | ||
| 96 : | THEN ; | ||
| 97 : | |||
| 98 : | \ input stream primitives 23feb93py | ||
| 99 : | |||
| 100 : | : tib ( -- c-addr ) \ core-ext | ||
| 101 : | \ obsolescent | ||
| 102 : | >tib @ ; | ||
| 103 : | Defer source ( -- addr count ) \ core | ||
| 104 : | \ used by dodefer:, must be defer | ||
| 105 : | : (source) ( -- addr count ) | ||
| 106 : | tib #tib @ ; | ||
| 107 : | ' (source) IS source | ||
| 108 : | |||
| 109 : | : (word) ( addr1 n1 char -- addr2 n2 ) | ||
| 110 : | dup >r skip 2dup r> scan nip - ; | ||
| 111 : | |||
| 112 : | \ (word) should fold white spaces | ||
| 113 : | \ this is what (parse-white) does | ||
| 114 : | |||
| 115 : | \ word parse 23feb93py | ||
| 116 : | |||
| 117 : | : parse-word ( char -- addr len ) \ gforth | ||
| 118 : | source 2dup >r >r >in @ over min /string | ||
| 119 : | rot dup bl = IF drop (parse-white) ELSE (word) THEN | ||
| 120 : | 2dup + r> - 1+ r> min >in ! ; | ||
| 121 : | : word ( char -- addr ) \ core | ||
| 122 : | parse-word here place bl here count + c! here ; | ||
| 123 : | |||
| 124 : | : parse ( char -- addr len ) \ core-ext | ||
| 125 : | >r source >in @ over min /string over swap r> scan >r | ||
| 126 : | over - dup r> IF 1+ THEN >in +! ; | ||
| 127 : | |||
| 128 : | \ name 13feb93py | ||
| 129 : | |||
| 130 : | : capitalize ( addr len -- addr len ) \ gforth | ||
| 131 : | 2dup chars chars bounds | ||
| 132 : | ?DO I c@ toupper I c! 1 chars +LOOP ; | ||
| 133 : | : (name) ( -- c-addr count ) | ||
| 134 : | source 2dup >r >r >in @ /string (parse-white) | ||
| 135 : | 2dup + r> - 1+ r> min >in ! ; | ||
| 136 : | \ name count ; | ||
| 137 : | |||
| 138 : | : name-too-short? ( c-addr u -- c-addr u ) | ||
| 139 : | dup 0= -&16 and throw ; | ||
| 140 : | |||
| 141 : | : name-too-long? ( c-addr u -- c-addr u ) | ||
| 142 : | dup $1F u> -&19 and throw ; | ||
| 143 : | |||
| 144 : | \ Literal 17dec92py | ||
| 145 : | |||
| 146 : | : Literal ( compilation n -- ; run-time -- n ) \ core | ||
| 147 : | postpone lit , ; immediate restrict | ||
| 148 : | : ALiteral ( compilation addr -- ; run-time -- addr ) \ gforth | ||
| 149 : | postpone lit A, ; immediate restrict | ||
| 150 : | |||
| 151 : | : char ( 'char' -- n ) \ core | ||
| 152 : | bl word char+ c@ ; | ||
| 153 : | : [char] ( compilation 'char' -- ; run-time -- n ) | ||
| 154 : | char postpone Literal ; immediate restrict | ||
| 155 : | |||
| 156 : | : (compile) ( -- ) \ gforth | ||
| 157 : | r> dup cell+ >r @ compile, ; | ||
| 158 : | |||
| 159 : | : postpone, ( w xt -- ) | ||
| 160 : | \g Compiles the compilation semantics represented by @var{w xt}. | ||
| 161 : | dup ['] execute = | ||
| 162 : | if | ||
| 163 : | drop compile, | ||
| 164 : | else | ||
| 165 : | dup ['] compile, = | ||
| 166 : | if | ||
| 167 : | drop POSTPONE (compile) compile, | ||
| 168 : | else | ||
| 169 : | swap POSTPONE aliteral compile, | ||
| 170 : | then | ||
| 171 : | then ; | ||
| 172 : | |||
| 173 : | : POSTPONE ( "name" -- ) \ core | ||
| 174 : | \g Compiles the compilation semantics of @var{name}. | ||
| 175 : | COMP' postpone, ; immediate restrict | ||
| 176 : | |||
| 177 : | : interpret/compile: ( interp-xt comp-xt "name" -- ) \ gforth | ||
| 178 : | Create immediate swap A, A, | ||
| 179 : | DOES> | ||
| 180 : | abort" executed primary cfa of an interpret/compile: word" ; | ||
| 181 : | \ state @ IF cell+ THEN perform ; | ||
| 182 : | |||
| 183 : | \ number? number 23feb93py | ||
| 184 : | |||
| 185 : | hex | ||
| 186 : | Create bases 10 , 2 , A , 100 , | ||
| 187 : | \ 16 2 10 character | ||
| 188 : | \ !! this saving and restoring base is an abomination! - anton | ||
| 189 : | : getbase ( addr u -- addr' u' ) | ||
| 190 : | over c@ [char] $ - dup 4 u< | ||
| 191 : | IF | ||
| 192 : | cells bases + @ base ! 1 /string | ||
| 193 : | ELSE | ||
| 194 : | drop | ||
| 195 : | THEN ; | ||
| 196 : | : s>number ( addr len -- d ) | ||
| 197 : | base @ >r dpl on | ||
| 198 : | over c@ '- = dup >r | ||
| 199 : | IF | ||
| 200 : | 1 /string | ||
| 201 : | THEN | ||
| 202 : | getbase dpl on 0 0 2swap | ||
| 203 : | BEGIN | ||
| 204 : | dup >r >number dup | ||
| 205 : | WHILE | ||
| 206 : | dup r> - | ||
| 207 : | WHILE | ||
| 208 : | dup dpl ! over c@ [char] . = | ||
| 209 : | WHILE | ||
| 210 : | 1 /string | ||
| 211 : | REPEAT THEN | ||
| 212 : | 2drop rdrop dpl off | ||
| 213 : | ELSE | ||
| 214 : | 2drop rdrop r> | ||
| 215 : | IF | ||
| 216 : | dnegate | ||
| 217 : | THEN | ||
| 218 : | THEN | ||
| 219 : | r> base ! ; | ||
| 220 : | |||
| 221 : | : snumber? ( c-addr u -- 0 / n -1 / d 0> ) | ||
| 222 : | s>number dpl @ 0= | ||
| 223 : | IF | ||
| 224 : | 2drop false EXIT | ||
| 225 : | THEN | ||
| 226 : | dpl @ dup 0> 0= IF | ||
| 227 : | nip | ||
| 228 : | THEN ; | ||
| 229 : | |||
| 230 : | : number? ( string -- string 0 / n -1 / d 0> ) | ||
| 231 : | dup >r count snumber? dup if | ||
| 232 : | rdrop | ||
| 233 : | else | ||
| 234 : | r> swap | ||
| 235 : | then ; | ||
| 236 : | |||
| 237 : | : number ( string -- d ) | ||
| 238 : | number? ?dup 0= abort" ?" 0< | ||
| 239 : | IF | ||
| 240 : | s>d | ||
| 241 : | THEN ; | ||
| 242 : | |||
| 243 : | \ interpret 10mar92py | ||
| 244 : | |||
| 245 : | Defer parser | ||
| 246 : | Defer name ( -- c-addr count ) \ gforth | ||
| 247 : | \ get the next word from the input buffer | ||
| 248 : | ' (name) IS name | ||
| 249 : | Defer compiler-notfound ( c-addr count -- ) | ||
| 250 : | Defer interpreter-notfound ( c-addr count -- ) | ||
| 251 : | |||
| 252 : | : no.extensions ( addr u -- ) | ||
| 253 : | 2drop -&13 bounce ; | ||
| 254 : | ' no.extensions IS compiler-notfound | ||
| 255 : | ' no.extensions IS interpreter-notfound | ||
| 256 : | |||
| 257 : | : compile-only-error ( ... -- ) | ||
| 258 : | -&14 throw ; | ||
| 259 : | |||
| 260 : | : interpret ( ?? -- ?? ) \ gforth | ||
| 261 : | \ interpret/compile the (rest of the) input buffer | ||
| 262 : | BEGIN | ||
| 263 : | ?stack name dup | ||
| 264 : | WHILE | ||
| 265 : | parser | ||
| 266 : | REPEAT | ||
| 267 : | 2drop ; | ||
| 268 : | |||
| 269 : | \ interpreter compiler 30apr92py | ||
| 270 : | |||
| 271 : | \ not the most efficient implementations of interpreter and compiler | ||
| 272 : | : interpreter ( c-addr u -- ) | ||
| 273 : | 2dup find-name dup | ||
| 274 : | if | ||
| 275 : | nip nip name>int execute | ||
| 276 : | else | ||
| 277 : | drop | ||
| 278 : | 2dup 2>r snumber? | ||
| 279 : | IF | ||
| 280 : | 2rdrop | ||
| 281 : | ELSE | ||
| 282 : | 2r> interpreter-notfound | ||
| 283 : | THEN | ||
| 284 : | then ; | ||
| 285 : | |||
| 286 : | : compiler ( c-addr u -- ) | ||
| 287 : | 2dup find-name dup | ||
| 288 : | if ( c-addr u nt ) | ||
| 289 : | nip nip name>comp execute | ||
| 290 : | else | ||
| 291 : | drop | ||
| 292 : | 2dup snumber? dup | ||
| 293 : | IF | ||
| 294 : | 0> | ||
| 295 : | IF | ||
| 296 : | swap postpone Literal | ||
| 297 : | THEN | ||
| 298 : | postpone Literal | ||
| 299 : | 2drop | ||
| 300 : | ELSE | ||
| 301 : | drop compiler-notfound | ||
| 302 : | THEN | ||
| 303 : | then ; | ||
| 304 : | |||
| 305 : | ' interpreter IS parser | ||
| 306 : | |||
| 307 : | : [ ( -- ) \ core left-bracket | ||
| 308 : | ['] interpreter IS parser state off ; immediate | ||
| 309 : | : ] ( -- ) \ core right-bracket | ||
| 310 : | ['] compiler IS parser state on ; | ||
| 311 : | |||
| 312 : | \ Strings 22feb93py | ||
| 313 : | |||
| 314 : | : ," ( "string"<"> -- ) [char] " parse | ||
| 315 : | here over char+ allot place align ; | ||
| 316 : | : SLiteral ( Compilation c-addr1 u ; run-time -- c-addr2 u ) \ string | ||
| 317 : | postpone (S") here over char+ allot place align ; | ||
| 318 : | immediate restrict | ||
| 319 : | : ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ core,file paren | ||
| 320 : | [char] ) parse 2drop ; immediate | ||
| 321 : | |||
| 322 : | : \ ( -- ) \ core-ext backslash | ||
| 323 : | blk @ | ||
| 324 : | IF | ||
| 325 : | >in @ c/l / 1+ c/l * >in ! | ||
| 326 : | EXIT | ||
| 327 : | THEN | ||
| 328 : | source >in ! drop ; immediate | ||
| 329 : | |||
| 330 : | : \G ( -- ) \ gforth backslash | ||
| 331 : | POSTPONE \ ; immediate | ||
| 332 : | |||
| 333 : | \ error handling 22feb93py | ||
| 334 : | \ 'abort thrown out! 11may93jaw | ||
| 335 : | |||
| 336 : | : abort" ( compilation 'ccc"' -- ; run-time f -- ) \ core,exception-ext abort-quote | ||
| 337 : | postpone (abort") ," ; immediate restrict | ||
| 338 : | |||
| 339 : | \ Header states 23feb93py | ||
| 340 : | |||
| 341 : | : cset ( bmask c-addr -- ) | ||
| 342 : | tuck c@ or swap c! ; | ||
| 343 : | : creset ( bmask c-addr -- ) | ||
| 344 : | tuck c@ swap invert and swap c! ; | ||
| 345 : | : ctoggle ( bmask c-addr -- ) | ||
| 346 : | tuck c@ xor swap c! ; | ||
| 347 : | |||
| 348 : | : lastflags ( -- c-addr ) | ||
| 349 : | \ the address of the flags byte in the last header | ||
| 350 : | \ aborts if the last defined word was headerless | ||
| 351 : | last @ dup 0= abort" last word was headerless" cell+ ; | ||
| 352 : | |||
| 353 : | : immediate ( -- ) \ core | ||
| 354 : | immediate-mask lastflags cset ; | ||
| 355 : | : restrict ( -- ) \ gforth | ||
| 356 : | restrict-mask lastflags cset ; | ||
| 357 : | ' restrict alias compile-only ( -- ) \ gforth | ||
| 358 : | |||
| 359 : | \ Header 23feb93py | ||
| 360 : | |||
| 361 : | \ input-stream, nextname and noname are quite ugly (passing | ||
| 362 : | \ information through global variables), but they are useful for dealing | ||
| 363 : | \ with existing/independent defining words | ||
| 364 : | |||
| 365 : | defer (header) | ||
| 366 : | defer header ( -- ) \ gforth | ||
| 367 : | ' (header) IS header | ||
| 368 : | |||
| 369 : | : string, ( c-addr u -- ) \ gforth | ||
| 370 : | \G puts down string as cstring | ||
| 371 : | dup c, here swap chars dup allot move ; | ||
| 372 : | |||
| 373 : | : header, ( c-addr u -- ) \ gforth | ||
| 374 : | name-too-long? | ||
| 375 : | align here last ! | ||
| 376 : | current @ 1 or A, \ link field; before revealing, it contains the | ||
| 377 : | \ tagged reveal-into wordlist | ||
| 378 : | string, cfalign | ||
| 379 : | alias-mask lastflags cset ; | ||
| 380 : | |||
| 381 : | : input-stream-header ( "name" -- ) | ||
| 382 : | name name-too-short? header, ; | ||
| 383 : | : input-stream ( -- ) \ general | ||
| 384 : | \G switches back to getting the name from the input stream ; | ||
| 385 : | ['] input-stream-header IS (header) ; | ||
| 386 : | |||
| 387 : | ' input-stream-header IS (header) | ||
| 388 : | |||
| 389 : | \ !! make that a 2variable | ||
| 390 : | create nextname-buffer 32 chars allot | ||
| 391 : | |||
| 392 : | : nextname-header ( -- ) | ||
| 393 : | nextname-buffer count header, | ||
| 394 : | input-stream ; | ||
| 395 : | |||
| 396 : | \ the next name is given in the string | ||
| 397 : | : nextname ( c-addr u -- ) \ gforth | ||
| 398 : | name-too-long? | ||
| 399 : | nextname-buffer c! ( c-addr ) | ||
| 400 : | nextname-buffer count move | ||
| 401 : | ['] nextname-header IS (header) ; | ||
| 402 : | |||
| 403 : | : noname-header ( -- ) | ||
| 404 : | 0 last ! cfalign | ||
| 405 : | input-stream ; | ||
| 406 : | |||
| 407 : | : noname ( -- ) \ gforth | ||
| 408 : | \ the next defined word remains anonymous. The xt of that word is given by lastxt | ||
| 409 : | ['] noname-header IS (header) ; | ||
| 410 : | |||
| 411 : | : lastxt ( -- xt ) \ gforth | ||
| 412 : | \ xt is the execution token of the last word defined. The main purpose of this word is to get the xt of words defined using noname | ||
| 413 : | lastcfa @ ; | ||
| 414 : | |||
| 415 : | : Alias ( cfa "name" -- ) \ gforth | ||
| 416 : | Header reveal | ||
| 417 : | alias-mask lastflags creset | ||
| 418 : | dup A, lastcfa ! ; | ||
| 419 : | |||
| 420 : | : name>string ( nt -- addr count ) \ gforth name-to-string | ||
| 421 : | \g @var{addr count} is the name of the word represented by @var{nt}. | ||
| 422 : | cell+ count $1F and ; | ||
| 423 : | |||
| 424 : | Create ??? 0 , 3 c, char ? c, char ? c, char ? c, | ||
| 425 : | : >name ( cfa -- nt ) \ gforth to-name | ||
| 426 : | $21 cell do | ||
| 427 : | dup i - count $9F and + cfaligned over alias-mask + = if | ||
| 428 : | i - cell - unloop exit | ||
| 429 : | then | ||
| 430 : | cell +loop | ||
| 431 : | drop ??? ( wouldn't 0 be better? ) ; | ||
| 432 : | |||
| 433 : | \ threading 17mar93py | ||
| 434 : | |||
| 435 : | : cfa, ( code-address -- ) \ gforth cfa-comma | ||
| 436 : | here | ||
| 437 : | dup lastcfa ! | ||
| 438 : | 0 A, 0 , code-address! ; | ||
| 439 : | : compile, ( xt -- ) \ core-ext compile-comma | ||
| 440 : | A, ; | ||
| 441 : | : !does ( addr -- ) \ gforth store-does | ||
| 442 : | lastxt does-code! ; | ||
| 443 : | : (does>) ( R: addr -- ) | ||
| 444 : | r> cfaligned /does-handler + !does ; | ||
| 445 : | : dodoes, ( -- ) | ||
| 446 : | cfalign here /does-handler allot does-handler! ; | ||
| 447 : | |||
| 448 : | doer? :dovar [IF] | ||
| 449 : | : Create ( "name" -- ) \ core | ||
| 450 : | Header reveal dovar: cfa, ; | ||
| 451 : | [ELSE] | ||
| 452 : | : Create ( "name" -- ) \ core | ||
| 453 : | Header reveal here lastcfa ! 0 A, 0 , DOES> ; | ||
| 454 : | [THEN] | ||
| 455 : | |||
| 456 : | \ Create Variable User Constant 17mar93py | ||
| 457 : | |||
| 458 : | : Variable ( "name" -- ) \ core | ||
| 459 : | Create 0 , ; | ||
| 460 : | : AVariable ( "name" -- ) \ gforth | ||
| 461 : | Create 0 A, ; | ||
| 462 : | : 2Variable ( "name" -- ) \ double | ||
| 463 : | create 0 , 0 , ; | ||
| 464 : | |||
| 465 : | : uallot ( n -- ) udp @ swap udp +! ; | ||
| 466 : | |||
| 467 : | doer? :douser [IF] | ||
| 468 : | : User ( "name" -- ) \ gforth | ||
| 469 : | Header reveal douser: cfa, cell uallot , ; | ||
| 470 : | : AUser ( "name" -- ) \ gforth | ||
| 471 : | User ; | ||
| 472 : | [ELSE] | ||
| 473 : | : User Create uallot , DOES> @ up @ + ; | ||
| 474 : | : AUser User ; | ||
| 475 : | [THEN] | ||
| 476 : | |||
| 477 : | doer? :docon [IF] | ||
| 478 : | : (Constant) Header reveal docon: cfa, ; | ||
| 479 : | [ELSE] | ||
| 480 : | : (Constant) Create DOES> @ ; | ||
| 481 : | [THEN] | ||
| 482 : | : Constant ( w "name" -- ) \ core | ||
| 483 : | \G Defines constant @var{name} | ||
| 484 : | \G | ||
| 485 : | \G @var{name} execution: @var{-- w} | ||
| 486 : | (Constant) , ; | ||
| 487 : | : AConstant ( addr "name" -- ) \ gforth | ||
| 488 : | (Constant) A, ; | ||
| 489 : | : Value ( w "name" -- ) \ core-ext | ||
| 490 : | (Constant) , ; | ||
| 491 : | |||
| 492 : | : 2Constant ( w1 w2 "name" -- ) \ double | ||
| 493 : | Create ( w1 w2 "name" -- ) | ||
| 494 : | 2, | ||
| 495 : | DOES> ( -- w1 w2 ) | ||
| 496 : | 2@ ; | ||
| 497 : | |||
| 498 : | doer? :dofield [IF] | ||
| 499 : | : (Field) Header reveal dofield: cfa, ; | ||
| 500 : | [ELSE] | ||
| 501 : | : (Field) Create DOES> @ + ; | ||
| 502 : | [THEN] | ||
| 503 : | \ IS Defer What's Defers TO 24feb93py | ||
| 504 : | |||
| 505 : | doer? :dodefer [IF] | ||
| 506 : | : Defer ( "name" -- ) \ gforth | ||
| 507 : | \ !! shouldn't it be initialized with abort or something similar? | ||
| 508 : | Header Reveal dodefer: cfa, | ||
| 509 : | ['] noop A, ; | ||
| 510 : | [ELSE] | ||
| 511 : | : Defer ( "name" -- ) \ gforth | ||
| 512 : | Create ['] noop A, | ||
| 513 : | DOES> @ execute ; | ||
| 514 : | [THEN] | ||
| 515 : | |||
| 516 : | : Defers ( "name" -- ) \ gforth | ||
| 517 : | ' >body @ compile, ; immediate | ||
| 518 : | |||
| 519 : | \ : ; 24feb93py | ||
| 520 : | |||
| 521 : | defer :-hook ( sys1 -- sys2 ) | ||
| 522 : | defer ;-hook ( sys2 -- sys1 ) | ||
| 523 : | |||
| 524 : | : : ( "name" -- colon-sys ) \ core colon | ||
| 525 : | Header docol: cfa, defstart ] :-hook ; | ||
| 526 : | : ; ( compilation colon-sys -- ; run-time nest-sys ) \ core semicolon | ||
| 527 : | ;-hook ?struc postpone exit reveal postpone [ ; immediate restrict | ||
| 528 : | |||
| 529 : | : :noname ( -- xt colon-sys ) \ core-ext colon-no-name | ||
| 530 : | 0 last ! | ||
| 531 : | cfalign here docol: cfa, 0 ] :-hook ; | ||
| 532 : | |||
| 533 : | \ Search list handling 23feb93py | ||
| 534 : | |||
| 535 : | AVariable current ( -- addr ) \ gforth | ||
| 536 : | |||
| 537 : | : last? ( -- false / nfa nfa ) | ||
| 538 : | last @ ?dup ; | ||
| 539 : | : (reveal) ( nt wid -- ) | ||
| 540 : | ( wid>wordlist-id ) dup >r | ||
| 541 : | @ over ( name>link ) ! | ||
| 542 : | r> ! ; | ||
| 543 : | |||
| 544 : | \ object oriented search list 17mar93py | ||
| 545 : | |||
| 546 : | \ word list structure: | ||
| 547 : | |||
| 548 : | struct | ||
| 549 : | 1 cells: field find-method \ xt: ( c_addr u wid -- nt ) | ||
| 550 : | 1 cells: field reveal-method \ xt: ( nt wid -- ) \ used by dofield:, must be field | ||
| 551 : | 1 cells: field rehash-method \ xt: ( wid -- ) | ||
| 552 : | \ \ !! what else | ||
| 553 : | end-struct wordlist-map-struct | ||
| 554 : | |||
| 555 : | struct | ||
| 556 : | 1 cells: field wordlist-id \ not the same as wid; representation depends on implementation | ||
| 557 : | 1 cells: field wordlist-map \ pointer to a wordlist-map-struct | ||
| 558 : | 1 cells: field wordlist-link \ link field to other wordlists | ||
| 559 : | 1 cells: field wordlist-extend \ points to wordlist extensions (eg hash) | ||
| 560 : | end-struct wordlist-struct | ||
| 561 : | |||
| 562 : | : f83find ( addr len wordlist -- nt / false ) | ||
| 563 : | ( wid>wordlist-id ) @ (f83find) ; | ||
| 564 : | |||
| 565 : | \ Search list table: find reveal | ||
| 566 : | Create f83search ( -- wordlist-map ) | ||
| 567 : | ' f83find A, ' (reveal) A, ' drop A, | ||
| 568 : | |||
| 569 : | Create forth-wordlist NIL A, G f83search T A, NIL A, NIL A, | ||
| 570 : | AVariable lookup G forth-wordlist lookup T ! | ||
| 571 : | G forth-wordlist current T ! | ||
| 572 : | |||
| 573 : | \ higher level parts of find | ||
| 574 : | |||
| 575 : | ( struct ) | ||
| 576 : | 0 >body cell | ||
| 577 : | 1 cells: field interpret/compile-int | ||
| 578 : | 1 cells: field interpret/compile-comp | ||
| 579 : | end-struct interpret/compile-struct | ||
| 580 : | |||
| 581 : | : interpret/compile? ( xt -- flag ) | ||
| 582 : | >does-code ['] S" >does-code = ; | ||
| 583 : | |||
| 584 : | : (cfa>int) ( cfa -- xt ) | ||
| 585 : | dup interpret/compile? | ||
| 586 : | if | ||
| 587 : | interpret/compile-int @ | ||
| 588 : | then ; | ||
| 589 : | |||
| 590 : | : (x>int) ( cfa b -- xt ) | ||
| 591 : | \ get interpretation semantics of name | ||
| 592 : | restrict-mask and | ||
| 593 : | if | ||
| 594 : | drop ['] compile-only-error | ||
| 595 : | else | ||
| 596 : | (cfa>int) | ||
| 597 : | then ; | ||
| 598 : | |||
| 599 : | : name>int ( nt -- xt ) \ gforth | ||
| 600 : | \G @var{xt} represents the interpretation semantics of the word | ||
| 601 : | \G @var{nt}. Produces @code{' compile-only-error} if | ||
| 602 : | \G @var{nt} is compile-only. | ||
| 603 : | (name>x) (x>int) ; | ||
| 604 : | |||
| 605 : | : name?int ( nt -- xt ) \ gforth | ||
| 606 : | \G Like name>int, but throws an error if compile-only. | ||
| 607 : | (name>x) restrict-mask and | ||
| 608 : | if | ||
| 609 : | compile-only-error \ does not return | ||
| 610 : | then | ||
| 611 : | (cfa>int) ; | ||
| 612 : | |||
| 613 : | : name>comp ( nt -- w xt ) \ gforth | ||
| 614 : | \G @var{w xt} is the compilation token for the word @var{nt}. | ||
| 615 : | (name>x) >r dup interpret/compile? | ||
| 616 : | if | ||
| 617 : | interpret/compile-comp @ | ||
| 618 : | then | ||
| 619 : | r> immediate-mask and if | ||
| 620 : | ['] execute | ||
| 621 : | else | ||
| 622 : | ['] compile, | ||
| 623 : | then ; | ||
| 624 : | |||
| 625 : | : (search-wordlist) ( addr count wid -- nt / false ) | ||
| 626 : | dup wordlist-map @ find-method perform ; | ||
| 627 : | |||
| 628 : | : flag-sign ( f -- 1|-1 ) | ||
| 629 : | \ true becomes 1, false -1 | ||
| 630 : | 0= 2* 1+ ; | ||
| 631 : | |||
| 632 : | : (name>intn) ( nfa -- xt +-1 ) | ||
| 633 : | (name>x) tuck (x>int) ( b xt ) | ||
| 634 : | swap immediate-mask and flag-sign ; | ||
| 635 : | |||
| 636 : | : search-wordlist ( addr count wid -- 0 / xt +-1 ) \ search | ||
| 637 : | \ xt is the interpretation semantics | ||
| 638 : | (search-wordlist) dup if | ||
| 639 : | (name>intn) | ||
| 640 : | then ; | ||
| 641 : | |||
| 642 : | : find-name ( c-addr u -- nt/0 ) \ gforth | ||
| 643 : | \g Find the name @var{c-addr u} in the current search | ||
| 644 : | \g order. Return its nt, if found, otherwise 0. | ||
| 645 : | lookup @ (search-wordlist) ; | ||
| 646 : | |||
| 647 : | : sfind ( c-addr u -- 0 / xt +-1 ) \ gforth-obsolete | ||
| 648 : | find-name dup | ||
| 649 : | if ( nt ) | ||
| 650 : | state @ | ||
| 651 : | if | ||
| 652 : | name>comp ['] execute = flag-sign | ||
| 653 : | else | ||
| 654 : | (name>intn) | ||
| 655 : | then | ||
| 656 : | then ; | ||
| 657 : | |||
| 658 : | : find ( c-addr -- xt +-1 / c-addr 0 ) \ core,search | ||
| 659 : | dup count sfind dup | ||
| 660 : | if | ||
| 661 : | rot drop | ||
| 662 : | then ; | ||
| 663 : | |||
| 664 : | : (') ( "name" -- nt ) \ gforth | ||
| 665 : | name find-name dup 0= | ||
| 666 : | IF | ||
| 667 : | drop -&13 bounce | ||
| 668 : | THEN ; | ||
| 669 : | |||
| 670 : | : [(')] ( compilation "name" -- ; run-time -- nt ) \ gforth bracket-paren-tick | ||
| 671 : | (') postpone ALiteral ; immediate restrict | ||
| 672 : | |||
| 673 : | : ' ( "name" -- xt ) \ core tick | ||
| 674 : | \g @var{xt} represents @var{name}'s interpretation | ||
| 675 : | \g semantics. Performs @code{-14 throw} if the word has no | ||
| 676 : | \g interpretation semantics. | ||
| 677 : | (') name?int ; | ||
| 678 : | : ['] ( compilation. "name" -- ; run-time. -- xt ) \ core bracket-tick | ||
| 679 : | \g @var{xt} represents @var{name}'s interpretation | ||
| 680 : | \g semantics. Performs @code{-14 throw} if the word has no | ||
| 681 : | \g interpretation semantics. | ||
| 682 : | ' postpone ALiteral ; immediate restrict | ||
| 683 : | |||
| 684 : | : COMP' ( "name" -- w xt ) \ gforth c-tick | ||
| 685 : | \g @var{w xt} represents @var{name}'s compilation semantics. | ||
| 686 : | (') name>comp ; | ||
| 687 : | : [COMP'] ( compilation "name" -- ; run-time -- w xt ) \ gforth bracket-comp-tick | ||
| 688 : | \g @var{w xt} represents @var{name}'s compilation semantics. | ||
| 689 : | COMP' swap POSTPONE Aliteral POSTPONE ALiteral ; immediate restrict | ||
| 690 : | |||
| 691 : | \ reveal words | ||
| 692 : | |||
| 693 : | Variable warnings ( -- addr ) \ gforth | ||
| 694 : | G -1 warnings T ! | ||
| 695 : | |||
| 696 : | : check-shadow ( addr count wid -- ) | ||
| 697 : | \G prints a warning if the string is already present in the wordlist | ||
| 698 : | >r 2dup 2dup r> (search-wordlist) warnings @ and ?dup if | ||
| 699 : | ." redefined " name>string 2dup type | ||
| 700 : | compare 0<> if | ||
| 701 : | ." with " type | ||
| 702 : | else | ||
| 703 : | 2drop | ||
| 704 : | then | ||
| 705 : | space space EXIT | ||
| 706 : | then | ||
| 707 : | 2drop 2drop ; | ||
| 708 : | |||
| 709 : | : reveal ( -- ) \ gforth | ||
| 710 : | last? | ||
| 711 : | if \ the last word has a header | ||
| 712 : | dup ( name>link ) @ 1 and | ||
| 713 : | if \ it is still hidden | ||
| 714 : | dup ( name>link ) @ 1 xor ( nt wid ) | ||
| 715 : | 2dup >r name>string r> check-shadow ( nt wid ) | ||
| 716 : | dup wordlist-map @ reveal-method perform | ||
| 717 : | then | ||
| 718 : | then ; | ||
| 719 : | |||
| 720 : | : rehash ( wid -- ) | ||
| 721 : | dup wordlist-map @ rehash-method perform ; | ||
| 722 : | |||
| 723 : | \ Query 07apr93py | ||
| 724 : | |||
| 725 : | has-files 0= [IF] | ||
| 726 : | : sourceline# ( -- n ) loadline @ ; | ||
| 727 : | [THEN] | ||
| 728 : | |||
| 729 : | : refill ( -- flag ) \ core-ext,block-ext,file-ext | ||
| 730 : | blk @ IF 1 blk +! true 0 >in ! EXIT THEN | ||
| 731 : | tib /line | ||
| 732 : | [ has-files [IF] ] | ||
| 733 : | loadfile @ ?dup | ||
| 734 : | IF read-line throw | ||
| 735 : | ELSE | ||
| 736 : | [ [THEN] ] | ||
| 737 : | sourceline# 0< IF 2drop false EXIT THEN | ||
| 738 : | accept true | ||
| 739 : | [ has-files [IF] ] | ||
| 740 : | THEN | ||
| 741 : | [ [THEN] ] | ||
| 742 : | 1 loadline +! | ||
| 743 : | swap #tib ! 0 >in ! ; | ||
| 744 : | |||
| 745 : | : query ( -- ) \ core-ext | ||
| 746 : | \G obsolescent | ||
| 747 : | blk off loadfile off | ||
| 748 : | tib /line accept #tib ! 0 >in ! ; | ||
| 749 : | |||
| 750 : | \ save-mem extend-mem | ||
| 751 : | |||
| 752 : | has-os [IF] | ||
| 753 : | : save-mem ( addr1 u -- addr2 u ) \ gforth | ||
| 754 : | \g copy a memory block into a newly allocated region in the heap | ||
| 755 : | swap >r | ||
| 756 : | dup allocate throw | ||
| 757 : | swap 2dup r> -rot move ; | ||
| 758 : | |||
| 759 : | : extend-mem ( addr1 u1 u -- addr addr2 u2 ) | ||
| 760 : | \ extend memory block allocated from the heap by u aus | ||
| 761 : | \ the (possibly reallocated piece is addr2 u2, the extension is at addr | ||
| 762 : | over >r + dup >r resize throw | ||
| 763 : | r> over r> + -rot ; | ||
| 764 : | [THEN] | ||
| 765 : | |||
| 766 : | \ RECURSE 17may93jaw | ||
| 767 : | |||
| 768 : | : recurse ( compilation -- ; run-time ?? -- ?? ) \ core | ||
| 769 : | lastxt compile, ; immediate restrict | ||
| 770 : | ' reveal alias recursive ( -- ) \ gforth | ||
| 771 : | immediate | ||
| 772 : | |||
| 773 : | \ EVALUATE 17may93jaw | ||
| 774 : | |||
| 775 : | has-files 0= [IF] | ||
| 776 : | : push-file ( -- ) r> | ||
| 777 : | sourceline# >r tibstack @ >r >tib @ >r #tib @ >r | ||
| 778 : | >tib @ tibstack @ = IF r@ tibstack +! THEN | ||
| 779 : | tibstack @ >tib ! >in @ >r >r ; | ||
| 780 : | |||
| 781 : | : pop-file ( throw-code -- throw-code ) | ||
| 782 : | r> | ||
| 783 : | r> >in ! r> #tib ! r> >tib ! r> tibstack ! r> loadline ! >r ; | ||
| 784 : | [THEN] | ||
| 785 : | |||
| 786 : | : evaluate ( c-addr len -- ) \ core,block | ||
| 787 : | push-file #tib ! >tib ! | ||
| 788 : | >in off blk off loadfile off -1 loadline ! | ||
| 789 : | ['] interpret catch | ||
| 790 : | pop-file throw ; | ||
| 791 : | |||
| 792 : | : abort ( ?? -- ?? ) \ core,exception-ext | ||
| 793 : | -1 throw ; | ||
| 794 : | |||
| 795 : | \+ environment? true ENV" CORE" | ||
| 796 : | \ core wordset is now complete! | ||
| 797 : | |||
| 798 : | \ Quit 13feb93py | ||
| 799 : | |||
| 800 : | Defer 'quit | ||
| 801 : | Defer .status | ||
| 802 : | : prompt state @ IF ." compiled" EXIT THEN ." ok" ; | ||
| 803 : | : (Query) ( -- ) | ||
| 804 : | loadfile off blk off refill drop ; | ||
| 805 : | : (quit) BEGIN .status cr (query) interpret prompt AGAIN ; | ||
| 806 : | ' (quit) IS 'quit | ||
| 807 : | |||
| 808 : | \ DOERROR (DOERROR) 13jun93jaw | ||
| 809 : | |||
| 810 : | 8 Constant max-errors | ||
| 811 : | Variable error-stack 0 error-stack ! | ||
| 812 : | max-errors 6 * cells allot | ||
| 813 : | \ format of one cell: | ||
| 814 : | \ source ( addr u ) | ||
| 815 : | \ >in | ||
| 816 : | \ line-number | ||
| 817 : | \ Loadfilename ( addr u ) | ||
| 818 : | |||
| 819 : | : dec. ( n -- ) \ gforth | ||
| 820 : | \ print value in decimal representation | ||
| 821 : | base @ decimal swap . base ! ; | ||
| 822 : | |||
| 823 : | : hex. ( u -- ) \ gforth | ||
| 824 : | \ print value as unsigned hex number | ||
| 825 : | '$ emit base @ swap hex u. base ! ; | ||
| 826 : | |||
| 827 : | : typewhite ( addr u -- ) \ gforth | ||
| 828 : | \ like type, but white space is printed instead of the characters | ||
| 829 : | bounds ?do | ||
| 830 : | i c@ #tab = if \ check for tab | ||
| 831 : | #tab | ||
| 832 : | else | ||
| 833 : | bl | ||
| 834 : | then | ||
| 835 : | emit | ||
| 836 : | loop ; | ||
| 837 : | |||
| 838 : | DEFER DOERROR | ||
| 839 : | |||
| 840 : | : .error-frame ( addr1 u1 n1 n2 addr2 u2 -- ) | ||
| 841 : | cr error-stack @ | ||
| 842 : | IF | ||
| 843 : | ." in file included from " | ||
| 844 : | type ." :" dec. drop 2drop | ||
| 845 : | ELSE | ||
| 846 : | type ." :" dec. | ||
| 847 : | cr dup 2over type cr drop | ||
| 848 : | nip -trailing 1- ( line-start index2 ) | ||
| 849 : | 0 >r BEGIN | ||
| 850 : | 2dup + c@ bl > WHILE | ||
| 851 : | r> 1+ >r 1- dup 0< UNTIL THEN 1+ | ||
| 852 : | ( line-start index1 ) | ||
| 853 : | typewhite | ||
| 854 : | r> 1 max 0 ?do \ we want at least one "^", even if the length is 0 | ||
| 855 : | [char] ^ emit | ||
| 856 : | loop | ||
| 857 : | THEN | ||
| 858 : | ; | ||
| 859 : | |||
| 860 : | : (DoError) ( throw-code -- ) | ||
| 861 : | [ has-os [IF] ] | ||
| 862 : | outfile-id dup flush-file drop >r | ||
| 863 : | stderr to outfile-id | ||
| 864 : | [ [THEN] ] | ||
| 865 : | sourceline# IF | ||
| 866 : | source >in @ sourceline# 0 0 .error-frame | ||
| 867 : | THEN | ||
| 868 : | error-stack @ 0 ?DO | ||
| 869 : | -1 error-stack +! | ||
| 870 : | error-stack dup @ 6 * cells + cell+ | ||
| 871 : | 6 cells bounds DO | ||
| 872 : | I @ | ||
| 873 : | cell +LOOP | ||
| 874 : | .error-frame | ||
| 875 : | LOOP | ||
| 876 : | dup -2 = | ||
| 877 : | IF | ||
| 878 : | "error @ ?dup | ||
| 879 : | IF | ||
| 880 : | cr count type | ||
| 881 : | THEN | ||
| 882 : | drop | ||
| 883 : | ELSE | ||
| 884 : | .error | ||
| 885 : | THEN | ||
| 886 : | normal-dp dpp ! | ||
| 887 : | [ has-os [IF] ] r> to outfile-id [ [THEN] ] | ||
| 888 : | ; | ||
| 889 : | |||
| 890 : | ' (DoError) IS DoError | ||
| 891 : | |||
| 892 : | : quit ( ?? -- ?? ) \ core | ||
| 893 : | r0 @ rp! handler off >tib @ >r | ||
| 894 : | BEGIN | ||
| 895 : | postpone [ | ||
| 896 : | ['] 'quit CATCH dup | ||
| 897 : | WHILE | ||
| 898 : | DoError r@ >tib ! r@ tibstack ! | ||
| 899 : | REPEAT | ||
| 900 : | drop r> >tib ! ; | ||
| 901 : | |||
| 902 : | \ Cold 13feb93py | ||
| 903 : | |||
| 904 : | \ : .name ( name -- ) name>string type space ; | ||
| 905 : | \ : words listwords @ | ||
| 906 : | \ BEGIN @ dup WHILE dup .name REPEAT drop ; | ||
| 907 : | |||
| 908 : | Defer 'cold | ||
| 909 : | \ hook (deferred word) for things to do right before interpreting the | ||
| 910 : | \ command-line arguments | ||
| 911 : | ' noop IS 'cold | ||
| 912 : | |||
| 913 : | : (bootmessage) | ||
| 914 : | ." GForth " version-string type | ||
| 915 : | ." , Copyright (C) 1994-1997 Free Software Foundation, Inc." cr | ||
| 916 : | ." GForth comes with ABSOLUTELY NO WARRANTY; for details type `license'" | ||
| 917 : | [ has-os [IF] ] | ||
| 918 : | cr ." Type `bye' to exit" | ||
| 919 : | [ [THEN] ] ; | ||
| 920 : | |||
| 921 : | defer bootmessage | ||
| 922 : | |||
| 923 : | ' (bootmessage) IS bootmessage | ||
| 924 : | |||
| 925 : | : cold ( -- ) \ gforth | ||
| 926 : | [ has-files [IF] ] | ||
| 927 : | pathstring 2@ fpath only-path | ||
| 928 : | init-included-files | ||
| 929 : | [ [THEN] ] | ||
| 930 : | 'cold | ||
| 931 : | [ has-files [IF] ] | ||
| 932 : | ['] process-args catch ?dup | ||
| 933 : | IF | ||
| 934 : | dup >r DoError cr r> negate (bye) | ||
| 935 : | THEN | ||
| 936 : | argc @ 1 > | ||
| 937 : | IF \ there may be some unfinished line, so let's finish it | ||
| 938 : | cr | ||
| 939 : | THEN | ||
| 940 : | [ [THEN] ] | ||
| 941 : | bootmessage | ||
| 942 : | loadline off quit ; | ||
| 943 : | |||
| 944 : | : boot ( path **argv argc -- ) | ||
| 945 : | main-task up! | ||
| 946 : | [ has-os [IF] ] | ||
| 947 : | stdout TO outfile-id | ||
| 948 : | [ [THEN] ] | ||
| 949 : | [ has-files [IF] ] | ||
| 950 : | argc ! argv ! pathstring 2! | ||
| 951 : | [ [THEN] ] | ||
| 952 : | sp@ s0 ! | ||
| 953 : | [ has-locals [IF] ] | ||
| 954 : | lp@ forthstart 7 cells + @ - | ||
| 955 : | [ [ELSE] ] | ||
| 956 : | [ has-os [IF] ] | ||
| 957 : | sp@ $1040 + | ||
| 958 : | [ [ELSE] ] | ||
| 959 : | sp@ $40 + | ||
| 960 : | [ [THEN] ] | ||
| 961 : | [ [THEN] ] | ||
| 962 : | dup >tib ! tibstack ! #tib off >in off | ||
| 963 : | rp@ r0 ! | ||
| 964 : | [ has-floats [IF] ] | ||
| 965 : | fp@ f0 ! | ||
| 966 : | [ [THEN] ] | ||
| 967 : | ['] cold catch DoError | ||
| 968 : | [ has-os [IF] ] | ||
| 969 : | bye | ||
| 970 : | [ [THEN] ] | ||
| 971 : | ; | ||
| 972 : | |||
| 973 : | has-os [IF] | ||
| 974 : | : bye ( -- ) \ tools-ext | ||
| 975 : | [ has-files [IF] ] | ||
| 976 : | script? 0= IF cr THEN | ||
| 977 : | [ [ELSE] ] | ||
| 978 : | cr | ||
| 979 : | [ [THEN] ] | ||
| 980 : | 0 (bye) ; | ||
| 981 : | [THEN] | ||
| 982 : | |||
| 983 : | \ **argv may be scanned by the C starter to get some important | ||
| 984 : | \ information, as -display and -geometry for an X client FORTH | ||
| 985 : | \ or space and stackspace overrides | ||
| 986 : | |||
| 987 : | \ 0 arg contains, however, the name of the program. |
|
CVS Admin Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |