diff --git a/hoax.tal b/hoax.tal index c84e787..5066876 100644 --- a/hoax.tal +++ b/hoax.tal @@ -48,6 +48,17 @@ ( 30 08 int negative four byte (bcde) int ) ( 30 0c int negative lsb (bc) + next ptr (de) ) ( 40 n/a rational rational number (bc/de) ) +( 50 n/a bool (not allocated but used as type) ) +( 60 n/a builtin (not allocated but used as type) ) + +%NL { #0a18 DEO } +%SP { #2018 DEO } +%BX { ;emit/byte JSR2 } +%SX { ;emit/short JSR2 } +%DEBUG { #010e DEO } +%EXIT { #010f DEO BRK } + +%D { ;display JSR2 } %null { #0000 } %false { #5ffe } @@ -58,16 +69,59 @@ @objects $2 |0100 - BRK + ;init-hoax JSR2 + null ;null? JSR2 D + null ;list? JSR2 D + null ;number? JSR2 D + null D + #0000 ;u16-to-num JSR2 D + #0001 ;u16-to-num JSR2 D + #1234 ;u16-to-num JSR2 D + #3fff ;u16-to-num JSR2 D + #4000 ;u16-to-num JSR2 D + #4001 ;u16-to-num JSR2 D + #ffff ;u16-to-num JSR2 D + #30 #5678 #9abc ;make-obj JSR2 STH2k D + #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 + #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 + DEBUG EXIT + +@emit + &short SWP ,&byte JSR + &byte DUP #04 SFT ,&char JSR + &char #0f AND DUP #09 GTH #27 MUL ADD #30 ADD #18 DEO + JMP2r + +( usage: ;print JSR2 "literal-string 00 ) +@print ( -- ) + LDArk STHr DUP #18 DEO + INC2r ,print JCN JMP2r @init-hoax ( -> ) - #2000 #0005 ;init-arena JSR2 ( allocate 8192 5-byte object slots ) + ( need to ensure that ;arenas is ) + ( is divisible by 5, since: ) + ( obj = (addr - arenas) / 5 ) + ( addr = (obj * 5) + arenas ) + ;arenas #0005 DIV2 #0005 MUL2 ;arenas EQU2 ,&ok JCN + ;print JSR2 "invalid 20 "arenas 20 "( 00 + ;arenas ;emit/short JSR2 + ;print JSR2 ") 20 "not 20 "divisible 20 "by 20 "5 0a 00 + EXIT + &ok + ( allocate 8192 5-byte object slots ) + #2000 #0005 ;init-arena JSR2 ;objects STA2 JMP2r @buffers &x $64 &y $64 &z $64 @error ( -> ) + #0000 DIV ( TODO ) ( CONVENTIONS ) ( ) @@ -76,9 +130,89 @@ ( ) ( errors will clear the stack and jump to ;error ) +@display ( ref$ -> ) + ;display0 JSR2 NL JMP2r + +@display0 ( ref$ -> ) + DUP2 #7fff GTH2 ,&litnum JCN + DUP2 #5fff GTH2 ,&builtin JCN + DUP2 #3fff GTH2 ,&const JCN + ;display0-object JMP2 + &litnum #8000 EOR2 ;print JSR2 "0x 00 ;emit/short JMP2 + &builtin ;print JSR2 "builtin< 00 ;emit/short JSR2 LIT "> #18 DEO JMP2r + &const DUP2 false NEQ2 ,¬-false JCN POP2 ;print JSR2 "#f 00 JMP2r + ¬-false DUP2 true NEQ2 ,¬-true JCN POP2 ;print JSR2 "#t 00 JMP2r + ¬-true ;print JSR2 "const< 00 ;emit/short JSR2 LIT "> #18 DEO JMP2r + +@display0-object ( ref$ -> ) + DUP2 #0000 NEQ2 ,¬-null JCN POP2 ;print JSR2 "null 00 JMP2r + ¬-null ;obj-to-addr JSR2 ( addr* ) + LDAk #50 LTH ,¬-unk JCN ;display0-unk JMP2 + ¬-unk LDAk #40 LTH ,¬-rat JCN ;display0-rat JMP2 + ¬-rat LDAk #30 LTH ,¬-int JCN ;display0-int JMP2 + ¬-int LDAk #20 LTH ,¬-str JCN ;display0-str JMP2 + ¬-str LDAk #10 LTH ,¬-sym JCN ;display0-sym JMP2 + ¬-sym ;display0-lst JMP2 + +@display0-unk ( addr* -> ) + ;print JSR "unknown< 00 ;emit/short JSR2 LIT "> #18 DEO JMP2r +@display0-rat ( addr* -> ) + INC2 LDA2k ;display0 JSR2 + LIT "/ #18 DEO + INC2 INC2 LDA2 ;display0 JMP2 +@display0-int ( addr* -> ) + LDAk #80 LTH ,&non-neg JCN LIT "- #18 DEO + &non-neg + ;print JSR2 "0x 00 + &loop + LDAk #04 AND ,&is-long JCN + INC2 LDA2k ;emit/short JSR2 + INC2 INC2 LDA2 ;emit/short JMP2 + &is-long + INC2 LDA2k ;emit/short JSR2 + INC2 INC2 LDA2 ;obj-to-addr JSR2 + ,&loop JMP + +( TODO: \n \t etc. ) +@display0-char ( c^ -> ) + DUP #20 LTH ,&escape JCN + DUP #7e GTH ,&escape JCN + DUP #5c ( \ ) EQU ,&escape JCN + DUP #22 ( " ) EQU ,&escape JCN + DUP #27 ( ' ) EQU ,&escape JCN #18 DEO JMP2r + &escape #5c18 DEO #7818 DEO ;emit/byte JMP2 + +( shared by strings/symbols ) +@display0-chars ( 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 + &short + #00 SWP SUB STH INC2 ( addr+1 [-len] ) + &loop ( pos [-i] ) + LDAk ,display0-char JSR ( pos [-i] ) + 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 + +@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$ ) + ;print JSR2 20 ". 20 00 + ;display0 JSR2 + LIT ") #18 DEO JMP2r + @read-object ( ref$ -> tag^ ohi* olo* ) OVR #c0 AND ,&error JCN - #0005 MUL2 ;objects ADD2 ( addr ) + ;obj-to-addr JSR2 ( addr ) STH2k LDA ( tag^ [addr] ) INC2r STH2kr LDA2 ( tag^ ohi* [addr+1] ) INC2r INC2r STH2r LDA2 ( tag^ ohi* olo* ) @@ -86,47 +220,63 @@ &error POP2 ;error JMP2 -@to-bool ( x^ -> bool$ ) +@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$ ) + DUP2 #4000 LTH2 ,&small JCN + STH2 #30 #0000 STH2r ;make-obj JMP2 + &small #8000 ORA2 JMP2r + +@addr-to-obj ( addr* -> obj$ ) + ;objects SUB2 #0005 DIV2 JMP2r + +@obj-to-addr ( obj$ -> addr* ) + #0005 MUL2 ;objects ADD2 JMP2r + +@make ( tag^ -> 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$ ) + +@get-type ( ref$ -> type^ ) + DUP2 #0000 NEQ2 ,¬-nul JCN POP2 #00 JMP2r + ¬-nul DUP2 #5ffe NEQ2 ,¬-f JCN POP2 #50 JMP2r + ¬-f DUP2 #5fff NEQ2 ,¬-t JCN POP2 #50 JMP2r + ¬-t DUP2 #8000 LTH2 ,¬-int JCN POP2 #30 JMP2r + ¬-int DUP2 #6000 LTH2 ,¬-tal JCN POP2 #60 JMP2r + ¬-tal DUP2 #4000 LTH2 ,¬-sym JCN POP2 #10 JMP2r + ¬-sym ;read-object JSR2 POP2 POP2 #f0 AND JMP2r + @builtins -@null? ( r$ -> bool$ ) - #0000 EQU2 ;to-bool JMP2 - -@list? ( r$ -> bool$ ) - ORAk ,¬-null JCN ( r ) - POP2 true JMP2r ( true ) - ¬-null ( r ) - DUP2 #c000 AND2 ( r r&c000 ) - ORA ,¬-object JCN ( r ) - ;read-object JSR2 ( tag^ ohi* olo* ) - POP2 POP2 ( tag^ ) - ,¬-list JCN ( ) - true JMP2r ( true ) - ¬-object POP2 ( ) - ¬-list false JMP2r ( false ) - -@number? ( r$ -> bool$ ) - DUP2 #8000 AND2 ORA ,&ref-num JCN - DUP2 #c000 AND2 ORA ,¬-obj JCN - ;read-object JSR2 POP2 POP2 #f0 AND ( tag^ ) - DUP #30 EQU SWP #40 EQU ;to-bool JMP2 - &ref-num POP2 true JMP2r - ¬-obj POP2 false JMP2r +@null? ( r$ -> bool$ ) #0000 EQU2 ;byte-to-bool JMP2 +@list? ( r$ -> bool$ ) ;get-type JSR2 #00 EQU ;byte-to-bool JMP2 +@symbol? ( r$ -> bool$ ) ;get-type JSR2 #10 EQU ;byte-to-bool JMP2 +@string? ( r$ -> bool$ ) ;get-type JSR2 #20 EQU ;byte-to-bool JMP2 +@number? ( r$ -> bool$ ) ;get-type JSR2 DUP #30 EQU SWP #40 EQU ORA ;byte-to-bool JMP2 +@int? ( r$ -> bool$ ) ;get-type JSR2 #30 EQU ;byte-to-bool JMP2 +@rational? ( r$ -> bool$ ) ;get-type JSR2 #40 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 @cons ( h$ t$ -> cons$ ) - SWP2 ( t h ) - ;objects LDA2 ;alloc JSR2 STH2k ( t h addr [addr] ) - #00 STH2kr STA ( t h [addr] ; addr<-00 ) - STH2kr INC2 STA2 ( t [addr] ; addr+1<-h ) - STH2kr #0003 ADD2 STA2 ( [addr] ; addr+3<-t ) - STH2r ;objects SUB2 ( delta ) - #0005 DIV2 JMP2r ( object ) + STH2 STH2 ( [t$ h$] ) + #00 STH2r STH2r ( 00 h$ t$ ) + ;make-obj JMP2 ( cons$ ) @car ( ref$ -> h* ) ;read-object JSR2 ( tag^ ohi* olo* ) @@ -144,4 +294,5 @@ &error POP2r ;error JMP2 +|1004 ( ;arenas needs to be a multiple of 5 ) ~alloc.tal