d6
/
nxu
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

modernize immediate jumps

This commit is contained in:
~d6 2023-11-28 12:08:42 -05:00
parent 29186973c8
commit 06332929f6
2 changed files with 686 additions and 684 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

968
femto.tal
View File

File diff suppressed because it is too large Load Diff

402
regex.tal
View File

@ -97,10 +97,10 @@
( using error! will print the given message before causing )
( the interpreter to halt. )
@error!! ( msg* -> )
@errorm ( msg* -> )
LIT "! emit! space
&loop LDAk #00 EQU ,&done JCN
LDAk emit! INC2 ,&loop JMP
&loop LDAk #00 EQU ?&done
LDAk emit! INC2 !&loop
&done POP2 newline #ff0e DEO #010f DEO BRK
( error messages )
@ -126,34 +126,34 @@
@rx-match ( str* regex* -> bool^ )
#01 ;match-multiline STA
#00 ;search-mode STA
;rx-reset JSR2
;loop JMP2
rx-reset
!loop
@rx-search-multiline ( str* regex* -> bool^ )
#01 ;match-multiline STA
#01 ;search-mode STA
,rx-search/main JMP
!rx-search/main
@rx-search ( str* regex* -> bool^ )
#00 ;match-multiline STA
#01 ;search-mode STA
&main STH2 ( s* [r*] )
DUP2 ;string-start STA2 ( s* [r*] )
&loop LDAk #00 EQU ,&eof JCN ( s* [r*] )
;rx-reset JSR2 ( s* [r*] )
&loop LDAk #00 EQU ?&eof ( s* [r*] )
rx-reset ( s* [r*] )
DUP2 ;search-start STA2 ( s* [r*] )
DUP2 STH2kr ;loop JSR2 ( s* b^ [r*] )
,&found JCN ( s* [r*] )
INC2 ,&loop JMP ( s+1* [r*] )
DUP2 STH2kr loop ( s* b^ [r*] )
?&found ( s* [r*] )
INC2 !&loop ( s+1* [r*] )
&found POP2 POP2r #01 JMP2r ( 01 )
&eof ;rx-reset JSR2 ( s* [r*] )
&eof rx-reset ( s* [r*] )
DUP2 ;search-start STA2 ( s* [r*] )
STH2r ;loop JMP2 ( b^ )
STH2r !loop ( b^ )
( reset all "runtime" memory allocated during match/search )
@rx-reset ( -> )
;reset-stack JSR2
;subgroup-reset JMP2
reset-stack
!subgroup-reset
( loop used during matching )
( )
@ -163,87 +163,87 @@
( return a boolean, which is where the stack )
( effects signature comes from. )
@loop ( s* r* -> bool^ )
LDAk #01 EQU ;do-empty JCN2
LDAk #02 EQU ;do-dot JCN2
LDAk #03 EQU ;do-literal JCN2
LDAk #04 EQU ;do-or JCN2
LDAk #05 EQU ;do-or JCN2 ( same code as the or case )
LDAk #06 EQU ;do-caret JCN2
LDAk #07 EQU ;do-dollar JCN2
LDAk #08 EQU ;do-lpar JCN2
LDAk #09 EQU ;do-rpar JCN2
LDAk #0a EQU ;do-ccls JCN2
LDAk #0b EQU ;do-ncls JCN2
LDAk #dd ;unknown-node-type ;error!! JSR2
LDAk #01 EQU ?do-empty
LDAk #02 EQU ?do-dot
LDAk #03 EQU ?do-literal
LDAk #04 EQU ?do-or
LDAk #05 EQU ?do-or ( same code as the or case )
LDAk #06 EQU ?do-caret
LDAk #07 EQU ?do-dollar
LDAk #08 EQU ?do-lpar
LDAk #09 EQU ?do-rpar
LDAk #0a EQU ?do-ccls
LDAk #0b EQU ?do-ncls
LDAk #dd ;unknown-node-type errorm
( used when we hit a dead-end during matching. )
( )
( if stack is non-empty we have a point we can resume from. )
@goto-backtrack ( -> bool^ )
;stack-exist JSR2 ,&has-stack JCN ( do we have stack? )
stack-exist ?&has-stack ( do we have stack? )
#00 JMP2r ( no, return false )
&has-stack
;pop4 JSR2
;subgroup-backtrack JSR2
;goto-next JMP2 ( yes, resume from the top )
pop4
subgroup-backtrack
!goto-next ( yes, resume from the top )
( follow the given address (next*) to continue matching )
@goto-next ( str* next* -> bool^ )
DUP2 #0000 GTH2 ,&has-next JCN
POP2 LDAk #00 EQU ,&end-of-string JCN
;search-mode LDA ,&end-of-search JCN
POP2 ;goto-backtrack JMP2
DUP2 #0000 GTH2 ?&has-next
POP2 LDAk #00 EQU ?&end-of-string
;search-mode LDA ?&end-of-search
POP2 !goto-backtrack
&end-of-search DUP2 ;search-end STA2
&end-of-string POP2 #01 JMP2r
&has-next ;loop JMP2
&has-next !loop
( handle the empty node -- just follow the next pointer )
@do-empty ( str* regex* -> bool^ )
INC2 LDA2 ( load next )
;goto-next JMP2 ( jump to next )
!goto-next ( jump to next )
( FIXME: not currently used )
@do-lpar ( str* regex* -> bool^ )
STH2 DUP2 ( s s [r] )
INC2r LDA2kr STH2r ( s s i [r+1] )
;subgroup-start JSR2 ( s [r+1] )
subgroup-start ( s [r+1] )
STH2r INC2 INC2 ( s r+3 )
LDA2 ;goto-next JMP2 ( jump to next )
LDA2 !goto-next ( jump to next )
( FIXME: not currently used )
@do-rpar ( str* regex* -> bool^ )
STH2 DUP2 ( s s [r] )
INC2r LDA2kr STH2r ( s s i [r+1] )
;subgroup-finish JSR2 ( s [r+1] )
subgroup-finish ( s [r+1] )
STH2r INC2 INC2 ( s r+3 )
LDA2 ;goto-next JMP2 ( jump to next )
LDA2 !goto-next ( jump to next )
( handle dot -- match any one character )
@do-dot ( str* regex* -> bool^ )
INC2 LDA2 STH2 ( load and stash next )
LDAk #00 NEQ ,&non-empty JCN ( is there a char? )
&backtrack POP2r POP2 ;goto-backtrack JMP2 ( no, clear stacks and backtrack )
&non-empty LDAk #0a NEQ ,&match JCN ( yes, match unless \n in search-mode )
;search-mode LDA ,&backtrack JCN ( if \n and search-mode, treat as EOF )
&match INC2 STH2r ;goto-next JMP2 ( on match: inc s, restore and jump )
LDAk #00 NEQ ?&non-empty ( is there a char? )
&backtrack POP2r POP2 !goto-backtrack ( no, clear stacks and backtrack )
&non-empty LDAk #0a NEQ ?&match ( yes, match unless \n in search-mode )
;search-mode LDA ?&backtrack ( if \n and search-mode, treat as EOF )
&match INC2 STH2r !goto-next ( on match: inc s, restore and jump )
( hande caret -- match string start (or possibly after newline) without advancing )
@do-caret ( str* regex* -> bool^ )
INC2 LDA2 STH2 ( load and stash next )
DUP2 ;string-start LDA2 EQU2 ,&at-start JCN ( at string start? )
;match-multiline LDA ,&no-match JCN ( are we in multi-line mode? )
DUP2 #0001 SUB2 LDA #0a EQU ,&at-start JCN ( just after newline? )
&no-match POP2r POP2 ;goto-backtrack JMP2 ( clear stacks and backtrack )
&at-start STH2r ;goto-next JMP2 ( go to next without advancing )
DUP2 ;string-start LDA2 EQU2 ?&at-start ( at string start? )
;match-multiline LDA ?&no-match ( are we in multi-line mode? )
DUP2 #0001 SUB2 LDA #0a EQU ?&at-start ( just after newline? )
&no-match POP2r POP2 !goto-backtrack ( clear stacks and backtrack )
&at-start STH2r !goto-next ( go to next without advancing )
( hande dollar -- match string end (or possibly before newline) without advancing )
@do-dollar ( str* regex* -> bool^ )
INC2 LDA2 STH2 ( load and stash next )
LDAk #00 EQU ,&at-end JCN ( at string end? )
;match-multiline LDA ,&no-match JCN ( are we in multi-line mode? )
LDAk #0a EQU ,&at-end JCN ( at newline? )
&no-match POP2r POP2 ;goto-backtrack JMP2 ( clear stacks and backtrack )
&at-end STH2r ;goto-next JMP2 ( go to next without advancing )
LDAk #00 EQU ?&at-end ( at string end? )
;match-multiline LDA ?&no-match ( are we in multi-line mode? )
LDAk #0a EQU ?&at-end ( at newline? )
&no-match POP2r POP2 !goto-backtrack ( clear stacks and backtrack )
&at-end STH2r !goto-next ( go to next without advancing )
( handle literal -- match one specific character )
@do-literal ( str* regex* -> bool^ )
@ -251,23 +251,23 @@
LDAk STH ( store c )
INC2 LDA2 STH2 ROTr ( store next, move c to top )
LDAk
STHr EQU ,&matches JCN ( do we match this char? )
POP2r POP2 ;goto-backtrack JMP2 ( no, clear stacks and backtrack )
STHr EQU ?&matches ( do we match this char? )
POP2r POP2 !goto-backtrack ( no, clear stacks and backtrack )
&matches
INC2 STH2r ;goto-next JMP2 ( yes, inc s, restore and jump )
INC2 STH2r !goto-next ( yes, inc s, restore and jump )
( handle or -- try the left branch but backtrack to the right if needed )
( )
( this also handles asteration, since it ends up having the same structure )
@do-or ( str* regex* -> bool^ )
INC2 OVR2 OVR2 #0002 ADD2 ( s r+1 s r+3 )
LDA2 ;push4 JSR2 ( save (s, right) in the stack for possible backtracking )
LDA2 ;loop JMP2 ( continue on left branch )
LDA2 push4 ( save (s, right) in the stack for possible backtracking )
LDA2 !loop ( continue on left branch )
@matches-cls ( str* regex* -> bool^ )
OVR2 LDA ,&not-null JCN
OVR2 LDA ?&not-null
( needs to have a character to match )
POP2 POP2 ;goto-backtrack JMP2
POP2 POP2 !goto-backtrack
&not-null
DUP2 INC2 LDA2 STH2 ( str regex [next] )
OVR2 INC2 STH2 ( str regex [str+1 next] )
@ -275,24 +275,24 @@
#0003 ADD2 LDAk #00 SWP #0002 MUL2 ( r+3 len*2 [c str+1 next] )
SWP2 INC2 STH2k ADD2 STH2r ( r+4+len*2 r+4 [c str+1 next] )
&loop ( limit addr [c str+1 next] )
EQU2k ,&missing JCN
LDAk STHkr GTH ,&next1 JCN INC2
LDAk STHkr LTH ,&next2 JCN ,&found JMP
EQU2k ?&missing
LDAk STHkr GTH ?&next1 INC2
LDAk STHkr LTH ?&next2 !&found
&next1 INC2
&next2 INC2 ,&loop JMP
&missing POP2 POP2 POPr ,&negated LDR ,&match JCN
&no-match POP2r POP2r ;goto-backtrack JMP2
&found POP2 POP2 POPr ,&negated LDR ,&no-match JCN
&match STH2r STH2r ;goto-next JMP2
&next2 INC2 !&loop
&missing POP2 POP2 POPr ,&negated LDR ?&match
&no-match POP2r POP2r !goto-backtrack
&found POP2 POP2 POPr ,&negated LDR ?&no-match
&match STH2r STH2r !goto-next
[ &negated $1 ]
( )
@do-ccls ( str* regex* -> bool^ )
#00 ,matches-cls/negated STR ,matches-cls JMP
#00 ,matches-cls/negated STR !matches-cls
( )
@do-ncls ( str* regex* -> bool^ )
#01 ,matches-cls/negated STR ,matches-cls JMP
#01 ,matches-cls/negated STR !matches-cls
( REGEX PARSING )
@ -325,9 +325,9 @@
@read ( -> c^ )
;pos LDA2k ( pos s )
LDAk STHk #00 EQU ( pos s c=0 [c] )
,&is-eof JCN ( pos s [c] )
?&is-eof ( pos s [c] )
INC2 ( pos s+1 [c] )
SWP2 STA2 ,&return JMP ( [c] )
SWP2 STA2 !&return ( [c] )
&is-eof POP2 POP2
&return STHr ( c )
JMP2r
@ -370,8 +370,8 @@
@compile ( expr* -> regex* )
;pos STA2
#0000 ;parens STA2
;rx-reset JSR2
;compile-region JMP2
rx-reset
!compile-region
( the basic strategy here is to build a stack of non-or )
( expressions to be joined together at the end of the )
@ -385,24 +385,24 @@
( by #ffff #ffff. above that we start with #0000 #0000 )
( to signal an empty node. )
@compile-region ( -> r2* )
#ffff #ffff ;push4 JSR2 ( stack delimiter )
#0000 #0000 ;push4 JSR2 ( stack frame start )
#ffff #ffff push4 ( stack delimiter )
#0000 #0000 push4 ( stack frame start )
@compile-region-loop
;read JSR2
DUP #00 EQU ;c-done JCN2
DUP LIT "| EQU ;c-or JCN2
DUP LIT ". EQU ;c-dot JCN2
DUP LIT "^ EQU ;c-caret JCN2
DUP LIT "$ EQU ;c-dollar JCN2
DUP LIT "( EQU ;c-lpar JCN2
DUP LIT ") EQU ;c-rpar JCN2
DUP LIT "[ EQU ;c-lbrk JCN2
DUP LIT "] EQU ;c-rbrk JCN2
DUP LIT "\ EQU ;c-esc JCN2
DUP LIT "* EQU ;c-star JCN2
DUP LIT "+ EQU ;c-plus JCN2
DUP LIT "? EQU ;c-qmark JCN2
;c-char JMP2
read
DUP #00 EQU ?c-done
DUP LIT "| EQU ?c-or
DUP LIT ". EQU ?c-dot
DUP LIT "^ EQU ?c-caret
DUP LIT "$ EQU ?c-dollar
DUP LIT "( EQU ?c-lpar
DUP LIT ") EQU ?c-rpar
DUP LIT "[ EQU ?c-lbrk
DUP LIT "] EQU ?c-rbrk
DUP LIT "\ EQU ?c-esc
DUP LIT "* EQU ?c-star
DUP LIT "+ EQU ?c-plus
DUP LIT "? EQU ?c-qmark
!c-char
( either finalize the given r0/r1 or else wrap it in )
( a star node if a star is coming up next. )
@ -410,14 +410,14 @@
( we use this look-ahead approach rather than compiling )
( star nodes directly since the implementation is simpler. )
@c-peek-and-finalize ( r0* r1* -> r2* )
;peek-to-star JSR2 ( r0 r1 next-is-star? ) ,&next-is-star JCN
;peek-to-plus JSR2 ( r0 r1 next-is-plus? ) ,&next-is-plus JCN
;peek-to-qmark JSR2 ( r0 r1 next-is-qmark? ) ,&next-is-qmark JCN
,&finally JMP ( r0 r1 )
&next-is-star ;skip JSR2 POP2 ;alloc-star JSR2 DUP2 ,&finally JMP
&next-is-plus ;skip JSR2 POP2 ;alloc-plus JSR2 DUP2 ,&finally JMP
&next-is-qmark ;skip JSR2 POP2 ;alloc-qmark JSR2 DUP2 ,&finally JMP
&finally ;push-next JSR2 ;compile-region-loop JMP2
peek-to-star ( r0 r1 next-is-star? ) ?&next-is-star
peek-to-plus ( r0 r1 next-is-plus? ) ?&next-is-plus
peek-to-qmark ( r0 r1 next-is-qmark? ) ?&next-is-qmark
!&finally ( r0 r1 )
&next-is-star skip POP2 alloc-star DUP2 !&finally
&next-is-plus skip POP2 alloc-plus DUP2 !&finally
&next-is-qmark skip POP2 alloc-qmark DUP2 !&finally
&finally push-next !compile-region-loop
( called when we reach EOF of the input string )
( )
@ -427,9 +427,9 @@
( this is where we detect unclosed parenthesis. )
@c-done ( c^ -> r2* )
POP
;parens LDA2 #0000 GTH2 ,&mismatched-parens JCN
;unroll-stack JSR2 POP2 JMP2r
&mismatched-parens ;mismatched-parens ;error!! JSR2
;parens LDA2 #0000 GTH2 ?&mismatched-parens
unroll-stack POP2 JMP2r
&mismatched-parens ;mismatched-parens errorm
( called when we read "|" )
( )
@ -437,8 +437,8 @@
( we just start a new stack frame and continue. )
@c-or ( c^ -> r2* )
POP
#0000 #0000 ;push4 JSR2
;compile-region-loop JMP2
#0000 #0000 push4
!compile-region-loop
( called when we read left parenthesis )
( )
@ -450,7 +450,7 @@
@c-lpar ( c^ -> r2* )
POP
;parens LDA2 INC2 ;parens STA2 ( parens++ )
;compile-region JMP2
!compile-region
( called when we read right parenthesis )
( )
@ -463,34 +463,34 @@
( 5. continue parsing )
@c-rpar ( c^ -> r2* )
POP
;parens LDA2 #0000 EQU2 ,&mismatched-parens JCN
;parens LDA2 #0000 EQU2 ?&mismatched-parens
;parens LDA2 #0001 SUB2 ;parens STA2 ( parens-- )
;unroll-stack JSR2
;c-peek-and-finalize JMP2
&mismatched-parens ;mismatched-parens ;error!! JSR2
unroll-stack
!c-peek-and-finalize
&mismatched-parens ;mismatched-parens errorm
( doesn't support weird things like []abc] or [-abc] or similar. )
( doesn't currently handle "special" escapes such as \n )
@c-lbrk ( c^ -> r2* )
POP LITr 00 ;pos LDA2 ( pos [0] )
LDAk LIT "^ NEQ ,&normal JCN INCr INC2 ( pos [negated?^] )
LDAk LIT "^ NEQ ?&normal INCr INC2 ( pos [negated?^] )
&normal
#0a STHr ADD ( src* type^ )
;arena-pos LDA2 STH2k ( src* type^ dst* [dst*] )
STA LIT2r 0004 ADD2r ( src* [dst+4] )
&left-parse ( src* [dst*] )
LDAk LIT "] EQU ,&done JCN
LDAk LIT "- EQU ,&error JCN
LDAk LIT "\ NEQ ,&left JCN INC2
LDAk LIT "] EQU ?&done
LDAk LIT "- EQU ?&error
LDAk LIT "\ NEQ ?&left INC2
&left
LDAk STH2kr STA INC2r
DUP2 INC2 LDA LIT "- NEQ ,&pre-right JCN INC2 INC2
LDAk LIT "] EQU ,&error JCN
LDAk LIT "- EQU ,&error JCN
DUP2 INC2 LDA LIT "- NEQ ?&pre-right INC2 INC2
LDAk LIT "] EQU ?&error
LDAk LIT "- EQU ?&error
&pre-right
LDAk LIT "\ NEQ ,&right JCN INC2
LDAk LIT "\ NEQ ?&right INC2
&right
LDAk STH2kr STA INC2 INC2r ,&left-parse JMP
LDAk STH2kr STA INC2 INC2r !&left-parse
&done ( src* [dst*] )
INC2 ;pos STA2 STH2r ( dst* )
DUP2 ;arena-pos LDA2 ( dst dst a )
@ -498,7 +498,7 @@
;arena-pos LDA2 STH2k #0003 ADD2 STA ( dst [a] )
;arena-pos STA2 STH2r ( a )
#0000 OVR2 INC2 STA2 ( a )
DUP2 ;c-peek-and-finalize JMP2
DUP2 !c-peek-and-finalize
&error
#abcd #0000 DIV ( TODO error here )
@ -511,24 +511,24 @@
( allocates a dot-node and continues. )
@c-dot ( c^ -> r2* )
POP
#02 ;alloc3 JSR2
DUP2 ;c-peek-and-finalize JMP2
#02 alloc3
DUP2 !c-peek-and-finalize
( called when we read "^" )
( )
( allocates a caret-node and continues. )
@c-caret ( c^ -> r2* )
POP
#06 ;alloc3 JSR2
DUP2 ;c-peek-and-finalize JMP2
#06 alloc3
DUP2 !c-peek-and-finalize
( called when we read "$" )
( )
( allocates a dollar-node and continues. )
@c-dollar ( c^ -> r2* )
POP
#07 ;alloc3 JSR2
DUP2 ;c-peek-and-finalize JMP2
#07 alloc3
DUP2 !c-peek-and-finalize
( called when we read "\" )
( )
@ -536,50 +536,50 @@
( )
( otherwise, allocates a literal of the next character. )
@c-esc ( c^ -> r2* )
POP ;read JSR2
DUP LIT "a EQU ,&bel JCN
DUP LIT "b EQU ,&bs JCN
DUP LIT "t EQU ,&tab JCN
DUP LIT "n EQU ,&nl JCN
DUP LIT "v EQU ,&vtab JCN
DUP LIT "f EQU ,&ff JCN
DUP LIT "r EQU ,&cr JCN
&default ;c-char JMP2
&bel POP #07 ,&default JMP
&bs POP #08 ,&default JMP
&tab POP #09 ,&default JMP
&nl POP #0a ,&default JMP
&vtab POP #0b ,&default JMP
&ff POP #0c ,&default JMP
&cr POP #0d ,&default JMP
POP read
DUP LIT "a EQU ?&bel
DUP LIT "b EQU ?&bs
DUP LIT "t EQU ?&tab
DUP LIT "n EQU ?&nl
DUP LIT "v EQU ?&vtab
DUP LIT "f EQU ?&ff
DUP LIT "r EQU ?&cr
&default !c-char
&bel POP #07 !&default
&bs POP #08 !&default
&tab POP #09 !&default
&nl POP #0a !&default
&vtab POP #0b !&default
&ff POP #0c !&default
&cr POP #0d !&default
( called when we read any other character )
( )
( allocates a literal-node and continues. )
@c-char ( c^ -> r2* )
;alloc-lit JSR2 ( lit )
DUP2 ;c-peek-and-finalize JMP2
alloc-lit ( lit )
DUP2 !c-peek-and-finalize
( called if we parse a "*" )
( )
( actually calling this means the code broke an invariant somewhere. )
@c-star ( c^ -> regex* )
POP
;star-invariant ;error!! JSR2
;star-invariant errorm
( called if we parse a "+" )
( )
( actually calling this means the code broke an invariant somewhere. )
@c-plus ( c^ -> regex* )
POP
;plus-invariant ;error!! JSR2
;plus-invariant errorm
( called if we parse a "?" )
( )
( actually calling this means the code broke an invariant somewhere. )
@c-qmark ( c^ -> regex* )
POP
;qmark-invariant ;error!! JSR2
;qmark-invariant errorm
( ALLOCATING REGEX NDOES )
@ -589,51 +589,51 @@
@alloc3 ( mode^ -> r* )
#0000 ROT ( 00 00 mode^ )
#03 ;alloc JSR2 ( 00 00 mode^ addr* )
#03 alloc ( 00 00 mode^ addr* )
STH2k STA ( addr <- mode )
STH2kr INC2 STA2 ( addr+1 <- 0000 )
STH2r JMP2r ( return addr )
@alloc-empty ( -> r* )
#01 ;alloc3 JMP2
#01 !alloc3
@alloc-lit ( c^ -> r* )
#03 #0000 SWP2 ( 0000 c^ 03 )
#04 ;alloc JSR2 ( 0000 c^ 03 addr* )
#04 alloc ( 0000 c^ 03 addr* )
STH2k STA ( addr <- 03 )
STH2kr INC2 STA ( addr+1 <- c )
STH2kr #0002 ADD2 STA2 ( addr+2 <- 0000 )
STH2r JMP2r ( return addr )
@alloc-or ( right* left* -> r* )
#05 ;alloc JSR2 STH2 ( r l [x] )
#05 alloc STH2 ( r l [x] )
#04 STH2kr STA ( r l [x] )
STH2kr INC2 STA2 ( r [x] )
STH2kr #0003 ADD2 STA2 ( [x] )
STH2r JMP2r
@alloc-star ( expr* -> r* )
#05 ;alloc JSR2 STH2 ( expr [r] )
#05 alloc STH2 ( expr [r] )
#05 STH2kr STA ( expr [r] )
DUP2 STH2kr INC2 STA2 ( expr [r] )
#0000 STH2kr #0003 ADD2 STA2 ( expr [r] )
STH2kr SWP2 ( r expr [r] )
;set-next JSR2 ( [r] )
set-next ( [r] )
STH2r JMP2r
@alloc-plus ( expr* -> r* )
#05 ;alloc JSR2 STH2 ( expr [r] )
#05 alloc STH2 ( expr [r] )
#05 STH2kr STA ( expr [r] )
DUP2 STH2kr INC2 STA2 ( expr [r] )
#0000 STH2kr #0003 ADD2 STA2 ( expr [r] )
STH2r SWP2 STH2k ( r expr [expr] )
;set-next JSR2 ( [expr] )
set-next ( [expr] )
STH2r JMP2r
@alloc-qmark ( expr* -> r* )
;alloc-empty JSR2 STH2k ( expr e [e] )
OVR2 ;set-next JSR2 ( expr [e] )
#05 ;alloc JSR2 STH2 ( expr [r e] )
alloc-empty STH2k ( expr e [e] )
OVR2 set-next ( expr [e] )
#05 alloc STH2 ( expr [r e] )
#04 STH2kr STA ( expr [r e] )
STH2kr INC2 STA2 ( [r e] )
SWP2r STH2r STH2kr ( e r [r] )
@ -642,7 +642,7 @@
( if r is 0000, allocate an empty node )
@alloc-if-null ( r* -> r2* )
ORAk ,&return JCN POP2 ;alloc-empty JSR2 &return JMP2r
ORAk ?&return POP2 alloc-empty &return JMP2r
( unroll one region of the parsing stack, returning )
( a single node consisting of an alternation of )
@ -651,23 +651,23 @@
( this unrolls until it hits #ffff #ffff, which it )
( also removes from the stack. )
@unroll-stack ( -> start* end* )
;pop4 JSR2 STH2 ( r )
pop4 STH2 ( r )
#00 STH ( count items in stack frame )
;alloc-if-null JSR2 ( replace 0000 with empty )
alloc-if-null ( replace 0000 with empty )
&loop ( r* )
;pop4 JSR2 POP2 ( r x )
DUP2 #ffff EQU2 ( r x x-is-end? ) ,&done JCN
pop4 POP2 ( r x )
DUP2 #ffff EQU2 ( r x x-is-end? ) ?&done
INCr ( items++ )
;alloc-or JSR2 ( r|x ) ,&loop JMP
alloc-or ( r|x ) !&loop
&done
( r ffff )
POP2
STHr ,&is-or JCN
STHr ?&is-or
STH2r JMP2r
&is-or
POP2r
;alloc-empty JSR2 OVR2 OVR2 SWP2 ( r empty empty r )
;set-next-or JSR2
alloc-empty OVR2 OVR2 SWP2 ( r empty empty r )
set-next-or
JMP2r
( add r to the top of the stock. )
@ -675,21 +675,21 @@
( in particular, this will write r into tail.next )
( before replacing tail with r. )
@push-next ( r0 r1 -> )
;pop4 JSR2 ( r0 r1 x0 x1 )
DUP2 #0000 EQU2 ( r0 r1 x0 x1 x1=0? ) ,&is-zero JCN
pop4 ( r0 r1 x0 x1 )
DUP2 #0000 EQU2 ( r0 r1 x0 x1 x1=0? ) ?&is-zero
STH2 ROT2 STH2r ( r1 x0 r0 x1 )
;set-next JSR2 SWP2 ( x0 r1 )
;push4 JSR2
set-next SWP2 ( x0 r1 )
push4
JMP2r
&is-zero POP2 POP2 ;push4 JMP2
&is-zero POP2 POP2 !push4
( load the given address: )
( )
( 1. if it points to 0000, update it to target )
( 2. otherwise, call set-next on it )
@set-next-addr ( target* addr* -> )
LDA2k #0000 EQU2 ( target addr addr=0? ) ,&is-zero JCN
LDA2 ;set-next JMP2
LDA2k #0000 EQU2 ( target addr addr=0? ) ?&is-zero
LDA2 !set-next
&is-zero STA2 JMP2r
( set regex.next to target )
@ -703,18 +703,18 @@
( back up we only bother taking the left branch. otherwise )
( you can end up double-appending things. )
@set-next ( target* regex* -> )
LDAk #01 LTH ,&unknown JCN
LDAk #0b GTH ,&unknown JCN
LDAk #09 GTH ,&cc JCN
LDAk #01 LTH ?&unknown
LDAk #0b GTH ?&unknown
LDAk #09 GTH ?&cc
LDAk #00 SWP ;rx-node-sizes ADD2
LDA #00 SWP ADD2 #0002 SUB2
;set-next-addr JMP2
&cc INC2 ;set-next-addr JMP2
&unknown LDAk #ee ;unknown-node-type ;error!! JSR2
!set-next-addr
&cc INC2 !set-next-addr
&unknown LDAk #ee ;unknown-node-type errorm
@set-next-or-addr ( target* addr* -> )
LDA2k #0000 EQU2 ( target addr addr=0? ) ,&is-zero JCN
LDA2 ;set-next-or JMP2
LDA2k #0000 EQU2 ( target addr addr=0? ) ?&is-zero
LDA2 !set-next-or
&is-zero STA2 JMP2r
( this is used when first building or-nodes )
@ -722,10 +722,10 @@
( [x1, [x2, [x3, ..., [xm, xn]]]] )
( so we recurse on the right side but not the left. )
@set-next-or ( target* regex* -> )
LDAk #04 NEQ ,&!4 JCN
OVR2 OVR2 INC2 ;set-next-addr JSR2
#0003 ADD2 ;set-next-or-addr JMP2
&!4 ;set-next JMP2
LDAk #04 NEQ ?&!4
OVR2 OVR2 INC2 set-next-addr
#0003 ADD2 !set-next-or-addr
&!4 !set-next
( STACK OPERATIONS )
( )
@ -741,7 +741,7 @@
( push 4 bytes onto the stack )
@push4 ( str* regex* -> )
;assert-stack-avail JSR2 ( check for space )
assert-stack-avail ( check for space )
;stack-pos LDA2 #0002 ADD2 STA2 ( cell[2:3] <- regex )
;stack-pos LDA2 STA2 ( cell[0:1] <- str )
;stack-pos LDA2 #0004 ADD2 ;stack-pos STA2 ( pos += 4 )
@ -749,7 +749,7 @@
( pop 4 bytes from the stack )
@pop4 ( -> str* regex* )
;assert-stack-exist JSR2 ( check for space )
assert-stack-exist ( check for space )
;stack-pos LDA2 ( load stack-pos )
#0002 SUB2 LDA2k STH2 ( pop and stash regex )
#0002 SUB2 LDA2k STH2 ( pop and stash str )
@ -771,11 +771,11 @@
( error if stack is full )
@assert-stack-avail ( -> )
;stack-avail JSR2 ,&ok JCN ;stack-is-full ;error!! JSR2 &ok JMP2r
stack-avail ?&ok ;stack-is-full errorm &ok JMP2r
( error is stack is empty )
@assert-stack-exist ( -> )
;stack-exist JSR2 ,&ok JCN ;stack-is-empty ;error!! JSR2 &ok JMP2r
stack-exist ?&ok ;stack-is-empty errorm &ok JMP2r
( stack-pos points to the next free stack position (or the top if full). )
@stack-pos :stack-bot ( the next position to insert at )
@ -810,10 +810,10 @@
#00 SWP ( size* )
;arena-pos LDA2 STH2k ADD2 ( pos+size* [pos] )
DUP2 ;arena-top GTH2 ( pos+size pos+size>top? [pos] )
,&error JCN ( pos+size [pos] )
?&error ( pos+size [pos] )
;arena-pos STA2 ( pos += size [pos] )
STH2r JMP2r ( pos )
&error POP2 POP2r ;arena-is-full ;error!! JSR2
&error POP2 POP2r ;arena-is-full errorm
@arena-pos :arena-bot ( the next position to allocate )
@arena-bot $400 @arena-top ( holds up to 1024 bytes )
@ -870,7 +870,7 @@
@subgroup-start ( s* i^ -> )
;subgroup-pos LDA2 STH2k ( s* i^ pos* [pos*] )
;subgroup-top LTH2 ,&next JCN #0000 DIV ( too many subgroups )
;subgroup-top LTH2 ?&next #0000 DIV ( too many subgroups )
&next ( s* i^ [pos*] )
STH2kr STA
STH2r INC2 STA2
@ -878,9 +878,9 @@
@subgroup-finish ( s* i^ -> )
;subgroup-pos LDA2 STH2k ( s* i^ pos* [pos*] )
;subgroup-top LTH2 ,&next JCN #0000 DIV ( too many subgroups )
;subgroup-top LTH2 ?&next #0000 DIV ( too many subgroups )
&next ( s* i^ [pos*] )
STH2kr LDA EQU ,&ok JCN #0000 DIV ( mismatched subgroups )
STH2kr LDA EQU ?&ok #0000 DIV ( mismatched subgroups )
&ok ( s* [pos*] )
STH2kr #0003 ADD2 STA2
STH2r #0005 ADD2 ;subgroup-pos STA2
@ -888,7 +888,7 @@
@subgroup-branch ( -> )
;subgroup-pos LDA2 STH2k ( pos* [pos*] )
;subgroup-top LTH2 ,&next JCN #0000 DIV ( too many subgroups )
;subgroup-top LTH2 ?&next #0000 DIV ( too many subgroups )
&next
#00 STH2kr STA ( [*pos] )
STH2r #0005 ADD2 ;subgroup-pos STA2
@ -897,9 +897,9 @@
@subgroup-backtrack ( -> )
;subgroup-bot ;subgroup-pos LDA2 ( bot* pos* )
&loop ( bot* pos* )
EQU2k ,&done JCN
LDAk #00 EQU ,&done JCN
#0005 SUB2 ,&loop JMP
EQU2k ?&done
LDAk #00 EQU ?&done
#0005 SUB2 !&loop
&done ( bot* pos* )
NIP2 ;subgroup-pos STA2
JMP2r