Merge remote-tracking branch 'origin/main'
This commit is contained in:
commit
230eb91c74
|
|
@ -361,6 +361,12 @@
|
|||
DUP2 x16-pi/2 LTH2 ?{ x16-pi SWP2 SUB2 }
|
||||
&q DUP2 ADD2 ;x16-sin-table ADD2 LDA2 JMP2r
|
||||
|
||||
( there are 1608 8.8 fixed point values between 0 and 2pi. )
|
||||
( )
|
||||
( we use 402 tables entries x 4 quadants to get 1608 values. )
|
||||
( )
|
||||
( note that the table actually has 403 values just to make )
|
||||
( boundary conditions a bit easier to deal with. )
|
||||
@x16-sin-table
|
||||
0000 0001 0002 0003 0004 0005 0006 0007 0008 0009 000a 000b 000c 000d 000e 000f
|
||||
0010 0011 0012 0013 0014 0015 0016 0017 0018 0019 001a 001b 001c 001d 001e 001f
|
||||
|
|
|
|||
402
regex.tal
402
regex.tal
|
|
@ -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 ,¬-null JCN
|
||||
OVR2 LDA ?¬-null
|
||||
( needs to have a character to match )
|
||||
POP2 POP2 ;goto-backtrack JMP2
|
||||
POP2 POP2 !goto-backtrack
|
||||
¬-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
|
||||
|
|
|
|||
2
term.tal
2
term.tal
|
|
@ -172,7 +172,7 @@
|
|||
|
||||
@setup-debugging ( -> )
|
||||
.debug LDZ ?&continue JMP2r &continue
|
||||
#99 #010e DEO ( put 99 in wst so #010e DEO reliably logs )
|
||||
( #99 #010e DEO ) ( put 99 in wst so #010e DEO reliably logs )
|
||||
;debug-log .File1/name DEO2
|
||||
#01 .File1/append DEO
|
||||
JMP2r
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ def tosigned(x):
|
|||
return x if x < 32768 else x - 65536
|
||||
|
||||
u8 = {'sz': 1 << 8, 'fmt': b'%02x'}
|
||||
u16 = {'sz': 1 << 16, 'fmt': b'%04x'}
|
||||
x16 = {'sz': 1 << 16, 'fmt': b'%04x'}
|
||||
z16 = {'sz': 1 << 16, 'fmt': b'%04x'} # non-zero
|
||||
p16 = {'sz': 1 << 16, 'fmt': b'%04x'} # positive
|
||||
t16 = {'sz': 1 << 16, 'fmt': b'%04x'} # tangent, must not be pi/2
|
||||
|
|
@ -46,6 +46,7 @@ def testcase(p, sym, args, out, f, eq):
|
|||
val = randint(0, g['sz'] - 1)
|
||||
while ((val == 0 and (g is z16 or g is p16)) or
|
||||
(val >= 0x8000 and g is p16) or
|
||||
(val == 0x8000 and g is x16) or
|
||||
(g is t16 and ((val >= 804) or ((val % 804) == 402)))):
|
||||
val = randint(0, g['sz'] - 1)
|
||||
vals.append((name, g, val))
|
||||
|
|
@ -178,32 +179,32 @@ def main():
|
|||
print('the command `uxnasm test-fix16.tal run.rom` failed!')
|
||||
exit(e.returncode)
|
||||
p = pipe()
|
||||
test(p, trials, b'+', [('x', u16), ('y', u16)], u16, x16_add)
|
||||
test(p, trials, b'-', [('x', u16), ('y', u16)], u16, x16_sub)
|
||||
test(p, trials, b'*', [('x', u16), ('y', u16)], u16, x16_mul)
|
||||
test(p, trials, b'/', [('x', u16), ('y', z16)], u16, x16_div)
|
||||
test(p, trials, b'\\', [('x', u16), ('y', z16)], u16, x16_quot)
|
||||
test(p, trials, b'%', [('x', u16), ('y', z16)], u16, x16_rem)
|
||||
test(p, trials, b'w', [('x', u16)], u8, x16_is_whole, eq=booleq)
|
||||
test(p, trials, b'N', [('x', u16)], u16, x16_negate)
|
||||
test(p, trials, b'=', [('x', u16), ('y', u16)], u8, x16_eq)
|
||||
test(p, trials, b'!', [('x', u16), ('y', u16)], u8, x16_ne)
|
||||
test(p, trials, b'<', [('x', u16), ('y', u16)], u8, x16_lt)
|
||||
test(p, trials, b'>', [('x', u16), ('y', u16)], u8, x16_gt)
|
||||
test(p, trials, b'{', [('x', u16), ('y', u16)], u8, x16_lteq)
|
||||
test(p, trials, b'}', [('x', u16), ('y', u16)], u8, x16_gteq)
|
||||
test(p, trials, b'F', [('x', u16)], u16, x16_floor)
|
||||
test(p, trials, b'C', [('x', u16)], u16, x16_ceil)
|
||||
test(p, trials, b'R', [('x', u16)], u16, x16_round)
|
||||
test(p, trials, b'8', [('x', u16)], u16, x16_trunc8)
|
||||
test(p, trials, b'T', [('x', u16)], u16, x16_trunc16)
|
||||
test(p, trials, b'+', [('x', x16), ('y', x16)], x16, x16_add)
|
||||
test(p, trials, b'-', [('x', x16), ('y', x16)], x16, x16_sub)
|
||||
test(p, trials, b'*', [('x', x16), ('y', x16)], x16, x16_mul)
|
||||
test(p, trials, b'/', [('x', x16), ('y', z16)], x16, x16_div)
|
||||
test(p, trials, b'\\', [('x', x16), ('y', z16)], x16, x16_quot)
|
||||
test(p, trials, b'%', [('x', x16), ('y', z16)], x16, x16_rem)
|
||||
test(p, trials, b'w', [('x', x16)], u8, x16_is_whole, eq=booleq)
|
||||
test(p, trials, b'N', [('x', x16)], x16, x16_negate)
|
||||
test(p, trials, b'=', [('x', x16), ('y', x16)], u8, x16_eq)
|
||||
test(p, trials, b'!', [('x', x16), ('y', x16)], u8, x16_ne)
|
||||
test(p, trials, b'<', [('x', x16), ('y', x16)], u8, x16_lt)
|
||||
test(p, trials, b'>', [('x', x16), ('y', x16)], u8, x16_gt)
|
||||
test(p, trials, b'{', [('x', x16), ('y', x16)], u8, x16_lteq)
|
||||
test(p, trials, b'}', [('x', x16), ('y', x16)], u8, x16_gteq)
|
||||
test(p, trials, b'F', [('x', x16)], x16, x16_floor)
|
||||
test(p, trials, b'C', [('x', x16)], x16, x16_ceil)
|
||||
test(p, trials, b'R', [('x', x16)], x16, x16_round)
|
||||
test(p, trials, b'8', [('x', x16)], x16, x16_trunc8)
|
||||
test(p, trials, b'T', [('x', x16)], x16, x16_trunc16)
|
||||
# the next five are known to be somewhat inaccurate and use
|
||||
# a "relaxed" equality predicate for testing purposes.
|
||||
test(p, trials, b'r', [('x', p16)], u16, x16_sqrt, eq=releq)
|
||||
test(p, trials, b's', [('x', p16)], u16, x16_sin, eq=sineq)
|
||||
test(p, trials, b'c', [('x', p16)], u16, x16_cos, eq=sineq)
|
||||
test(p, trials, b't', [('x', t16)], u16, x16_tan, eq=taneq)
|
||||
test(p, trials, b'l', [('x', p16)], u16, x16_log, eq=releq)
|
||||
test(p, trials, b'r', [('x', p16)], x16, x16_sqrt, eq=releq)
|
||||
test(p, trials, b's', [('x', p16)], x16, x16_sin, eq=sineq)
|
||||
test(p, trials, b'c', [('x', p16)], x16, x16_cos, eq=sineq)
|
||||
test(p, trials, b't', [('x', t16)], x16, x16_tan, eq=taneq)
|
||||
test(p, trials, b'l', [('x', p16)], x16, x16_log, eq=releq)
|
||||
p.stdin.write(b'\n\n')
|
||||
p.stdin.flush()
|
||||
p.stdin.close()
|
||||
|
|
|
|||
119
wave.tal
119
wave.tal
|
|
@ -38,6 +38,7 @@
|
|||
( |00 @System [ &vec $2 &wst $1 &rst $1 &pad $4 &r $2 &g $2 &b $2 &dbg $1 &halt $1 ] )
|
||||
|10 @Console [ &vec $2 &read $1 &pad $5 &out $1 &err $1 ]
|
||||
|30 @Audio0 [ &vec $2 &pos $2 &out $1 &dur $2 &pad $1 &adsr $2 &len $2 &addr $2 &vol $1 &pitch $1 ]
|
||||
|40 @Audio1 [ &vec $2 &pos $2 &out $1 &dur $2 &pad $1 &adsr $2 &len $2 &addr $2 &vol $1 &pitch $1 ]
|
||||
|a0 @File [ &vec $2 &ok $2 &stat $2 &del $1 &append $1 &name $2 &len $2 &r $2 &w $2 ]
|
||||
|
||||
|0000
|
||||
|
|
@ -45,7 +46,6 @@
|
|||
@pos $2
|
||||
@is-stereo $1
|
||||
@is-8bit $1
|
||||
@bytes-per-ms $2
|
||||
|
||||
|0100
|
||||
;filename .pos STZ2
|
||||
|
|
@ -76,9 +76,9 @@
|
|||
LIT2 =reload/resample STA2 ( ; save resample function )
|
||||
LIT2r =reload/sft STAr ( ; save shift size )
|
||||
#2274 .File/len DEO2
|
||||
#2274 ;len0 STA2 #2274 ;buf0 zero-buf-u8
|
||||
#2274 ;len1 STA2 #2274 ;buf1 zero-buf-u8
|
||||
!play0
|
||||
#2274 DUP2 ;a/len STA2 DUP2 ;a/l-buf zero-buf-u8 DUP2 ;a/r-buf zero-buf-u8
|
||||
DUP2 ;b/len STA2 DUP2 ;b/l-buf zero-buf-u8 ;b/r-buf zero-buf-u8
|
||||
!play-a
|
||||
|
||||
@zero-buf-u8 ( len* buf* -> )
|
||||
STH2k ADD2 STH2 SWP2r ( [limit=buf+len* buf*] )
|
||||
|
|
@ -103,70 +103,84 @@
|
|||
@hdr-eq2 ( offset* v* -> eq^ )
|
||||
STH2 ;header ADD2 LDA2 STH2r EQU2 JMP2r
|
||||
|
||||
@reload ( l-addr* b-addr* -> )
|
||||
.done LDZ ?&skip ( l-addr* b-addr* )
|
||||
SWP2 ( b-addr* l-addr* )
|
||||
;scratch .File/r DEO2 ( b-addr* l-addr* )
|
||||
.File/ok DEI2 ( b-addr* l-addr* read* )
|
||||
DUP2 LIT &sft $1 SFT2 ( b-addr* l-addr* read* read>>sft )
|
||||
ROT2 STA2 ( b-addr* read* ; l-addr<-read>>sft )
|
||||
DUP2 #2274 EQU2 ?&end ( b-addr* read* ; if we read 0x2274 we are not done )
|
||||
#01 .done STZ ( b-addr* read* ; done<-1 )
|
||||
&end ( b-addr* read* )
|
||||
SWP2 STH2 ;scratch ( read* scratch* [b-addr*] )
|
||||
DUP2 ROT2 ADD2 SWP2 ( limit=scratch+read* scratch* [b-addr*] )
|
||||
INC2 ( limit* scratch+1* [b-addr*] )
|
||||
&loop ( limit* pos* [bpos*] )
|
||||
LIT2 &resample $2 JSR2 ( limit* pos+n* sample^ [bpos*] )
|
||||
STH2kr STA ( limit* pos+n* [bpos*] ; bpos<-sample )
|
||||
INC2r GTH2k ?&loop ( limit* pos+n* [bpos+1*] )
|
||||
POP2r ( limit* pos+n* )
|
||||
POP2 POP2 JMP2r
|
||||
&skip ( )
|
||||
#2274 SWP2 zero-buf-u8 ( )
|
||||
#2274 SWP2 STA2 JMP2r ( )
|
||||
@reload ( l-addr* bl-addr* br-addr* -> )
|
||||
SWP2 STH2 STH2 ( l-addr* [bl-addr* br-addr*] )
|
||||
.done LDZ ?&skip ( l-addr* [bl-addr* br-addr*] )
|
||||
;scratch .File/r DEO2 ( l-addr* [bl-addr* br-addr*] )
|
||||
.File/ok DEI2 ( l-addr* read* [bl-addr* br-addr*] )
|
||||
DUP2 LIT &sft $1 SFT2 ( l-addr* read* read>>sft [bl-addr* br-addr*] )
|
||||
ROT2 STA2 ( read* [bl-addr* br-addr*] ; l-addr<-read>>sft )
|
||||
DUP2 #2274 EQU2 ?&end ( read* [bl-addr* br-addr*] ; if we read 0x2274 we are not done )
|
||||
#01 .done STZ ( read* [bl-addr* br-addr*] ; done<-1 )
|
||||
&end ( read* [bl-addr* br-addr*] )
|
||||
;scratch ( read* scratch* [bl-addr* br-addr*] )
|
||||
DUP2 ROT2 ADD2 SWP2 ( limit=scratch+read* scratch* [bl-addr* br-addr*] )
|
||||
INC2 ( limit* scratch+1* [bl-addr* br-addr*] )
|
||||
&loop ( limit* pos* [bl-pos* br-pos*] )
|
||||
LIT2 [ &resample $2 ] JSR2 ( limit* pos+n* l-sample^ r-sample^ [bl-pos* br-pos*] )
|
||||
STH2kr STA INC2 SWP2r ( limit* pos+n* [br-pos+1* bl-pos*] ; br-pos<-sample )
|
||||
STH2kr STA INC2 SWP2r ( limit* pos+n* [bl-pos+1* br-pos+1*] ; bl-pos<-sample )
|
||||
GTH2k ?&loop ( limit* pos+n* [bl-pos+1* br-pos+1*] )
|
||||
POP2r POP2r POP2 POP2 JMP2r ( )
|
||||
&skip ( l-addr* [bl-addr* br-addr*] )
|
||||
#2274 DUP2 STH2r zero-buf-u8 ( l-addr* #2274 [bl-addr*] ; clear br-addr )
|
||||
DUP2 STH2r zero-buf-u8 ( l-addr* #2274 ; clear bl-addr )
|
||||
SWP2 STA2 JMP2r ( ; l-addr<-2274 )
|
||||
|
||||
@mono-u8-to-u8 ( pos* -> pos+1* sample^ )
|
||||
LDAk STH INC2 STHr JMP2r
|
||||
@mono-u8-to-u8 ( pos* -> pos+1* l-sample^ r-sample^ )
|
||||
LDAk STH INC2 ( pos+1* [s^] )
|
||||
STHr DUP JMP2r ( pos+1 l-s^ r-s^ )
|
||||
|
||||
@mono-s16-to-u8 ( pos* -> pos+2* sample^ )
|
||||
LDAk #80 ADD STH INC2 INC2 STHr JMP2r
|
||||
@mono-s16-to-u8 ( pos* -> pos+2* l-sample^ r-sample^ )
|
||||
LDAk #80 ADD STH INC2 INC2 ( pos+2* [s^] )
|
||||
STHr DUP JMP2r ( pos+2* l-s^ r-s^ )
|
||||
|
||||
@stereo-u8-to-u8 ( pos* -> pos+2* sample^ )
|
||||
LDAk LITr 00 STH INC2
|
||||
LDAk LITr 00 STH INC2
|
||||
ADD2r LITr 01 SFT2r NIPr STHr JMP2r
|
||||
@stereo-u8-to-u8 ( pos* -> pos+2* l-sample^ r-sample^ )
|
||||
INC2k SWP2 LDA STH ( pos+1* [l-s^] )
|
||||
INC2k SWP2 LDA STH ( pos+2* [l-s^ r-s^] )
|
||||
STH2r JMP2r ( pos+2* l-s^ r-s^ )
|
||||
|
||||
@stereo-s16-to-u8 ( pos* -> pos+4* sample^ )
|
||||
LDAk #80 EOR #00 SWP STH2 INC2 INC2
|
||||
LDAk #80 EOR #00 SWP STH2 INC2 INC2
|
||||
ADD2r LITr 01 SFT2r NIPr STHr JMP2r
|
||||
LDAk #80 ADD STH INC2 INC2 ( pos+2* [l-s^] )
|
||||
LDAk #80 ADD STH INC2 INC2 ( pos+4* [l-s^ r-s^] )
|
||||
STH2r JMP2r ( pos+4* l-s^ r-s^ )
|
||||
|
||||
@play0 ( -> ) ;play1 ;len0 ;buf0 !play
|
||||
@play1 ( -> ) ;play0 ;len1 ;buf1 !play
|
||||
@play-a ( -> ) ;play-b ;a !play-base
|
||||
@play-b ( -> ) ;play-a ;b !play-base
|
||||
|
||||
@play ( next* l-addr* b-addr* -> )
|
||||
OVR2 LDA2 ORAk ?&nonzero ( next* l-addr* b-addr* n* )
|
||||
POP2 POP2 POP2 POP2 ( ; clear stack )
|
||||
@play-base ( next* base* -> )
|
||||
SWP2 .Audio0/vec DEO2 ( base* ; vec<-next )
|
||||
INC2k INC2 STH2k ( l-addr* lb-addr* [lb-addr*] )
|
||||
#2274 ADD2 STH2 ( l-addr* [lb-addr* rb-addr*] )
|
||||
( LDA2k ORAk ?&non-zero ( l-addr* n* [lb-addr* rb-addr*] )
|
||||
POP2 POP2 POP2r POP2r ( ; clear stack )
|
||||
#010f BRK ( ; exit )
|
||||
&nonzero ( next* l-addr b-addr* n* )
|
||||
OVR2 output ( next* l-addr b-addr* ; play buf1 )
|
||||
reload ( next* ; load more data )
|
||||
.Audio0/vec DEO2 ( ; Audio0/vec<-next )
|
||||
BRK ( )
|
||||
&non-zero ( l-addr* n* [lb-addr* rb-addr*] ) )
|
||||
DUP2 STH2kr r-output SWP2r ( l-addr* n* [rb-addr* lb-addr*] ; play rb-addr )
|
||||
STH2kr l-output SWP2r ( l-addr* [lb-addr* rb-addr*] ; play lb-addr )
|
||||
SWP2r STH2r STH2r reload BRK ( ; load more data )
|
||||
|
||||
@bytes-to-millis ( samples* -> ms* )
|
||||
#01b9 DIV2 #000a MUL2 JMP2r
|
||||
|
||||
@output ( len* addr* -> )
|
||||
@l-output ( len* addr* -> )
|
||||
.Audio0/addr DEO2 ( ; <- write buf addr )
|
||||
DUP2 .Audio0/len DEO2 ( ; <- write length in bytes/samples )
|
||||
bytes-to-millis .Audio0/dur DEO2 ( ; <- write duration in milliseconds )
|
||||
#00f0 .Audio0/adsr DEO2 ( ; <- write ignore envelope )
|
||||
#ff .Audio0/vol DEO ( ; <- play 100% volume )
|
||||
#f0 .Audio0/vol DEO ( ; <- play 100% volume )
|
||||
#bc .Audio0/pitch DEO ( ; <- play standard sample once )
|
||||
JMP2r
|
||||
|
||||
@r-output ( len* addr* -> )
|
||||
.Audio1/addr DEO2 ( ; <- write buf addr )
|
||||
DUP2 .Audio1/len DEO2 ( ; <- write length in bytes/samples )
|
||||
bytes-to-millis .Audio1/dur DEO2 ( ; <- write duration in milliseconds )
|
||||
#00f0 .Audio1/adsr DEO2 ( ; <- write ignore envelope )
|
||||
#0f .Audio1/vol DEO ( ; <- play 100% volume )
|
||||
#bc .Audio1/pitch DEO ( ; <- play standard sample once )
|
||||
JMP2r
|
||||
|
||||
( buffer size is 0x2274, i.e. 8820. )
|
||||
( this is an important number: 8820 = 4 * 5 * 441. )
|
||||
( since it is divisible by 4 we know that the buffer will read )
|
||||
|
|
@ -176,6 +190,9 @@
|
|||
( end up with static, popping, or other problems. )
|
||||
@filename $100
|
||||
@header $2c
|
||||
@len0 $2 @buf0 $2274
|
||||
@len1 $2 @buf1 $2274
|
||||
( @len0 $2 @buf0 $2274
|
||||
@len1 $2 @buf1 $2274 )
|
||||
@scratch $2274
|
||||
|
||||
@a [ &len $2 &l-buf $2274 &r-buf $2274 ]
|
||||
@b [ &len $2 &l-buf $2274 &r-buf $2274 ]
|
||||
|
|
|
|||
Loading…
Reference in New Issue