forth/device/fcode.fs

\ tag: FCode implementation functions
\ 
\ this code implements IEEE 1275-1994 ch. 5.3.3
\ 
\ Copyright (C) 2003 Stefan Reinauer
\ 
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\ 

hex 

0    value fcode-sys-table \ table with built-in fcodes (0-0x7ff)

true value ?fcode-offset16 \ fcode offsets are 16 instead of 8 bit?
1    value fcode-spread    \ fcode spread (1, 2 or 4)
0    value fcode-table     \ pointer to fcode table
false value ?fcode-verbose  \ do verbose fcode execution?

defer _fcode-debug?        \ If true, save names for FCodes with headers
true value fcode-headers?  \ If true, possibly save names for FCodes.

0 value fcode-stream-start \ start address of fcode stream
0 value fcode-stream       \ current fcode stream address

variable fcode-end         \ state variable, if true, fcode program terminates.
defer fcode-c@             \ get byte

: fcode-push-state ( -- <state information> )
  ?fcode-offset16
  fcode-spread
  fcode-table
  fcode-headers?
  fcode-stream-start
  fcode-stream
  fcode-end @
  ['] fcode-c@ behavior
;

: fcode-pop-state ( <state information> -- )
  to fcode-c@
  fcode-end !
  to fcode-stream
  to fcode-stream-start
  to fcode-headers?
  to fcode-table
  to fcode-spread
  to ?fcode-offset16
;
  
\ 
\ fcode access helper functions
\ 

\ fcode-ptr
\   convert FCode number to pointer to xt in FCode table.

: fcode-ptr ( u16 -- *xt )
  cells
  fcode-table ?dup if + exit then
  
  \ we are not parsing fcode at the moment
  dup 800 cells u>= abort" User FCODE# referenced."
  fcode-sys-table +
;
  
\ fcode>xt
\   get xt according to an FCode#

: fcode>xt ( u16 -- xt )
  fcode-ptr @
  ;

\ fcode-num8
\   get 8bit from FCode stream, taking spread into regard.

: fcode-num8 ( -- c ) ( F: c -- )
  fcode-stream
  dup fcode-spread + to fcode-stream 
  fcode-c@
  ;

\ fcode-num8-signed ( -- c ) ( F: c -- )
\   get 8bit signed from FCode stream

: fcode-num8-signed
  fcode-num8
  dup 80 and 0> if
     ff invert or
  then
  ;

\ fcode-num16
\   get 16bit from FCode stream

: fcode-num16 ( -- num16 )
  fcode-num8 fcode-num8 swap bwjoin
  ;

\ fcode-num16-signed ( -- c ) ( F: c -- )
\   get 16bit signed from FCode stream

: fcode-num16-signed
  fcode-num16
  dup 8000 and 0> if
     ffff invert or
  then
  ;

\ fcode-num32
\   get 32bit from FCode stream

: fcode-num32 ( -- num32 )
  fcode-num8 fcode-num8
  fcode-num8 fcode-num8
  swap 2swap swap bljoin
  ;
 
\ fcode#
\   Get an FCode# from FCode stream

: fcode# ( -- fcode# )
  fcode-num8
  dup 1 f between if
    fcode-num8 swap bwjoin
  then
  ;

\ fcode-offset
\   get offset from FCode stream.

: fcode-offset ( -- offset )
  ?fcode-offset16 if
    fcode-num16-signed
  else
    fcode-num8-signed
  then

  \ Display offset in verbose mode
  ?fcode-verbose if
    dup ."        (offset) " . cr
  then
  ;

\ fcode-string
\   get a string from FCode stream, store in pocket.

: fcode-string ( -- addr len )
  pocket dup
  fcode-num8
  dup rot c!
  2dup bounds ?do
    fcode-num8 i c!
  loop

  \ Display string in verbose mode
  ?fcode-verbose if
    2dup ."        (const) " type cr
  then
  ;
    
\ fcode-header
\   retrieve FCode header from FCode stream

: fcode-header
  fcode-num8
  fcode-num16
  fcode-num32
  ?fcode-verbose if
    ." Found FCode header:" cr rot
    ."   Format   : " u. cr swap
    ."   Checksum : " u. cr
    ."   Length   : " u. cr
  else
    3drop
  then
  \ TODO checksum
  ;

\ writes currently created word as fcode# read from stream
\ 

: fcode! ( F:FCode# -- )
  here fcode#

  \ Display fcode# in verbose mode
  ?fcode-verbose if
    dup ."        (fcode#) " . cr
  then
  fcode-ptr !
  ;

  
\ 
\ 5.3.3.1 Defining new FCode functions.
\ 

\ instance ( -- )   
\   Mark next defining word as instance specific.
\  (defined in bootstrap.fs)

\ instance-init ( wid buffer -- )
\   Copy template from specified wordlist to instance
\ 

: instance-init
  swap
  begin @ dup 0<> while
    dup /n + @ instance-cfa? if         \ buffer dict
      2dup 2 /n* + @ +                  \ buffer dict dest
      over 3 /n* + @                    \ buffer dict dest size
      2 pick 4 /n* +                    \ buffer dict dest size src
      -rot
      move
    then
  repeat
  2drop
  ;


\ new-token ( F:/FCode#/ -- ) 
\   Create a new unnamed FCode function

: new-token 
  0 0 header
  fcode!
  ;

  
\ named-token (F:FCode-string FCode#/ -- )
\   Create a new possibly named FCode function.

: named-token 
  fcode-string
  _fcode-debug? not if
    2drop 0 0
  then
  header
  fcode!
  ;

  
\ external-token (F:/FCode-string FCode#/ -- )
\   Create a new named FCode function

: external-token 
  fcode-string header
  fcode!
  ;

  
\ b(;) ( -- ) 
\   End an FCode colon definition.

: b(;)
  ['] ; execute
  ; immediate


\ b(:) ( -- ) ( E: ... -- ??? )
\   Defines type of new FCode function as colon definition.

: b(:)
  1 , ]
  ;


\ b(buffer:) ( size -- ) ( E:  -- a-addr )  
\   Defines type of new FCode function as buffer:.

: b(buffer:)
  4 , allot
  reveal
  ;

\ b(constant) ( nl -- ) ( E: -- nl )
\   Defines type of new FCode function as constant.

: b(constant)
  3 , , 
  reveal
  ;


\ b(create) ( -- ) ( E: -- a-addr )
\   Defines type of new FCode function as create word.

: b(create)
  6 , 
  ['] noop ,
  reveal
  ;


\ b(defer) ( -- ) ( E: ... -- ??? )  
\   Defines type of new FCode function as defer word.

: b(defer)
  5 ,
  ['] (undefined-defer) ,
  ['] (semis) ,
  reveal
  ;


\ b(field) ( offset size -- offset+size ) ( E: addr -- addr+offset )
\   Defines type of new FCode function as field.

: b(field)
  6 ,
  ['] noop ,
  reveal
    over ,
    +
  does>
    @ +
  ;

  
\ b(value) ( x -- ) (E: -- x )
\   Defines type of new FCode function as value.
  
: b(value)
  3 , , reveal
  ;


\ b(variable) ( -- ) ( E: -- a-addr )
\   Defines type of new FCode function as variable.

: b(variable)
  4 , 0 ,
  reveal
  ;
  
  
\ (is-user-word) ( name-str name-len xt -- ) ( E: ... -- ??? )
\   Create a new named user interface command.

: (is-user-word)
  ;

  
\ get-token ( fcode# -- xt immediate? )
\   Convert FCode number to function execution token.

: get-token
  fcode>xt dup immediate?
  ;


\ set-token ( xt immediate? fcode# -- )
\   Assign FCode number to existing function.
  
: set-token
  nip \ TODO we use the xt's immediate state for now.
  fcode-ptr !
  ;

  
  

\ 
\ 5.3.3.2 Literals
\ 


\ b(lit) ( -- n1 ) 
\   Numeric literal FCode. Followed by FCode-num32.

64bit? [IF]
: b(lit)
  fcode-num32 32>64
  state @ if
    ['] (lit) , ,
  then
  ; immediate
[ELSE]
: b(lit)
  fcode-num32 
  state @ if
    ['] (lit) , ,
  then
  ; immediate
[THEN]


\ b(') ( -- xt )  
\   Function literal FCode. Followed by FCode#

: b(')
  fcode# fcode>xt
  state @ if
    ['] (lit) , , 
  then
  ; immediate

  
\ b(") ( -- str len )
\   String literal FCode. Followed by FCode-string.
  
: b(")
  fcode-string
  state @ if
    \ only run handle-text in compile-mode,
    \ otherwise we would waste a pocket.
    handle-text
  then
  ; immediate


\ 
\ 5.3.3.3 Controlling values and defers
\ 

\ behavior ( defer-xt -- contents-xt )
\ defined in bootstrap.fs

\ b(to) ( new-value -- )
\   FCode for setting values and defers. Followed by FCode#.

: b(to)
  fcode# fcode>xt 
  1 handle-lit
  ['] (to)
  state @ if 
    ,
  else
    execute
  then
  ; immediate



\ 
\ 5.3.3.4 Control flow
\ 


\ offset16 ( -- )
\   Makes subsequent FCode-offsets use 16-bit (not 8-bit) form.

: offset16
  true to ?fcode-offset16
  ;


\ bbranch ( -- )
\   Unconditional branch FCode. Followed by FCode-offset.
  
: bbranch
  fcode-offset 0< if \ if we jump backwards, we can forsee where it goes
    ['] dobranch ,
    resolve-dest
    execute-tmp-comp
  else
    setup-tmp-comp ['] dobranch ,
    here 0
    0 ,
    2swap
  then
  ; immediate


\ b?branch ( continue? -- )
\   Conditional branch FCode. Followed by FCode-offset.

: b?branch
  fcode-offset 0< if \ if we jump backwards, we can forsee where it goes
    ['] do?branch ,
    resolve-dest
    execute-tmp-comp
  else
    setup-tmp-comp ['] do?branch ,
    here 0
    0 ,
  then 
  ; immediate

  
\ b(<mark) ( -- )
\   Target of backward branches.

: b(<mark)
  setup-tmp-comp
  here 1
  ; immediate

  
\ b(>resolve) ( -- )
\   Target of forward branches.

: b(>resolve)
  resolve-orig
  execute-tmp-comp
  ; immediate

  
\ b(loop) ( -- )
\   End FCode do..loop. Followed by FCode-offset.

: b(loop)
  fcode-offset drop
  postpone loop
  ; immediate

  
\ b(+loop) ( delta -- )
\   End FCode do..+loop. Followed by FCode-offset.

: b(+loop)
  fcode-offset drop
  postpone +loop
  ; immediate

  
\ b(do) ( limit start -- )
\   Begin FCode do..loop. Followed by FCode-offset.

: b(do)
  fcode-offset drop
  postpone do
  ; immediate

  
\ b(?do) ( limit start -- )
\   Begin FCode ?do..loop. Followed by FCode-offset.

: b(?do)
  fcode-offset drop
  postpone ?do
  ; immediate

  
\ b(leave) ( -- )
\   Exit from a do..loop.
  
: b(leave)
  postpone leave
  ; immediate

  
\ b(case) ( sel -- sel )
\   Begin a case (multiple selection) statement.

: b(case)
  postpone case
  ; immediate

  
\ b(endcase) ( sel | <nothing> -- )
\   End a case (multiple selection) statement.

: b(endcase)
  postpone endcase
  ; immediate
  

\ b(of) ( sel of-val -- sel | <nothing> )
\   FCode for of in case statement. Followed by FCode-offset.

: b(of)
  fcode-offset drop
  postpone of
  ; immediate

\ b(endof) ( -- )
\   FCode for endof in case statement. Followed by FCode-offset.

: b(endof)
  fcode-offset drop
  postpone endof
  ; immediate