hoax 2
This commit is contained in:
parent
2600b8c568
commit
5c531428af
219
hoax.tal
219
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 <rest-of-code> )
|
||||
@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
|
||||
|
|
|
|||
Loading…
Reference in New Issue