682 lines
26 KiB
Tal
682 lines
26 KiB
Tal
( hoax.tal )
|
|
( )
|
|
( ADDRESSES )
|
|
( )
|
|
( hoax uses 16-bit references. within these two bytes, the top bits )
|
|
( determine the type of reference and the bottom bits determine its )
|
|
( location or value: )
|
|
( )
|
|
( BIT PATTERN RANGE DESCRIPTION )
|
|
( 00...... ........ 0000-3fff 14-bit object address )
|
|
( 00000000 00000000 (0000) null (empty list) )
|
|
( 00000000 00000001 (0001) object in arena slot 1 )
|
|
( 00100000 00000000 (2000) object in arena slot 8192 )
|
|
( 010..... ........ 4000-5fff 13-bit constant index )
|
|
( 01000000 00000000 (4000) symbol interned at offset 0 )
|
|
( 01010000 00000000 (5000) symbol interned at offset 4096 )
|
|
( 01011111 11111110 (5ffe) #f )
|
|
( 01011111 11111111 (5fff) #t )
|
|
( 011..... ........ 6000-7fff 13-bit uxn builtin address )
|
|
( 01100000 00000000 (6000) cons )
|
|
( 01100000 00000001 (6001) lambda )
|
|
( 1....... ........ 8000-ffff signed 15-bit number )
|
|
( 10000000 00000000 (8000) 0 )
|
|
( 10000000 00000001 (8001) 1 )
|
|
( 10111111 11111111 (bfff) 16383 )
|
|
( 10100000 00000001 (c000) -16384 )
|
|
( 11111111 11111111 (ffff) -1 )
|
|
( )
|
|
( object references contain an address to additional allocated )
|
|
( memory which includes additional information such as the type. )
|
|
( other references are either literal values (numbers) or else an )
|
|
( index which can be directly interpreted. )
|
|
( )
|
|
( OBJECTS )
|
|
( )
|
|
( objects are 5-byte chunks of memory. each object contains a )
|
|
( 4-bit tag which describes the object's type, a 4-bit flag which )
|
|
( describes details of the type's layout, and 4 bytes of data. )
|
|
( )
|
|
( TAG FLAG BITS NAME DATA LAYOUT )
|
|
( 00 n/a list head ptr (bc) + tail ptr (de) )
|
|
( 10 00 - 04 short symbol length is 0-4 bytes of (bcde) )
|
|
( 10 05 - 0f long symbol two bytes (bc) + next ptr (de) )
|
|
( 20 00 - 04 short string length is 0-4 bytes of (bcde) )
|
|
( 20 05 - 0f long string two bytes (bc) + next ptr (de) )
|
|
( 30 00 int positive four byte (bcde) int )
|
|
( 30 04 int positive lsb (bc) + next ptr (de) )
|
|
( 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) )
|
|
( )
|
|
( INVARIANTS )
|
|
( )
|
|
( 1. integers should always be stored in the most compact way )
|
|
( a. for integer object n, abs(n) > 16383. )
|
|
( 2. long string/symbols have non-empty terminators )
|
|
( a. empty strings are only allowed on their own )
|
|
( b. empty symbols are never allowed )
|
|
( 3. rationals should be in normal form )
|
|
( a. positive denominator > 1 )
|
|
( b. non-zero numerator )
|
|
( c. gcd(numerator, denominator) should be 1 )
|
|
( )
|
|
( EFFICIENCY )
|
|
( )
|
|
( EXPRESSION SIZE (including ref) )
|
|
( #t 2 bytes )
|
|
( #f 2 bytes )
|
|
( 0 2 bytes )
|
|
( 16383 2 bytes )
|
|
( -16384 2 bytes )
|
|
( 16384 7 bytes )
|
|
( 4294967295 7 bytes )
|
|
( 4294967296 12 bytes )
|
|
( -4294967295 7 bytes )
|
|
( -4294967296 12 bytes )
|
|
( 281474976710655 12 bytes )
|
|
( -281474976710655 12 bytes )
|
|
( null 2 bytes )
|
|
( (1 . null) 7 bytes )
|
|
( (1 . (2 . null)) 12 bytes )
|
|
( "" 7 bytes )
|
|
( "a" 7 bytes )
|
|
( "abcd" 7 bytes )
|
|
( "abcde" 12 bytes )
|
|
( )
|
|
( LITERAL SYNTAX )
|
|
( )
|
|
( 1. decimal numbers )
|
|
( 0|-?[1-9](0-9)* )
|
|
( )
|
|
( 2. hexadecimal numbers )
|
|
( 0x[0-9a-f]+ )
|
|
( )
|
|
( 3. bareword )
|
|
( [^-0-9 ][^ ]*|-([^0-9 ][^ ]*)? )
|
|
( )
|
|
( 4. string )
|
|
( "(\.|[^"\])" )
|
|
|
|
( TODO: special case empty string? )
|
|
|
|
%NL { #0a18 DEO }
|
|
%SP { #2018 DEO }
|
|
%BX { ;emit/byte JSR2 }
|
|
%SX { ;emit/short JSR2 }
|
|
%DEBUG { #010e DEO }
|
|
%EXIT { #010f DEO BRK }
|
|
%DIE { #0000 DIV }
|
|
|
|
%D { ;display JSR2 }
|
|
|
|
%null { #0000 }
|
|
%false { #5ffe }
|
|
%true { #5fff }
|
|
%zero { #8000 }
|
|
|
|
|0000
|
|
@objects $2
|
|
@buffer [ &pos $2 &input $7f &limit $1 ] ( max symbol size 127 )
|
|
|
|
|0100
|
|
;init-hoax JSR2
|
|
;buf-reset JSR2
|
|
;on-key-ready #10 DEO2
|
|
;demo JSR2
|
|
( DEBUG EXIT )
|
|
BRK
|
|
|
|
( returns true if buffer contains a hex number or error )
|
|
@buf-is-hex ( -> bool^ )
|
|
;buffer/input ;buffer/pos LDA2 OVR2 SUB2 ( start* size* )
|
|
#0003 LTH2 ,&short JCN ( start* )
|
|
LDA2 LIT2 "0x EQU2 JMP2r ( 0x-prefix? )
|
|
&short POP2 #00 JMP2r ( 00 )
|
|
|
|
( returns true if buffer contains a decimal number or error )
|
|
@buf-is-dec
|
|
;buffer/input ;buffer/pos LDA2 OVR2 SUB2 ( start* size* )
|
|
DUP2 #0000 GTH2 ,&nonempty JCN ( start* size* )
|
|
&empty POP2 POP2 #00 JMP2r ( 00 )
|
|
&nonempty ( start* size* )
|
|
OVR2 LDA LIT "- NEQ ,&continue JCN ( start* size* )
|
|
SWP2 INC2 SWP2 ( start+1* size-1* )
|
|
DUP2 #0000 EQU2 ,&empty JCN ( start+1* size-1* )
|
|
&continue ( start* size* )
|
|
LITr "0 #0001 GTH2 STH ADDr ( start* [lower^] )
|
|
LDAk STH GTHr ( start* [lower>c^] )
|
|
LDA LIT "9 GTH ( start* c>upper^ [lower>c^] )
|
|
STHr ORA #00 EQU JMP2r ( lower<=c&&c<=upper )
|
|
|
|
( 0 = #30, a = #61 )
|
|
@char-to-hex ( c^ -> n^ )
|
|
DUP #60 GTH ,&letter JCN
|
|
#30 SUB JMP2r
|
|
&letter #57 SUB JMP2r
|
|
|
|
@negate ( num$ -> negated$ )
|
|
DUP2 #7fff ;negate-short JCN2
|
|
|
|
@negate-short ( n$ -> negated$ )
|
|
DUP2 #c000 EQU ,&need-alloc JCN ( n$ )
|
|
#7fff EOR2 INC2 JMP2r ( (n^7fff)+1 )
|
|
&need-alloc #c000 ;u16-to-num JMP2 ( -16384 )
|
|
|
|
@negate-long ( n$ -> negated$ )
|
|
|
|
@negate-big ( n$ -> negated$ )
|
|
|
|
@lshift-16 ( num$ -> res$ )
|
|
#0000 ;shift-and-add JMP2
|
|
|
|
( shift number left by 16-bits and perform an unsigned )
|
|
( addition of the given 16-bit integer. )
|
|
( the sign of the 16-bit integer to add is assumed )
|
|
( to be the same as the original number. )
|
|
@shift-and-add ( num$ add* -> res$ )
|
|
STH2 ( num$ [add*] )
|
|
DUP2 #8000 EQU2 ,&iszero JCN ( num$ [add*] )
|
|
DUP2 #7fff GTH2 ,&literal JCN ( num$ )
|
|
DUP2 ;read-object JSR2 ( num$ tag^ ohi* olo* [add*] )
|
|
STH2 STH2 ( num$ tag^ [add* olo* ohi*] )
|
|
DUP #f0 AND ( num$ tag^ type^ [add* olo* ohi*] )
|
|
#30 NEQ ,&error JCN ( num$ tag^ [add* olo* ohi*] )
|
|
#04 ANDk EQU ,&non-zero-hi JCN ( num$ tag^ [add* olo* ohi*] )
|
|
STH2kr ORA ,&non-zero-hi JCN ( num$ tag^ [add* olo* ohi*] )
|
|
POP2r STH2r STH2r ( num$ tag^ olo* add* )
|
|
;make-obj JSR2 NIP2 JMP2r ( res$ )
|
|
&non-zero-hi POP2r POP2r ( num$ tag^ [add*] )
|
|
#04 ORA ROT ROT ( tag^ num$ [add*] )
|
|
STH2r SWP2 ( tag^ add* num$ )
|
|
;make-obj JMP2 ( res$ )
|
|
&literal ( num$ [add*] )
|
|
#7fff AND2 ( n* [add*] )
|
|
DUP2 #3fff GTH2 ,&negative JCN ( n* [add*] )
|
|
#30 ,&create JMP ( n* 30 [add*] )
|
|
&iszero STH2r ;u16-to-num JMP2 ( res$ )
|
|
&error POP POP2 ;error JMP2 ( <ERROR> )
|
|
&negative ( n* [add*] )
|
|
#8000 SWP2 SUB2 #38 ( abs* 38 [add*] )
|
|
&create ( n* ^tag [add*] )
|
|
ROT ROT STH2r ( tag^ n* add* )
|
|
;make-obj JMP2 ( res$ )
|
|
|
|
@add-big-u16 ( x$ y* -> z$ )
|
|
STH2 ;read-object JSR ( xtag^ xhi* xlo* [y*] )
|
|
|
|
|
|
@sym-from-buf ( -> sym$ )
|
|
;buffer/input ;sym-from-buf-src JMP2
|
|
|
|
@sym-from-buf-src ( src* -> sym$ )
|
|
;buffer/pos LDA2 STH2k ( src* limit* [limit*] )
|
|
OVR2 SUB2 ( src* size* [limit*] )
|
|
DUP2 #0005 LTH2 ,&small JCN ( src* size* [limit*] )
|
|
POP2 POP2r ( src* )
|
|
DUP2 INC2 INC2 ( src* src+2* )
|
|
;sym-from-buf-src JSR2 ( src* child$ )
|
|
STH2 STH2k ( src* [child$ src*] )
|
|
LDA STH2r INC LDA STH2 ( [child$ cc*] )
|
|
#18 STH2r STH2r ( tag^ cc* child$ )
|
|
;make-obj JSR2 JMP2r ( obj$ )
|
|
&small ( src* size* [limit*] )
|
|
NIP #10 ORA ( src* tag^ [limit*] )
|
|
;alloc-obj JSR2 STH2k ( src* tag^ new* [limit* new*] )
|
|
STA ( src* [limit* new*] )
|
|
SWP2r STH2r SWP2 ( limit* src* [new*] )
|
|
DUP2r INC2r ( limit* src* [new* new+1*] )
|
|
&loop ( limit* src* [new* dst*] )
|
|
LDAk STH2kr STA ( limit* src* [new* dst*] ; dst<-src )
|
|
INC2 INC2r ( limit* src+1* [new* dst+1*] )
|
|
GTH2k ,&loop JCN ( limit* src+1* [new* dst+1*] ; loop if limit>s )
|
|
POP2 POP2 POP2r STH2r ( new* )
|
|
;addr-to-obj JSR2 JMP2r ( new$ )
|
|
|
|
@convert-sym-to-str ( sym$ -> )
|
|
;obj-to-addr JSR2 STH2k ( addr* [addr*] )
|
|
LDA DUP #30 EOR ( old^ new^ [addr*] )
|
|
STH2kr STA ( old^ [addr*] ; addr<-new )
|
|
#15 LTH ,&done JCN ( [addr*] )
|
|
STH2r INC2 INC2 INC2 LDA2 ( child$ )
|
|
;convert-sym-to-str JMP2 ( )
|
|
&done ( [addr*] )
|
|
POP2r JMP2r ( )
|
|
|
|
@buf-end ( -> )
|
|
#00 ;buffer/pos LDA2 STA ( ; addr<-00 )
|
|
@buf-reset
|
|
;buffer/input ;buffer/pos STA2 ( ; pos<-start )
|
|
JMP2r
|
|
|
|
@buf-add ( c -> )
|
|
;buffer/pos LDA2 STAk ( c^ addr* )
|
|
INC2 ;buffer/pos STA2 ( c^ ; pos<-addr+1 )
|
|
POP JMP2r ( )
|
|
|
|
@start-list ( c -> )
|
|
;echo JSR2 "start 20 "list 0a 00 POP BRK
|
|
|
|
@end-list ( c -> )
|
|
;echo JSR2 "end 20 "list 0a 00 POP BRK
|
|
|
|
@start-string ( c -> )
|
|
;on-key-string #10 DEO2
|
|
POP BRK
|
|
|
|
@append-string ( c -> )
|
|
;buf-add JSR2 BRK
|
|
|
|
@end-string ( c -> )
|
|
POP ;on-key-ready #10 DEO2 ( )
|
|
;echo JSR2 "string 20 00 ( )
|
|
;sym-from-buf JSR2 ( obj$ )
|
|
DUP2 ;convert-sym-to-str JSR2 ( obj$ )
|
|
;display JSR2 ( )
|
|
;buf-end JSR2 BRK ( )
|
|
|
|
@start-word ( c -> )
|
|
;on-key-word #10 DEO2
|
|
;buf-add JSR2 BRK
|
|
|
|
@append-word ( c -> )
|
|
;buf-add JSR2 BRK
|
|
|
|
@end-word0 ( c -> )
|
|
POP ;on-key-ready #10 DEO2 ( )
|
|
;echo JSR2 "word 20 00 ( )
|
|
;buf-is-hex JSR2 BX SP ( )
|
|
;buf-is-dec JSR2 BX SP ( )
|
|
;sym-from-buf JSR2 ( obj$ )
|
|
;display JSR2 ( )
|
|
;buf-end JSR2 JMP2r ( )
|
|
|
|
@start-escape ( c -> )
|
|
;on-key-escaped #10 DEO2 POP BRK
|
|
|
|
( TODO: more sophisticated escapes )
|
|
@on-key-escaped ( -> )
|
|
;on-key-string #10 DEO2
|
|
#12 DEI ;append-string JMP2
|
|
|
|
( string state means we're inside a string literal )
|
|
( waiting to see an unecaped closing double quote )
|
|
@on-key-string ( -> )
|
|
#12 DEI
|
|
DUP #5c EQU ;start-escape JCN2 ( backslash )
|
|
DUP #22 EQU ;end-string JCN2 ( dquote )
|
|
;append-string JMP2
|
|
|
|
( word state means we're in a word until whitespace )
|
|
@on-key-word ( -> )
|
|
#12 DEI
|
|
DUP #29 EQU ,&end JCN ( rpar )
|
|
DUP #09 EQU ,&space JCN ( tab )
|
|
DUP #0a EQU ,&space JCN ( nl )
|
|
DUP #0d EQU ,&space JCN ( cr )
|
|
DUP #20 EQU ,&space JCN ( sp )
|
|
DUP #20 LTH ,&skip JCN ( control chars )
|
|
DUP #7e GTH ,&skip JCN ( delete + 8bit )
|
|
;append-word JMP2
|
|
&skip
|
|
POP BRK
|
|
&space
|
|
;end-word0 JSR2 BRK
|
|
&end
|
|
;end-word0 JSR2
|
|
#00 ;end-list JMP2
|
|
|
|
( ready state means we are expecing a complete value )
|
|
@on-key-ready ( -> )
|
|
#12 DEI
|
|
DUP #28 EQU ;start-list JCN2 ( lpar )
|
|
DUP #29 EQU ;end-list JCN2 ( rpar )
|
|
DUP #22 EQU ;start-string JCN2 ( dquote )
|
|
DUP #09 EQU ,&space JCN ( tab )
|
|
DUP #0a EQU ,&space JCN ( nl )
|
|
DUP #0d EQU ,&space JCN ( cr )
|
|
DUP #20 EQU ,&space JCN ( sp )
|
|
DUP #20 LTH ,&skip JCN ( control chars )
|
|
DUP #7e GTH ,&skip JCN ( delete + 8bit )
|
|
;start-word JMP2
|
|
&space
|
|
POP BRK
|
|
&skip
|
|
POP BRK
|
|
|
|
@demo
|
|
null ;null? JSR2 D
|
|
null ;cons? 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 STH2k D
|
|
STH2r ;lshift-16 JSR2 STH2k D
|
|
STH2r ;lshift-16 JSR2 STH2k D
|
|
STH2r ;lshift-16 JSR2 STH2k D
|
|
STH2r ;lshift-16 JSR2 STH2k D
|
|
STH2r ;lshift-16 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 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
|
|
#13 LIT2 "cd LIT2 "e 00 ;make-obj JSR2 STH2
|
|
#18 LIT2 "ab STH2r ;make-obj JSR2 D
|
|
STH2kr ;emit/short JSR2 NL
|
|
STH2kr D
|
|
STH2kr ;len JSR2 D
|
|
STH2r ;cdr JSR2 ;len JSR2 D
|
|
JMP2r
|
|
|
|
@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
|
|
|
|
@print ( addr -> )
|
|
LDAk ,&ok JCN POP2 JMP2r
|
|
&ok LDAk #18 DEO INC2 ,print JMP
|
|
|
|
( usage: ;echo JSR2 "literal-string 00 <rest-of-code> )
|
|
@echo ( -> )
|
|
LDAkr STHr DUP #18 DEO
|
|
INC2r ,echo JCN JMP2r
|
|
|
|
@init-hoax ( -> )
|
|
( 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
|
|
;echo JSR2 "invalid 20 "arenas 20 28 00
|
|
;arenas ;emit/short JSR2
|
|
;echo JSR2 29 20 "not 20 "divisible 20 "by 20 "5 0a 00
|
|
EXIT
|
|
&ok
|
|
( allocate 8192 5-byte object slots )
|
|
#2000 #0005 ;init-arena JSR2 .objects STZ2
|
|
|
|
( set up buffers )
|
|
;buffer/input ;buffer/pos STA2
|
|
JMP2r
|
|
|
|
@error ( -> )
|
|
#0000 DIV ( TODO )
|
|
|
|
( CONVENTIONS )
|
|
( )
|
|
( word$ - 2-byte reference )
|
|
( object# - 5-byte object )
|
|
( )
|
|
( 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 ;echo JSR2 "0x 00 ;emit/short JMP2
|
|
&builtin ;echo JSR2 "builtin< 00 ;emit/short JSR2 LIT "> #18 DEO JMP2r
|
|
&const DUP2 false NEQ2 ,¬-false JCN POP2 ;echo JSR2 "#f 00 JMP2r
|
|
¬-false DUP2 true NEQ2 ,¬-true JCN POP2 ;echo JSR2 "#t 00 JMP2r
|
|
¬-true ;echo JSR2 "const< 00 ;emit/short JSR2 LIT "> #18 DEO JMP2r
|
|
|
|
@display0-object ( ref$ -> )
|
|
DUP2 #0000 NEQ2 ,¬-null JCN POP2 ;echo 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* -> )
|
|
;echo 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 ( addr* )
|
|
LIT "- #18 DEO ( addr* )
|
|
&non-neg ( addr* )
|
|
;echo JSR2 "0x 00 ( addr* )
|
|
,&loop JSR JMP2r ( )
|
|
&loop ( addr* )
|
|
LDAk #04 AND ,&is-long JCN ( addr* )
|
|
INC2 LDA2k ;emit/short JSR2 ( addr+1* )
|
|
INC2 INC2 LDA2 ;emit/short JMP2 ( )
|
|
&is-long ( addr* )
|
|
INC2 DUP2 INC2 INC2 ( addr+1* addr+3* )
|
|
LDA2 ;obj-to-addr JSR2 ( addr+1* obj$ )
|
|
,&loop JSR ( addr+1* )
|
|
LDA2 ;emit/short JMP2 ( )
|
|
|
|
( 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-sym ( addr* -> )
|
|
LDAk #0f AND ( addr* sz^ )
|
|
DUP #05 LTH ,&short JCN ( addr* sz^ )
|
|
POP
|
|
INC2 LDAk ,display0-char JSR ( addr+1 )
|
|
INC2 LDAk ,display0-char JSR ( addr+2 )
|
|
INC2 LDA2 ;obj-to-addr JSR2 ,display0-sym JMP
|
|
&short ( addr* sz^ )
|
|
#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-sym JSR2 #2218 DEO JMP2r
|
|
|
|
@display0-lst ( addr* -> )
|
|
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 29 #18 DEO JMP2r
|
|
|
|
@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$ )
|
|
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 )
|
|
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 LDZ2 SUB2 #0005 DIV2 JMP2r
|
|
|
|
@obj-to-addr ( obj$ -> addr* )
|
|
#0005 MUL2 .objects LDZ2 ADD2 JMP2r
|
|
|
|
@make ( tag^ -> addr* )
|
|
.objects LDZ2 ( tag^ arena* )
|
|
;alloc JSR2 ( tag^ addr* )
|
|
STH2k STA ( [addr*] )
|
|
STH2r JMP2r ( addr* )
|
|
|
|
@alloc-obj ( -> addr* )
|
|
.objects LDZ2 ;alloc JMP2
|
|
|
|
@make-obj ( tag^ ohi$ olo$ -> object$ )
|
|
.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 )
|
|
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 ;obj-to-addr JSR2 #f0 AND JMP2r
|
|
|
|
@is-short-int ( ref$ -> bool^ )
|
|
#7fff GTH JMP2r ( ref>7fff^ )
|
|
|
|
@is-long-int ( ref$ -> bool^ )
|
|
DUP2 #3fff GTH ,&nope ( ref$ )
|
|
;obj-to-addr JSR2 LDA ( tag^ )
|
|
#f7 AND #30 EQU JMP2r ( (tag^f7)==30^ )
|
|
&nope POP2 #00 JMP2r ( 00 )
|
|
|
|
@is-big-int ( ref$ -> bool^ )
|
|
DUP2 #3fff GTH ,&nope ( ref$ )
|
|
;obj-to-addr JSR2 LDA ( tag^ )
|
|
#f7 AND #34 EQU JMP2r ( (tag^f7)==34^ )
|
|
&nope POP2 #00 JMP2r ( 00 )
|
|
|
|
@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
|
|
@cons? ( 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
|
|
|
|
@list? ( r$ -> bool$ )
|
|
DUP2 #0000 EQU2 ,&yes JCN ( r$ )
|
|
;read-object JSR2 ( tag^ ohi$ olo$ )
|
|
STH2 POP2 #f0 AND ( not-list^ [olo$] )
|
|
,&no JCN ( [olo$] )
|
|
STH2r ,list? JMP ( tail$ )
|
|
&yes ( r$ )
|
|
POP2 #5fff JMP2r ( t$ )
|
|
&no ( [olo$] )
|
|
POP2r #5ffe JMP2r ( f$ )
|
|
|
|
@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$ )
|
|
|
|
@car ( pair$ -> h$ )
|
|
;read-object JSR2 ( tag^ ohi$ olo$ )
|
|
POP2 STH2 ( tag^ [ohi$] )
|
|
&shared ( tag^ [ohi$] )
|
|
#f0 AND ,&error JCN ( [ohi$] ; tag should be 0 )
|
|
STH2r JMP2r ( ohi$ )
|
|
&error ( [ohi$] )
|
|
POP2r ;error JMP2 ( )
|
|
|
|
@cdr ( pair$ -> t$ )
|
|
;read-object JSR2 ( tag^ ohi$ olo$ )
|
|
NIP2 STH2 ( tag^ [olo$] )
|
|
,car/shared JMP ( tag^ [olo$] )
|
|
|
|
@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 )
|
|
|
|
@cdr! ( pair$ x$ -> pair$ )
|
|
STH2 ;assert-cons JSR2 ( pair$ [x$] )
|
|
DUP2 ;obj-to-addr JSR2 ( pair$ addr* [x$] )
|
|
#0003 ADD2 ( pair$ addr+3 [x$] )
|
|
STH2r SWP2 STA2 JMP2r ( pair$ ; addr+3<-x )
|
|
|
|
@get ( list$ key$ -> result$ )
|
|
STH2 ( list$ [x$] )
|
|
&loop ( list$ [x$] )
|
|
DUP2 ;read-object JSR2 ( list$ tag^ ohi$ ohlo$ [x$] )
|
|
,¬-obj JCN ( list$ ohi$ olo$ [x$] )
|
|
SWP2 STH2kr EQU2 ( list$ olo$ found^ [x$] )
|
|
,&found JCN ( list$ olo$ [x$] )
|
|
NIP2 ,&loop JMP ( olo$ [x$] )
|
|
&found ( list$ olo$ [x$] )
|
|
POP2r POP2 JMP2r ( list$ )
|
|
¬-obj ( list$ ohi$ olo$ )
|
|
POP2 POP2 POP2 POP2r ( )
|
|
#0000 JMP2r ( 0000 )
|
|
|
|
@find ( list$ x$ -> result$ )
|
|
STH2 ( list$ [x$] )
|
|
&loop ( list$ [x$] )
|
|
DUP2 ;read-object JSR2 ( list$ tag^ ohi$ ohlo$ [x$] )
|
|
,¬-obj JCN ( list$ ohi$ olo$ [x$] )
|
|
SWP2 STH2kr EQU2 ( list$ olo$ found^ [x$] )
|
|
,&found JCN ( list$ olo$ [x$] )
|
|
NIP2 ,&loop JMP ( olo$ [x$] )
|
|
&found ( list$ olo$ [x$] )
|
|
POP2r POP2 JMP2r ( list$ )
|
|
¬-obj ( list$ ohi$ olo$ )
|
|
POP2 POP2 POP2 POP2r ( )
|
|
#0000 JMP2r ( 0000 )
|
|
|
|
|
|
|1004 ( ;arenas needs to be a multiple of 5 )
|
|
~alloc.tal
|