( 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 @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 #4000 GTH2 ,&negative JCN ( n* [add*] ) #30 ,&create JMP ( n* 30 [add*] ) &iszero JMP2r ( zero$ [add*] ) &error POP POP2 ;error JMP2 ( ) &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 ) @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