very very wip
This commit is contained in:
parent
d40db315db
commit
ba4b9c02e3
119
hoax.tal
119
hoax.tal
|
|
@ -105,22 +105,89 @@
|
|||
|0000
|
||||
@objects $2
|
||||
|
||||
( 00 start )
|
||||
( 01 symbol )
|
||||
( 02 string )
|
||||
( 03 escape )
|
||||
( 04 comment )
|
||||
@state $1
|
||||
@stack $2
|
||||
@buffer [ &pos $1 &input $40 ] ( max symbol size 64 )
|
||||
|
||||
|0100
|
||||
;init-hoax JSR2
|
||||
;on-char #10 DEO2
|
||||
#00 .state STZ
|
||||
;on-key #10 DEO2
|
||||
;reset-input JSR2
|
||||
;demo JSR2
|
||||
( DEBUG EXIT )
|
||||
BRK
|
||||
|
||||
@on-char ( -> )
|
||||
#12 DEI #0a EQU ,&newline JCN
|
||||
@reset-input ( -> )
|
||||
#0000 #0000 ;cons JSR2 ( pair$ )
|
||||
.stack STZ2 ( ; stack<-pair )
|
||||
JMP2r
|
||||
|
||||
@complete-with ( v$ -> )
|
||||
.stack LDZ2 ( v$ stack$ )
|
||||
STH2k SWP2 ;car! JSR2 ( [stack] ; car(stack)<-v )
|
||||
#0000 STH2r ;cons JSR2 ( cell$ )
|
||||
.stack STZ2 ( stack<- )
|
||||
|
||||
@start-list ( -> )
|
||||
#0000 .stack LDZ2 ( 0000 stack$ )
|
||||
;cons JSR2 ( pair$ )
|
||||
DUP2 .stack STZ2 ( pair$ ; stack<-pair )
|
||||
|
||||
.stack/pos LDZ ( a^ )
|
||||
STHk LDZ2 ( base$ [a^] )
|
||||
#0000 #0000 ;cons JSR2 ( base$ cell$ [a^] )
|
||||
STH2k ;car! JSR2 ( base$ [a^ cell$] )
|
||||
POP2 STH2r ( cell$ [a^] )
|
||||
INCr INCr STHkr ( cell$ a+2^ [a+2^] )
|
||||
STZ2 STHr .stack/pos STZ ( ; pos<-a+2 )
|
||||
JMP2r
|
||||
|
||||
@end-list ( -> )
|
||||
;stack/pos LDA2k LDA2 ( pos* elem$ )
|
||||
STH2 #0004 SUB2 ( pos-4* [elem$] )
|
||||
|
||||
|
||||
@on-key-start ( -> )
|
||||
#12 DEI
|
||||
DUP #09 EQU ,&skip JCN ( tab )
|
||||
DUP #0a EQU ,&skip JCN ( nl )
|
||||
DUP #0d EQU ,&skip JCN ( cr )
|
||||
DUP #20 EQU ,&skip JCN ( sp )
|
||||
DUP #20 LTH ,&control JCN ( control chars )
|
||||
DUP #7e GTH ,&control JCN ( delete + 8bit )
|
||||
DUP #28 EQU ,start-list JCN ( lpar )
|
||||
DUP #29 EQU ,&rpar JCN ( rpar )
|
||||
,&printable JMP
|
||||
|
||||
&rpar
|
||||
|
||||
|
||||
&skip POP BRK
|
||||
&control POP BRK ( todo )
|
||||
&printable
|
||||
|
||||
@on-key ( -> )
|
||||
.state LDZ #00 EQU ,on-key-start JCN
|
||||
.state LDZ #01 EQU ,on-key-symbol JCN
|
||||
.state LDZ #02 EQU ,on-key-string JCN
|
||||
.state LDZ #03 EQU ,on-key-escape JCN
|
||||
.state LDZ #04 EQU ,on-key-comment JCN
|
||||
#0000 DIV
|
||||
|
||||
( #12 DEI #0a EQU ,&newline JCN
|
||||
#12 DEI ;buffer/pos LDA2 STAk ( c pos ; addr<-c )
|
||||
INC2 ;buffer/pos STA2 POP BRK ( )
|
||||
&newline
|
||||
#00 ;buffer/pos LDA2 STA ( ; addr<-00 )
|
||||
;buffer/input DUP2 ;buffer/pos STA2
|
||||
;echo JSR2 "read: 20 00 ;print JSR2 #0a18 DEO
|
||||
BRK
|
||||
BRK )
|
||||
|
||||
@demo
|
||||
null ;null? JSR2 D
|
||||
|
|
@ -175,14 +242,12 @@
|
|||
EXIT
|
||||
&ok
|
||||
( allocate 8192 5-byte object slots )
|
||||
#2000 #0005 ;init-arena JSR2 ;objects STA2
|
||||
#2000 #0005 ;init-arena JSR2 .objects STZ2
|
||||
|
||||
( set up buffers )
|
||||
;buffer/input ;buffer/pos STA2
|
||||
JMP2r
|
||||
|
||||
@buffer [ &pos $2 &input $80 ]
|
||||
|
||||
@error ( -> )
|
||||
#0000 DIV ( TODO )
|
||||
|
||||
|
|
@ -296,19 +361,19 @@
|
|||
&small #8000 ORA2 JMP2r
|
||||
|
||||
@addr-to-obj ( addr* -> obj$ )
|
||||
;objects SUB2 #0005 DIV2 JMP2r
|
||||
.objects LDZ2 SUB2 #0005 DIV2 JMP2r
|
||||
|
||||
@obj-to-addr ( obj$ -> addr* )
|
||||
#0005 MUL2 ;objects ADD2 JMP2r
|
||||
#0005 MUL2 .objects LDZ2 ADD2 JMP2r
|
||||
|
||||
@make ( tag^ -> addr* )
|
||||
;objects LDA2 ( tag^ arena* )
|
||||
.objects LDZ2 ( tag^ arena* )
|
||||
;alloc JSR2 ( tag^ addr* )
|
||||
STH2k STA ( [addr*] )
|
||||
STH2r JMP2r ( addr* )
|
||||
|
||||
@make-obj ( tag^ ohi$ olo$ -> object$ )
|
||||
;objects LDA2 ( tag^ ohi$ olo$ arena* )
|
||||
.objects LDZ2 ( tag^ ohi$ olo$ arena* )
|
||||
;alloc JSR2 ( tag^ ohi$ olo$ addr* )
|
||||
STH2k #0003 ADD2 STA2 ( tag^ ohi$ [addr*] ; addr+3<-olo )
|
||||
STH2kr INC2 STA2 ( tag^ [addr*] ; addr+1<-ohi )
|
||||
|
|
@ -371,30 +436,22 @@
|
|||
&error ( [ptr$] )
|
||||
POP2r ;error JMP2 ( )
|
||||
|
||||
@last ( lst$ -> lst1$ )
|
||||
DUP2 ;cdr JSR2 ( lst$ cdr$ )
|
||||
ORAk ,&non-empty JCN ( lst$ cdr$ )
|
||||
POP2 JMP2r ( lst$ )
|
||||
&non-empty ( lst$ cdr$ )
|
||||
NIP2 ;last JMP2 ( res$ )
|
||||
@car! ( pair$ x$ -> pair$ )
|
||||
STH2 ;assert-cons JSR2 ( pair$ [x$] )
|
||||
DUP2 ;obj-to-addr JSR2 ( pair$ addr* [x$] )
|
||||
INC2 ( pair$ addr+1 [x$] )
|
||||
STH2r SWP2 STA2 JMP2r ( pair$ ; addr+1<-x )
|
||||
|
||||
@car! ( lst$ x$ -> )
|
||||
@cdr! ( pair$ x$ -> )
|
||||
STH2 ;assert-cons JSR2 ( lst$ [x$] )
|
||||
;obj-to-addr JSR2 ( addr* [x$] )
|
||||
INC2 ( addr+1 [x$] )
|
||||
STH2r SWP2 STA2 ( ; addr+3<-x )
|
||||
|
||||
@cdr! ( lst$ x$ -> )
|
||||
STH2 ;assert-cons JSR2 ( lst$ [x$] )
|
||||
;obj-to-addr JSR2 ( addr* [x$] )
|
||||
DUP2 ;obj-to-addr JSR2 ( addr* [x$] )
|
||||
#0003 ADD2 ( addr+3 [x$] )
|
||||
STH2r SWP2 STA2 ( ; addr+3<-x )
|
||||
STH2r SWP2 STA2 JMP2r ( ; addr+3<-x )
|
||||
|
||||
@append! ( lst$ x$ -> )
|
||||
#0000 ;cons JSR2 ;extend! JMP2
|
||||
|
||||
@extend! ( lst$ tail$ -> )
|
||||
SWP2 ;last JSR2 SWP2 ;cdr! JMP2
|
||||
@find ( list$ x$ -> rest$ )
|
||||
STH2 ( list$ [x$] )
|
||||
&loop ( list$ [x$] )
|
||||
;read-object
|
||||
|
||||
|1004 ( ;arenas needs to be a multiple of 5 )
|
||||
~alloc.tal
|
||||
|
|
|
|||
Loading…
Reference in New Issue