1\ tag: FCode implementation functions 2\ 3\ this code implements IEEE 1275-1994 ch. 5.3.3 4\ 5\ Copyright (C) 2003 Stefan Reinauer 6\ 7\ See the file "COPYING" for further information about 8\ the copyright and warranty status of this work. 9\ 10 11hex 12 130 value fcode-sys-table \ table with built-in fcodes (0-0x7ff) 14 15true value ?fcode-offset16 \ fcode offsets are 16 instead of 8 bit? 161 value fcode-spread \ fcode spread (1, 2 or 4) 170 value fcode-table \ pointer to fcode table 18false value ?fcode-verbose \ do verbose fcode execution? 19 20defer _fcode-debug? \ If true, save names for FCodes with headers 21true value fcode-headers? \ If true, possibly save names for FCodes. 22 230 value fcode-stream-start \ start address of fcode stream 240 value fcode-stream \ current fcode stream address 25 26variable fcode-end \ state variable, if true, fcode program terminates. 27defer fcode-c@ \ get byte 28 29: fcode-push-state ( -- <state information> ) 30 ?fcode-offset16 31 fcode-spread 32 fcode-table 33 fcode-headers? 34 fcode-stream-start 35 fcode-stream 36 fcode-end @ 37 ['] fcode-c@ behavior 38; 39 40: fcode-pop-state ( <state information> -- ) 41 to fcode-c@ 42 fcode-end ! 43 to fcode-stream 44 to fcode-stream-start 45 to fcode-headers? 46 to fcode-table 47 to fcode-spread 48 to ?fcode-offset16 49; 50 51\ 52\ fcode access helper functions 53\ 54 55\ fcode-ptr 56\ convert FCode number to pointer to xt in FCode table. 57 58: fcode-ptr ( u16 -- *xt ) 59 cells 60 fcode-table ?dup if + exit then 61 62 \ we are not parsing fcode at the moment 63 dup 800 cells u>= abort" User FCODE# referenced." 64 fcode-sys-table + 65; 66 67\ fcode>xt 68\ get xt according to an FCode# 69 70: fcode>xt ( u16 -- xt ) 71 fcode-ptr @ 72 ; 73 74\ fcode-num8 75\ get 8bit from FCode stream, taking spread into regard. 76 77: fcode-num8 ( -- c ) ( F: c -- ) 78 fcode-stream 79 dup fcode-spread + to fcode-stream 80 fcode-c@ 81 ; 82 83\ fcode-num8-signed ( -- c ) ( F: c -- ) 84\ get 8bit signed from FCode stream 85 86: fcode-num8-signed 87 fcode-num8 88 dup 80 and 0> if 89 ff invert or 90 then 91 ; 92 93\ fcode-num16 94\ get 16bit from FCode stream 95 96: fcode-num16 ( -- num16 ) 97 fcode-num8 fcode-num8 swap bwjoin 98 ; 99 100\ fcode-num16-signed ( -- c ) ( F: c -- ) 101\ get 16bit signed from FCode stream 102 103: fcode-num16-signed 104 fcode-num16 105 dup 8000 and 0> if 106 ffff invert or 107 then 108 ; 109 110\ fcode-num32 111\ get 32bit from FCode stream 112 113: fcode-num32 ( -- num32 ) 114 fcode-num8 fcode-num8 115 fcode-num8 fcode-num8 116 swap 2swap swap bljoin 117 ; 118 119\ fcode# 120\ Get an FCode# from FCode stream 121 122: fcode# ( -- fcode# ) 123 fcode-num8 124 dup 1 f between if 125 fcode-num8 swap bwjoin 126 then 127 ; 128 129\ fcode-offset 130\ get offset from FCode stream. 131 132: fcode-offset ( -- offset ) 133 ?fcode-offset16 if 134 fcode-num16-signed 135 else 136 fcode-num8-signed 137 then 138 139 \ Display offset in verbose mode 140 ?fcode-verbose if 141 dup ." (offset) " . cr 142 then 143 ; 144 145\ fcode-string 146\ get a string from FCode stream, store in pocket. 147 148: fcode-string ( -- addr len ) 149 pocket dup 150 fcode-num8 151 dup rot c! 152 2dup bounds ?do 153 fcode-num8 i c! 154 loop 155 156 \ Display string in verbose mode 157 ?fcode-verbose if 158 2dup ." (const) " type cr 159 then 160 ; 161 162\ fcode-header 163\ retrieve FCode header from FCode stream 164 165: fcode-header 166 fcode-num8 167 fcode-num16 168 fcode-num32 169 ?fcode-verbose if 170 ." Found FCode header:" cr rot 171 ." Format : " u. cr swap 172 ." Checksum : " u. cr 173 ." Length : " u. cr 174 else 175 3drop 176 then 177 \ TODO checksum 178 ; 179 180\ writes currently created word as fcode# read from stream 181\ 182 183: fcode! ( F:FCode# -- ) 184 here fcode# 185 186 \ Display fcode# in verbose mode 187 ?fcode-verbose if 188 dup ." (fcode#) " . cr 189 then 190 fcode-ptr ! 191 ; 192 193 194\ 195\ 5.3.3.1 Defining new FCode functions. 196\ 197 198\ instance ( -- ) 199\ Mark next defining word as instance specific. 200\ (defined in bootstrap.fs) 201 202\ instance-init ( wid buffer -- ) 203\ Copy template from specified wordlist to instance 204\ 205 206: instance-init 207 swap 208 begin @ dup 0<> while 209 dup /n + @ instance-cfa? if \ buffer dict 210 2dup 2 /n* + @ + \ buffer dict dest 211 over 3 /n* + @ \ buffer dict dest size 212 2 pick 4 /n* + \ buffer dict dest size src 213 -rot 214 move 215 then 216 repeat 217 2drop 218 ; 219 220 221\ new-token ( F:/FCode#/ -- ) 222\ Create a new unnamed FCode function 223 224: new-token 225 0 0 header 226 fcode! 227 ; 228 229 230\ named-token (F:FCode-string FCode#/ -- ) 231\ Create a new possibly named FCode function. 232 233: named-token 234 fcode-string 235 _fcode-debug? not if 236 2drop 0 0 237 then 238 header 239 fcode! 240 ; 241 242 243\ external-token (F:/FCode-string FCode#/ -- ) 244\ Create a new named FCode function 245 246: external-token 247 fcode-string header 248 fcode! 249 ; 250 251 252\ b(;) ( -- ) 253\ End an FCode colon definition. 254 255: b(;) 256 ['] ; execute 257 ; immediate 258 259 260\ b(:) ( -- ) ( E: ... -- ??? ) 261\ Defines type of new FCode function as colon definition. 262 263: b(:) 264 1 , ] 265 ; 266 267 268\ b(buffer:) ( size -- ) ( E: -- a-addr ) 269\ Defines type of new FCode function as buffer:. 270 271: b(buffer:) 272 4 , allot 273 reveal 274 ; 275 276\ b(constant) ( nl -- ) ( E: -- nl ) 277\ Defines type of new FCode function as constant. 278 279: b(constant) 280 3 , , 281 reveal 282 ; 283 284 285\ b(create) ( -- ) ( E: -- a-addr ) 286\ Defines type of new FCode function as create word. 287 288: b(create) 289 6 , 290 ['] noop , 291 reveal 292 ; 293 294 295\ b(defer) ( -- ) ( E: ... -- ??? ) 296\ Defines type of new FCode function as defer word. 297 298: b(defer) 299 5 , 300 ['] (undefined-defer) , 301 ['] (semis) , 302 reveal 303 ; 304 305 306\ b(field) ( offset size -- offset+size ) ( E: addr -- addr+offset ) 307\ Defines type of new FCode function as field. 308 309: b(field) 310 6 , 311 ['] noop , 312 reveal 313 over , 314 + 315 does> 316 @ + 317 ; 318 319 320\ b(value) ( x -- ) (E: -- x ) 321\ Defines type of new FCode function as value. 322 323: b(value) 324 3 , , reveal 325 ; 326 327 328\ b(variable) ( -- ) ( E: -- a-addr ) 329\ Defines type of new FCode function as variable. 330 331: b(variable) 332 4 , 0 , 333 reveal 334 ; 335 336 337\ (is-user-word) ( name-str name-len xt -- ) ( E: ... -- ??? ) 338\ Create a new named user interface command. 339 340: (is-user-word) 341 ; 342 343 344\ get-token ( fcode# -- xt immediate? ) 345\ Convert FCode number to function execution token. 346 347: get-token 348 fcode>xt dup immediate? 349 ; 350 351 352\ set-token ( xt immediate? fcode# -- ) 353\ Assign FCode number to existing function. 354 355: set-token 356 nip \ TODO we use the xt's immediate state for now. 357 fcode-ptr ! 358 ; 359 360 361 362 363\ 364\ 5.3.3.2 Literals 365\ 366 367 368\ b(lit) ( -- n1 ) 369\ Numeric literal FCode. Followed by FCode-num32. 370 37164bit? [IF] 372: b(lit) 373 fcode-num32 32>64 374 state @ if 375 ['] (lit) , , 376 then 377 ; immediate 378[ELSE] 379: b(lit) 380 fcode-num32 381 state @ if 382 ['] (lit) , , 383 then 384 ; immediate 385[THEN] 386 387 388\ b(') ( -- xt ) 389\ Function literal FCode. Followed by FCode# 390 391: b(') 392 fcode# fcode>xt 393 state @ if 394 ['] (lit) , , 395 then 396 ; immediate 397 398 399\ b(") ( -- str len ) 400\ String literal FCode. Followed by FCode-string. 401 402: b(") 403 fcode-string 404 state @ if 405 \ only run handle-text in compile-mode, 406 \ otherwise we would waste a pocket. 407 handle-text 408 then 409 ; immediate 410 411 412\ 413\ 5.3.3.3 Controlling values and defers 414\ 415 416\ behavior ( defer-xt -- contents-xt ) 417\ defined in bootstrap.fs 418 419\ b(to) ( new-value -- ) 420\ FCode for setting values and defers. Followed by FCode#. 421 422: b(to) 423 fcode# fcode>xt 424 1 handle-lit 425 ['] (to) 426 state @ if 427 , 428 else 429 execute 430 then 431 ; immediate 432 433 434 435\ 436\ 5.3.3.4 Control flow 437\ 438 439 440\ offset16 ( -- ) 441\ Makes subsequent FCode-offsets use 16-bit (not 8-bit) form. 442 443: offset16 444 true to ?fcode-offset16 445 ; 446 447 448\ bbranch ( -- ) 449\ Unconditional branch FCode. Followed by FCode-offset. 450 451: bbranch 452 fcode-offset 0< if \ if we jump backwards, we can forsee where it goes 453 ['] dobranch , 454 resolve-dest 455 execute-tmp-comp 456 else 457 setup-tmp-comp ['] dobranch , 458 here 0 459 0 , 460 2swap 461 then 462 ; immediate 463 464 465\ b?branch ( continue? -- ) 466\ Conditional branch FCode. Followed by FCode-offset. 467 468: b?branch 469 fcode-offset 0< if \ if we jump backwards, we can forsee where it goes 470 ['] do?branch , 471 resolve-dest 472 execute-tmp-comp 473 else 474 setup-tmp-comp ['] do?branch , 475 here 0 476 0 , 477 then 478 ; immediate 479 480 481\ b(<mark) ( -- ) 482\ Target of backward branches. 483 484: b(<mark) 485 setup-tmp-comp 486 here 1 487 ; immediate 488 489 490\ b(>resolve) ( -- ) 491\ Target of forward branches. 492 493: b(>resolve) 494 resolve-orig 495 execute-tmp-comp 496 ; immediate 497 498 499\ b(loop) ( -- ) 500\ End FCode do..loop. Followed by FCode-offset. 501 502: b(loop) 503 fcode-offset drop 504 postpone loop 505 ; immediate 506 507 508\ b(+loop) ( delta -- ) 509\ End FCode do..+loop. Followed by FCode-offset. 510 511: b(+loop) 512 fcode-offset drop 513 postpone +loop 514 ; immediate 515 516 517\ b(do) ( limit start -- ) 518\ Begin FCode do..loop. Followed by FCode-offset. 519 520: b(do) 521 fcode-offset drop 522 postpone do 523 ; immediate 524 525 526\ b(?do) ( limit start -- ) 527\ Begin FCode ?do..loop. Followed by FCode-offset. 528 529: b(?do) 530 fcode-offset drop 531 postpone ?do 532 ; immediate 533 534 535\ b(leave) ( -- ) 536\ Exit from a do..loop. 537 538: b(leave) 539 postpone leave 540 ; immediate 541 542 543\ b(case) ( sel -- sel ) 544\ Begin a case (multiple selection) statement. 545 546: b(case) 547 postpone case 548 ; immediate 549 550 551\ b(endcase) ( sel | <nothing> -- ) 552\ End a case (multiple selection) statement. 553 554: b(endcase) 555 postpone endcase 556 ; immediate 557 558 559\ b(of) ( sel of-val -- sel | <nothing> ) 560\ FCode for of in case statement. Followed by FCode-offset. 561 562: b(of) 563 fcode-offset drop 564 postpone of 565 ; immediate 566 567\ b(endof) ( -- ) 568\ FCode for endof in case statement. Followed by FCode-offset. 569 570: b(endof) 571 fcode-offset drop 572 postpone endof 573 ; immediate 574