93 lines
2.5 KiB
Plaintext
Executable file
93 lines
2.5 KiB
Plaintext
Executable file
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 , ] ;
|
|
|
|
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] )
|
|
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 ;
|
|
|
|
: saveimage ( herestart -- )
|
|
' 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 ;
|
|
|
|
: loadjor fdeactivate swap interpretjor postload factivate ;
|
|
|
|
: loadfile ( filename -- )
|
|
( active file is preserved for the currently-loading file, but the
|
|
new file is always loaded with no active files )
|
|
fdeactivate swap
|
|
dup loadimage-if-uptodate not if
|
|
dup here swap interpretjor
|
|
swap imagefilename overwrite saveimage close postload
|
|
else drop then factivate ;
|