forth/device/fcode.fs

   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
  11 hex
  12
  13 0    value fcode-sys-table \ table with built-in fcodes (0-0x7ff)
  14
  15 true value ?fcode-offset16 \ fcode offsets are 16 instead of 8 bit?
  16 1    value fcode-spread    \ fcode spread (1, 2 or 4)
  17 0    value fcode-table     \ pointer to fcode table
  18 false value ?fcode-verbose  \ do verbose fcode execution?
  19
  20 defer _fcode-debug?        \ If true, save names for FCodes with headers
  21 true value fcode-headers?  \ If true, possibly save names for FCodes.
  22
  23 0 value fcode-stream-start \ start address of fcode stream
  24 0 value fcode-stream       \ current fcode stream address
  25
  26 variable fcode-end         \ state variable, if true, fcode program terminates.
  27 defer 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
 371 64bit? [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