more hoax
This commit is contained in:
parent
fa5cef3a0b
commit
d40db315db
154
hoax.tal
154
hoax.tal
|
|
@ -86,7 +86,6 @@
|
|||
( "abcd" 7 bytes )
|
||||
( "abcde" 12 bytes )
|
||||
|
||||
( TODO: symbols should display as barewords by default )
|
||||
( TODO: special case empty string? )
|
||||
|
||||
%NL { #0a18 DEO }
|
||||
|
|
@ -139,10 +138,14 @@
|
|||
#34 #1234 STH2r ;make-obj JSR2 D
|
||||
#0003 ;u16-to-num JSR2 null ;cons JSR2 STH2k D
|
||||
#0002 ;u16-to-num JSR2 STH2r ;cons JSR2 STH2k D
|
||||
#0001 ;u16-to-num JSR2 STH2r ;cons JSR2 D
|
||||
#0001 ;u16-to-num JSR2 STH2r ;cons JSR2 STH2k D
|
||||
#13 LIT2 "ab LIT2 "c 00 ;make-obj JSR2 D
|
||||
#23 LIT2 "ab LIT2 "c 00 ;make-obj JSR2 D
|
||||
#24 LIT2 "ab LIT2 "c 00 ;make-obj JSR2 D
|
||||
STH2kr ;emit/short JSR2 NL
|
||||
STH2kr D
|
||||
STH2kr ;len JSR2 D
|
||||
STH2r ;cdr JSR2 ;len JSR2 D
|
||||
JMP2r
|
||||
|
||||
@emit
|
||||
|
|
@ -166,9 +169,9 @@
|
|||
( obj = (addr - arenas) / 5 )
|
||||
( addr = (obj * 5) + arenas )
|
||||
;arenas #0005 DIV2 #0005 MUL2 ;arenas EQU2 ,&ok JCN
|
||||
;echo JSR2 "invalid 20 "arenas 20 "( 00
|
||||
;echo JSR2 "invalid 20 "arenas 20 28 00
|
||||
;arenas ;emit/short JSR2
|
||||
;echo JSR2 ") 20 "not 20 "divisible 20 "by 20 "5 0a 00
|
||||
;echo JSR2 29 20 "not 20 "divisible 20 "by 20 "5 0a 00
|
||||
EXIT
|
||||
&ok
|
||||
( allocate 8192 5-byte object slots )
|
||||
|
|
@ -178,11 +181,7 @@
|
|||
;buffer/input ;buffer/pos STA2
|
||||
JMP2r
|
||||
|
||||
@buffer
|
||||
&pos $2 &input $80
|
||||
( &x-pos $2 &x $40
|
||||
&y-pos $2 &y $40
|
||||
&z-pos $2 &z $40 )
|
||||
@buffer [ &pos $2 &input $80 ]
|
||||
|
||||
@error ( -> )
|
||||
#0000 DIV ( TODO )
|
||||
|
|
@ -247,11 +246,11 @@
|
|||
&escape #5c18 DEO #7818 DEO ;emit/byte JMP2
|
||||
|
||||
( shared by strings/symbols )
|
||||
@display0-chars ( addr* -> )
|
||||
@display0-sym ( addr* -> )
|
||||
LDAk #0f AND DUP #05 LTH ,&short JCN
|
||||
INC2 LDAk ,display0-char JSR ( addr+1 )
|
||||
INC2 LDAk ,display0-char JSR ( addr+2 )
|
||||
INC2 LDA2 ;obj-to-addr JSR2 ,display0-chars JMP
|
||||
INC2 LDA2 ;obj-to-addr JSR2 ,display0-sym JMP
|
||||
&short
|
||||
#00 SWP SUB STH INC2 ( addr+1 [-len] )
|
||||
&loop ( pos [-i] )
|
||||
|
|
@ -259,36 +258,36 @@
|
|||
INC2 INCr ( pos+1 [-i+1] )
|
||||
STHkr ,&loop JCN ( pos+1 [-i+1] )
|
||||
POP2 POPr JMP2r ( )
|
||||
|
||||
@display0-str ( addr* -> )
|
||||
#2218 DEO ;display0-chars JSR2 #2218 DEO JMP2r
|
||||
@display0-sym ( addr* -> )
|
||||
#2718 DEO ;display0-chars JSR2 JMP2r
|
||||
#2218 DEO ;display0-sym JSR2 #2218 DEO JMP2r
|
||||
|
||||
@display0-lst ( addr* -> )
|
||||
INC2 LDA2k ( addr+1* head$ )
|
||||
SWP2 INC2 INC2 ( head$ addr+3* )
|
||||
LDA2 SWP2 ( tail$ head$ )
|
||||
LIT "( #18 DEO ( tail$ head$ )
|
||||
;display0 JSR2 ( tail$ )
|
||||
INC2 LDA2k ( addr+1* head$ )
|
||||
SWP2 INC2 INC2 ( head$ addr+3* )
|
||||
LDA2 SWP2 ( tail$ head$ )
|
||||
LIT 28 #18 DEO ( tail$ head$ )
|
||||
;display0 JSR2 ( tail$ )
|
||||
;echo JSR2 20 ". 20 00
|
||||
;display0 JSR2
|
||||
LIT ") #18 DEO JMP2r
|
||||
LIT 29 #18 DEO JMP2r
|
||||
|
||||
@read-object ( ref$ -> tag^ ohi* olo* )
|
||||
@read-object ( ref$ -> tag^ ohi$ olo$ )
|
||||
ORAk #00 EQU ,&error JCN
|
||||
OVR #c0 AND ,&error JCN
|
||||
;obj-to-addr JSR2 ( addr )
|
||||
STH2k LDA ( tag^ [addr] )
|
||||
INC2r STH2kr LDA2 ( tag^ ohi* [addr+1] )
|
||||
INC2r INC2r STH2r LDA2 ( tag^ ohi* olo* )
|
||||
;obj-to-addr JSR2 ( addr )
|
||||
STH2k LDA ( tag^ [addr] )
|
||||
INC2r STH2kr LDA2 ( tag^ ohi$ [addr+1] )
|
||||
INC2r INC2r STH2r LDA2 ( tag^ ohi$ olo$ )
|
||||
JMP2r
|
||||
&error
|
||||
POP2 ;error JMP2
|
||||
|
||||
@byte-to-bool ( x^ -> bool$ )
|
||||
#5ffe ( x 5f fe )
|
||||
ROT ( 5f fe x )
|
||||
#00 NEQ ( 5f fe 0-or-1 )
|
||||
ORA ( 5f fe-or-ff )
|
||||
@byte-to-bool ( x^ -> bool$ )
|
||||
#5ffe ( x 5f fe )
|
||||
ROT ( 5f fe x )
|
||||
#00 NEQ ( 5f fe 0-or-1 )
|
||||
ORA ( 5f fe-or-ff )
|
||||
JMP2r
|
||||
|
||||
@u16-to-num ( x* -> num$ )
|
||||
|
|
@ -303,18 +302,18 @@
|
|||
#0005 MUL2 ;objects ADD2 JMP2r
|
||||
|
||||
@make ( tag^ -> addr* )
|
||||
;objects LDA2 ( tag^ arena* )
|
||||
;alloc JSR2 ( tag^ addr* )
|
||||
STH2k STA ( [addr*] )
|
||||
STH2r JMP2r ( addr* )
|
||||
;objects LDA2 ( tag^ arena* )
|
||||
;alloc JSR2 ( tag^ addr* )
|
||||
STH2k STA ( [addr*] )
|
||||
STH2r JMP2r ( addr* )
|
||||
|
||||
@make-obj ( tag^ ohi* olo* -> object$ )
|
||||
;objects LDA2 ( 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 )
|
||||
STH2kr STA ( [addr*] ; addr<-tag )
|
||||
STH2r ;addr-to-obj JMP2 ( object$ )
|
||||
@make-obj ( tag^ ohi$ olo$ -> object$ )
|
||||
;objects LDA2 ( 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 )
|
||||
STH2kr STA ( [addr*] ; addr<-tag )
|
||||
STH2r ;addr-to-obj JMP2 ( object$ )
|
||||
|
||||
@get-type ( ref$ -> type^ )
|
||||
DUP2 #0000 NEQ2 ,¬-nul JCN POP2 #00 JMP2r
|
||||
|
|
@ -325,6 +324,12 @@
|
|||
¬-tal DUP2 #4000 LTH2 ,¬-sym JCN POP2 #10 JMP2r
|
||||
¬-sym ;read-object JSR2 POP2 POP2 #f0 AND JMP2r
|
||||
|
||||
@assert-cons ( ref$ -> )
|
||||
DUP2 #c000 AND2 ,¬-obj JCN ( ref$ )
|
||||
DUP2 ;read-object JSR2 POP2 POP2 ( ref$ tag^ )
|
||||
#f0 AND ,¬-obj JCN JMP2r ( ref$ )
|
||||
¬-obj POP2 ;error JMP2 ( ref$ )
|
||||
|
||||
@builtins
|
||||
|
||||
@null? ( r$ -> bool$ ) #0000 EQU2 ;byte-to-bool JMP2
|
||||
|
|
@ -337,26 +342,59 @@
|
|||
@bool? ( r$ -> bool$ ) ;get-type JSR2 #50 EQU ;byte-to-bool JMP2
|
||||
@tal? ( r$ -> bool$ ) ;get-type JSR2 #60 EQU ;byte-to-bool JMP2
|
||||
|
||||
@len ( lst$ -> n$ )
|
||||
LIT2r 0000 ( lst$ [0] )
|
||||
&loop ( xs$ [n*] )
|
||||
ORAk ,&continue JCN ( xs$ [n*] )
|
||||
POP2 STH2r ( n* )
|
||||
;u16-to-num JMP2 ( n$ )
|
||||
&continue ( xs$ [n*] )
|
||||
INC2r ;cdr JSR2 ( tail$ [n+1*] )
|
||||
,&loop JMP ( tail$ [n+1*] )
|
||||
|
||||
@cons ( h$ t$ -> cons$ )
|
||||
STH2 STH2 ( [t$ h$] )
|
||||
#00 STH2r STH2r ( 00 h$ t$ )
|
||||
;make-obj JMP2 ( cons$ )
|
||||
STH2 STH2 ( [t$ h$] )
|
||||
#00 STH2r STH2r ( 00 h$ t$ )
|
||||
;make-obj JMP2 ( cons$ )
|
||||
|
||||
@car ( ref$ -> h* )
|
||||
;read-object JSR2 ( tag^ ohi* olo* )
|
||||
POP2 STH2 ( tag^ [ohi*] )
|
||||
#f0 AND ,&error JCN ( [ohi*] ; tag should be 0 )
|
||||
STH2r JMP2r ( ohi* )
|
||||
&error ( [ohi*] )
|
||||
POP2r ;error JMP2 ( )
|
||||
@car ( lst$ -> h$ )
|
||||
;read-object JSR2 ( tag^ ohi$ olo$ )
|
||||
POP2 STH2 ( tag^ [ohi$] )
|
||||
,cdr/shared JMP
|
||||
|
||||
@cdr ( ref$ -> h* )
|
||||
;read-object JSR2
|
||||
NIP2 STH2 ( tag^ [olo*] )
|
||||
#f0 AND ,&error JCN ( tag should be 0 )
|
||||
STH2r JMP2r
|
||||
&error
|
||||
POP2r ;error JMP2
|
||||
@cdr ( ref$ -> t$ )
|
||||
;read-object JSR2 ( tag^ ohi$ olo$ )
|
||||
NIP2 STH2 ( tag^ [olo$] )
|
||||
&shared ( tag^ [olo$] )
|
||||
#f0 AND ,&error JCN ( [ptr$] ; tag should be 0 )
|
||||
STH2r JMP2r ( ptr$ )
|
||||
&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! ( lst$ 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$] )
|
||||
#0003 ADD2 ( addr+3 [x$] )
|
||||
STH2r SWP2 STA2 ( ; addr+3<-x )
|
||||
|
||||
@append! ( lst$ x$ -> )
|
||||
#0000 ;cons JSR2 ;extend! JMP2
|
||||
|
||||
@extend! ( lst$ tail$ -> )
|
||||
SWP2 ;last JSR2 SWP2 ;cdr! JMP2
|
||||
|
||||
|1004 ( ;arenas needs to be a multiple of 5 )
|
||||
~alloc.tal
|
||||
|
|
|
|||
Loading…
Reference in New Issue