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

more hoax

This commit is contained in:
~d6 2022-12-01 10:25:29 -05:00
parent fa5cef3a0b
commit d40db315db
1 changed files with 96 additions and 58 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

110
hoax.tal
View File

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