pete286/boot.jor

2 const cell
: cells cell * ;

key ) const ')'

10 const '\n'
13 const '\r'
key  const sp

128 const F_IMMEDIATE

: cr '\n' emit ;
: bl sp emit ;

: if ' BZ_ , here 0 , ; immediate
: else ' GOTO_ , 0 , here swap ! here cell - ; immediate
: then here swap ! ; immediate

: begin here ; immediate
: while ' BZ_ , here 0 , ; immediate
: repeat ' GOTO_ , swap , here swap ! ; immediate
: again ' GOTO_ , , ; immediate
: until ' BZ_ , , ; immediate

: ( begin key ')' = until ; immediate
: lit ' LIT_ , , ;

: inline| ' INLINEDATA_ , here 0 , ;
: |inline [ ' then , ] ;

' cells @ const $DOCOLON ( get the colon execution token )
: :| inline| $DOCOLON , ; immediate
: |; ' ret , |inline ; immediate

key " const '"'

: s" state if inline| else here then
    begin key dup '"' != over 0 != and while b, repeat drop 0 b,
    state if |inline else dup here! then ; immediate

: interpretword F_IMMEDIATE & state not or if execute else , then ;
: interpretnumber state if lit then ;
: interpretunknown type s" ?" type cr ;
: compileword lookup dup
    if interpretword
    else drop number
      if interpretnumber
      else interpretunknown
      then
    then ;
: interpreter
  begin word dup b@ while compileword repeat drop ;
: load-input swap-input >r >r interpreter <r <r swap-input ;
: loadstring ' key-string load-input drop drop ;

( image loading )
: noop ;

: defer word new-word $DODEFERRED , ' noop , ;
: redefine ( cp cpdeferred ) cell + ! ;
: definition ( cpdeferred ) cell + @ ;

defer onload
: postload ' onload definition ' noop ' onload redefine execute ;

: loadimage ( -- [0 | onload] )
  imagemagic fget = if
    fget fget fget fget fget ( onload tasks latest size start )
    here != if tell + seek drop drop drop 0 else
    dup here fread here + here! latest! tasks! then
  else 0 then ;

: saveimage ( herestart -- )
  imagemagic fput
  ' onload definition here drop fput
  tasks fput
  latest fput
  dup here swap - fput
  dup fput
  dup here swap - swap fwrite ;

( file loading )
: loadimage-if-uptodate ( filename -- b )
  dup image-uptodate if imagefilename open loadimage close else drop 0 then
  dup if execute 1 then ;

: interpretjor ( filename -- )
  open fdeactivate ' key-file load-input drop factivate close ;

: preservefp ( xt -- ) fdeactivate >r execute <r factivate ;

: loadjor :| interpretjor postload |; preservefp ;

: loadfile ( filename -- )
  ( active file is preserved for the currently-loading file, but the
    new file is always loaded with no active files )
  :| dup loadimage-if-uptodate not if
    here over >r >r interpretjor
    <r <r imagefilename overwrite saveimage close postload
  else drop then |; preservefp ;