nxu/hoax.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

@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      ( <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$ )

@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 ,&not-false JCN POP2 ;echo JSR2 "#f 00 JMP2r
    &not-false DUP2 true  NEQ2 ,&not-true  JCN POP2 ;echo JSR2 "#t 00 JMP2r
    &not-true ;echo JSR2 "const< 00 ;emit/short JSR2 LIT "> #18 DEO JMP2r

@display0-object ( ref$ -> )
    DUP2 #0000 NEQ2 ,&not-null JCN POP2 ;echo JSR2 "null 00 JMP2r
    &not-null ;obj-to-addr JSR2 ( addr* )
             LDAk #50 LTH ,&not-unk JCN ;display0-unk JMP2
    &not-unk LDAk #40 LTH ,&not-rat JCN ;display0-rat JMP2
    &not-rat LDAk #30 LTH ,&not-int JCN ;display0-int JMP2
    &not-int LDAk #20 LTH ,&not-str JCN ;display0-str JMP2
    &not-str LDAk #10 LTH ,&not-sym JCN ;display0-sym JMP2
    &not-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 ,&not-nul JCN POP2 #00 JMP2r
    &not-nul DUP2 #5ffe NEQ2 ,&not-f   JCN POP2 #50 JMP2r
    &not-f   DUP2 #5fff NEQ2 ,&not-t   JCN POP2 #50 JMP2r
    &not-t   DUP2 #8000 LTH2 ,&not-int JCN POP2 #30 JMP2r
    &not-int DUP2 #6000 LTH2 ,&not-tal JCN POP2 #60 JMP2r
    &not-tal DUP2 #4000 LTH2 ,&not-sym JCN POP2 #10 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

@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$] )
        ,&not-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$ )
    &not-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$] )
        ,&not-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$ )
    &not-obj                     ( list$ ohi$ olo$ )
        POP2 POP2 POP2 POP2r     ( )
        #0000 JMP2r              ( 0000 )


|1004 ( ;arenas needs to be a multiple of 5 )
~alloc.tal