t{ 'x' 'u' <> -> -1 }t
+
: pick ( xn ... xi ... x0 i -- xn ... xi ... x0 xi )
1+ cells sp@ + @ ;
t{ 10 20 30 1 pick -> 10 20 30 20 }t
: visible-word ( -- ) hidden-word hidden-word ;
-
: save-mem ( c-addr1 u1 -- c-addr2 u2 )
dup >r allocate throw swap over r@ cmove r> ;
: scroll-up ( -- )
esc ." [S" ;
+: white ( -- ) esc ." [37m" ;
+: blue-bg ( -- ) esc ." [44m" ;
+
: save-cursor-position ( -- ) 27 emit '7' emit ;
: restore-cursor-position ( -- ) 27 emit '8' emit ;
: show-status ( -- )
status-line IF scroll-up THEN
- save-cursor-position blue reverse
+ save-cursor-position blue-bg white
base @ >r decimal
0 status-line 1 max at-xy ( clreol ) terminal-width spaces
0 status-line 1 max at-xy
rp-save his dup >r @ 1 cells - dup r> ! !
;
-: (activate) ( xt -- )
+| : (activate) ( xt -- )
catch error# ! stop ;
: activate ( xt tid -- )
t{ s( Δ) drop u8@+ nip -> 916 }t
t{ 916 pad u8!+ pad - pad c@ pad 1+ c@ -> 2 206 148 }t
-echo on
-input-echo on
++status
+echo on cr cr .( Welcome! ) input-echo on
DD 10000 dup(0)
rstck: DD 16 dup(0)
-_fp: DD 0 ; frame pointer for catch/throw
-
_dp: DD _start ; dictionary pointer: points to next free location in memory
; free memory starts at _start
next
;
-code invoke ( addr -- ) \ native code: >r ;
- pop eax
+\ code invoke ( addr -- ) \ native code: >r ;
+code execute ( addr -- ) \ this version uses token numbers as execution tokens and finds their code address via the headers table
+ pop edx
+ mov dword eax, [_head+edx*4]
jmp dword [eax]
;
: ?dup ( x -- x x | 0 )
dup 0= ?exit dup ;
+: 2* ( x1 -- x2 )
+ dup + ;
+
: cells ( x1 -- x2 )
- dup + dup + ;
+ 2* 2* ;
: +! ( x addr -- )
swap >r dup @ r> + swap ! ;
: compile, ( x -- )
h@ , ;
-: execute ( x -- )
- h@ invoke ;
+\ token are in the range 0 .. 767:
+\ 0, 3 .. 255 are single byte tokens
+\ 256 .. 511 are double byte tokens of the form 01 xx
+\ 511 .. 767 are double byte tokens of the form 02 xx
+: token ( -- x )
+ key dup 0= ?exit \ 0 -> single byte token
+ dup 3 - 0< 0= ?exit \ not 1 2 -> single byte token
+ key couple ; \ double byte token
: interpreter ( -- )
- key ?dup 0= ?exit execute tail interpreter ;
+ token execute tail interpreter ; \ executing exit will leave this loop
: num ( -- x )
tail interpreter ;
-: ?lit ( xt -- xt )
- h@ lit num - ?exit drop \ not num token: exit i.e. normal compile action
+: ?lit ( xt -- xt | )
+ dup h@ lit num - ?exit drop \ not num token: exit i.e. normal compile action
lit lit , num , \ generate lit x num call puts x on stack
r> drop tail compiler ;
: compiler ( -- )
- key ?dup 0= ?exit
- dup ?lit
+ token ?dup 0= ?exit ?lit
compile, tail compiler ;
: new ( -- xt )
: fun ( -- )
new drop compiler ;
-: 2* ( x1 -- x2 )
- dup + ;
-
: couple ( hi lo -- hilo )
>r 2* 2* 2* 2* 2* 2* 2* 2* r> + ;
r> swap h@ dup >r 1 cells - ! lit dodoes r> !
;
-: frame ( -- addr )
- lit fp ;
-
-: catch ( i*x xt -- j*x 0 | i*x err )
- frame @ >r sp@ >r rp@ frame ! execute r> drop r> frame ! 0 ;
-
-: throw ( i*x 0 | i*x err -- j*x err )
- ?dup 0= ?exit frame @ rp! r> swap >r sp! drop r> r> frame ! ;
-
-
: unused ( -- u )
lit memtop here - ;
: cold ( -- )
's' emit 'e' dup emit emit 'd' emit 10 emit
lit bye h, \ 0 00
- lit emit h, \ 1 01
- lit key h, \ 2 02
- lit dup h, \ 3 03
- lit swap h, \ 4 04
- lit drop h, \ 5 05
- lit 0< h, \ 6 06
- lit ?exit h, \ 7 07
- lit >r h, \ 8 08
- lit r> h, \ 9 09
- lit - h, \ 10 0A
- lit exit h, \ 11 0B
- lit lit h, \ 12 0C
- lit @ h, \ 13 0D
- lit c@ h, \ 14 0E
- lit ! h, \ 15 0F
- lit c! h, \ 16 10
- lit execute h, \ 17 11
- lit branch h, \ 18 12
- lit ?branch h, \ 19 13
- lit negate h, \ 20 14
- lit + h, \ 21 15
- lit 0= h, \ 22 16
- lit ?dup h, \ 23 17
- lit cells h, \ 24 18
- lit +! h, \ 25 19
- lit h@ h, \ 26 1A
- lit h, h, \ 27 1B
- lit here h, \ 28 1C
- lit allot h, \ 29 1D
- lit , h, \ 30 1E
- lit c, h, \ 31 1F
- lit fun h, \ 32 20
- lit interpreter h, \ 33 21
- lit compiler h, \ 34 22
- lit create h, \ 35 23
- lit does> h, \ 36 24
- lit cold h, \ 37 25
- lit depth h, \ 38 26
- lit compile, h, \ 39 27
- lit new h, \ 40 28
- lit couple h, \ 41 29
- lit and h, \ 42 2A
- lit or h, \ 43 2B
- lit catch h, \ 44 2C
- lit throw h, \ 45 2D
+ 0 h, \ 1 01 prefix
+ 0 h, \ 2 02 prefix
+ lit emit h, \ 3 03
+ lit key h, \ 4 04
+ lit dup h, \ 5 05
+ lit swap h, \ 6 06
+ lit drop h, \ 7 07
+ lit 0< h, \ 8 08
+ lit ?exit h, \ 9 09
+ lit >r h, \ 10 0A
+ lit r> h, \ 11 0B
+ lit - h, \ 12 0C
+ lit exit h, \ 13 0D
+ lit lit h, \ 14 0E
+ lit @ h, \ 15 0F
+ lit c@ h, \ 16 10
+ lit ! h, \ 17 11
+ lit c! h, \ 18 12
+ lit execute h, \ 19 13
+ lit branch h, \ 20 14
+ lit ?branch h, \ 21 15
+ lit negate h, \ 22 16
+ lit + h, \ 23 17
+ lit 0= h, \ 24 18
+ lit ?dup h, \ 25 19
+ lit cells h, \ 26 1A
+ lit +! h, \ 27 1B
+ lit h@ h, \ 28 1C
+ lit h, h, \ 29 1D
+ lit here h, \ 30 1E
+ lit allot h, \ 31 1F
+ lit , h, \ 32 20
+ lit c, h, \ 33 21
+ lit fun h, \ 34 22
+ lit interpreter h, \ 35 23
+ lit compiler h, \ 36 24
+ lit create h, \ 37 25
+ lit does> h, \ 38 26
+ lit cold h, \ 39 27
+ lit depth h, \ 40 28
+ lit compile, h, \ 41 29
+ lit new h, \ 42 2A
+ lit couple h, \ 43 2B
+ lit and h, \ 44 2C
+ lit or h, \ 45 2D
lit sp@ h, \ 46 2E
lit sp! h, \ 47 2F
lit rp@ h, \ 48 30
lit um/mod h, \ 53 35
lit unused h, \ 54 36
lit key? h, \ 55 37
- lit frame h, \ 56 38
+ lit token h, \ 56 38
interpreter bye ;
pre
VARIABLE OUTFILE
-: SUBMIT ( c -- )
+: submit ( c -- )
PAD C! PAD 1 OUTFILE @ WRITE-FILE THROW ;
+: submit-token ( x -- )
+ dup 255 > IF dup 8 rshift SUBMIT THEN SUBMIT ;
+
: <name> ( -- c-addr u ) bl word count ;
Variable #tokens 0 #tokens !
: Token ( <name> -- )
:noname
- #tokens @ postpone LITERAL postpone SUBMIT postpone ;
+ #tokens @ postpone LITERAL postpone SUBMIT-TOKEN postpone ;
<name>
cr #tokens @ 3 .r space 2dup type \ tell user about used tokens
?token ! 1 #tokens +! ;
<name> token@ dup 0= Abort" is undefined" postpone LITERAL postpone EXECUTE ; immediate
-( 0 $00 ) Token bye Token emit Token key Token dup
-( 4 $04 ) Token swap Token drop Token 0< Token ?exit
-( 8 $08 ) Token >r Token r> Token - Token exit
-( 12 $0C ) Token lit Token @ Token c@ Token !
-( 16 $10 ) Token c! Token execute Token branch Token ?branch
-( 20 $14 ) Token negate Token + Token 0= Token ?dup
-( 24 $18 ) Token cells Token +! Token h@ Token h,
-( 28 $1C ) Token here Token allot Token , Token c,
-( 32 $20 ) Token fun Token interpreter Token compiler Token create
-( 36 $24 ) Token does> Token cold Token depth Token compile,
-( 40 $28 ) Token new Token couple Token and Token or
-( 44 $2C ) Token catch Token throw Token sp@ Token sp!
+( 0 $00 ) Token bye Token prefix1 Token prefix2 Token emit
+( 4 $04 ) Token key Token dup Token swap Token drop
+( 8 $08 ) Token 0< Token ?exit Token >r Token r>
+( 12 $0C ) Token - Token exit Token lit Token @
+( 16 $10 ) Token c@ Token ! Token c! Token execute
+( 20 $14 ) Token branch Token ?branch Token negate Token +
+( 24 $18 ) Token 0= Token ?dup Token cells Token +!
+( 28 $1C ) Token h@ Token h, Token here Token allot
+( 32 $20 ) Token , Token c, Token fun Token interpreter
+( 36 $24 ) Token compiler Token create Token does> Token cold
+( 40 $28 ) Token depth Token compile, Token new Token couple
+( 44 $2C ) Token and Token or Token sp@ Token sp!
( 48 $30 ) Token rp@ Token rp! Token $lit Token num
-( 52 $34 ) Token um* Token um/mod Token unused Token key?
-( 53 $35 ) Token frame
+( 52 $34 ) Token um* Token um/mod Token unused Token key?
+( 56 $38 ) Token token
\ generate token sequences for numbers
: seed-name ( c-addr u -- )
2dup token@ dup IF nip nip execute EXIT THEN drop
- 2dup char-lit? IF nip nip seed num seed-number seed bye EXIT THEN drop
- 2dup number? IF nip nip seed num seed-number seed bye EXIT THEN drop
+ 2dup char-lit? IF nip nip seed num seed-number seed exit EXIT THEN drop
+ 2dup number? IF nip nip seed num seed-number seed exit EXIT THEN drop
cr type ." not found" abort ;
: seed-line ( -- )
postpone Token
#tokens @ 1 #tokens +!
postpone Literal
- postpone SUBMIT
+ postpone SUBMIT-TOKEN
seed fun
postpone end-macro
end-macro
\ catch and throw tests
-t{ 10 ' dup catch -> 10 10 0 }t
-
-: err99 ( x -- ) dup 9 = IF 99 throw THEN 1 + ;
-
-t{ 1 ' err99 catch -> 2 0 }t
-t{ 5 9 ' err99 catch nip -> 5 99 }t
+\ t{ 10 ' dup catch -> 10 10 0 }t
+\
+\ : err99 ( x -- ) dup 9 = IF 99 throw THEN 1 + ;
+\
+\ t{ 1 ' err99 catch -> 2 0 }t
+\ t{ 5 9 ' err99 catch nip -> 5 99 }t
\ Test for sp!
: 0<> ( x -- f )
0= 0= ;
-: 2* ( x1 -- x2 )
+: 2* ( x1 -- x2 ) \ already in kernel
dup + ;
: cell+ ( addr1 -- addr2 )
: move cmove ;
-
: place ( c-addr1 u c-addr2 -- )
2dup >r >r 1+ swap cmove r> r> c! ;
+
+\ Exception handling
+
+Variable frame ( -- addr )
+
+: catch ( i*x xt -- j*x 0 | i*x err )
+ frame @ >r sp@ >r rp@ frame ! execute
+ r> drop r> frame ! 0 ;
+
+: throw ( i*x 0 | i*x err -- j*x err )
+ ?dup 0= ?exit frame @ rp! r> swap >r sp! drop
+ r> r> frame ! ;
+
+
\ Tester
: empty-stack ( i*x -- )
BEGIN depth 0< WHILE 0 REPEAT
t{ 10 -1000 < -> 0 }t
t{ 1000 -10 < -> 0 }t
-\ : minint ( -- n )
-\ 1 BEGIN dup 2* dup WHILE nip REPEAT drop ;
-
-\ minint 1- Constant maxint
+: minint ( -- n )
+ 1 BEGIN dup 2* dup WHILE nip REPEAT drop ;
-\ t{ minint negate -> minint }t
-\ t{ minint maxint < -> -1 }t
-\ t{ maxint minint < -> 0 }t
+minint 1- Constant maxint
+t{ minint negate -> minint }t
+t{ minint maxint < -> -1 }t
+t{ maxint minint < -> 0 }t
t{ 0 1 u< -> -1 }t
t{ 1 0 u< -> 0 }t
\ Deferred words
-: ' ( -- x ) key ;
+: ' ( -- x ) token ;
: uninitialized ( -- )
cr s" uninitialized execution vector" type -1 throw ;
' xor has-header xor
' max has-header max
' min has-header min
-\ ' minint has-header minint
-\ ' maxint has-header maxint
+' minint has-header minint
+' maxint has-header maxint
' dispose has-header dispose
' alloc has-header alloc
' find-name has-header find-name
+: Alias ( xt <name> -- )
+ parse-name "header dup link-header _xt ! ;
+
+' Alias has-header Alias
: (postpone) ( <name> -- )
parse-name find-name dup 0= -13 and throw
: green ( -- ) esc ." [32m" ;
\ : yellow ( -- ) esc ." [33m" ;
: blue ( -- ) esc ." [34m" ;
+\ : bright-blue ( -- ) esc ." [94m" ;
: reset-colors ( -- ) esc ." [39;49m" ;
+: cyan ( -- ) esc ." [96m" ;
: page ( -- ) esc ." [2J" esc ." [H" ;
' blue has-header blue
: prompt ( -- )
echo @ IF
- cr blue bold .s normal reset-colors compiling? IF ']' ELSE '>' THEN emit space
+ cr cyan bold .s normal reset-colors compiling? IF ']' ELSE '>' THEN emit space
THEN ;
: .ok ( -- )
2 Constant major ( -- x )
-1 Constant minor ( -- x )
+2 Constant minor ( -- x )
0 Constant patch ( -- x )
: .version ( -- )
' boot has-header boot
\ ---- try colored words with embedded ESC sequences
-\ Create colored-header here 0 c, here
-\ 27 c, '[' c, '3' c, '1' c, 'm' c, 'r' c, 'e' c, 'd' c, 'w' c, 'o' c, 'r' c, 'd' c,
-\ 27 c, '[' c, '3' c, '9' c, ';' c, '4' c, '9' c, 'm' c,
-\ here swap - swap c!
+Create colored-header here 0 c, here
+ 27 c, '[' c, '3' c, '1' c, 'm' c, 'r' c, 'e' c, 'd' c, 'w' c, 'o' c, 'r' c, 'd' c,
+ 27 c, '[' c, '3' c, '9' c, ';' c, '4' c, '9' c, 'm' c,
+here swap - swap c!
-\ colored-header count "header dup link-header
+ colored-header count "header dup link-header
\ --------
+' token has-header token
+
cr
t{ -> }t
+
0 echo !
reveal
boot
public / preForth.git / commitdiff