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                                       )

( 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 }

%D { ;display JSR2 }

%null { #0000 }
%false { #5ffe }
%true { #5fff }
%zero { #8000 }

|0000
    @objects $2

|0100
    ;init-hoax JSR2
    ;on-char #10 DEO2
    ;demo JSR2
(    DEBUG EXIT )
    BRK

@on-char ( -> )
    #12 DEI #0a EQU ,&newline JCN
        #12 DEI ;buffer/pos LDA2 STAk ( c pos ; addr<-c )
        INC2 ;buffer/pos STA2 POP BRK  ( )
    &newline
        #00 ;buffer/pos LDA2 STA ( ; addr<-00 )
        ;buffer/input DUP2 ;buffer/pos STA2
        ;echo JSR2 "read: 20 00 ;print JSR2 #0a18 DEO
        BRK

@demo
    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
    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 ( -> )
    LDArk 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 "( 00
        ;arenas ;emit/short JSR2
        ;echo 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

        ( set up buffers )
        ;buffer/input ;buffer/pos STA2
    JMP2r

@buffer
    &pos $2 &input $80
(    &x-pos $2 &x $40
    &y-pos $2 &y $40
    &z-pos $2 &z $40 )

@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 LIT "- #18 DEO
    &non-neg
        ;echo 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$ )
    ;echo JSR2 20 ". 20 00
    ;display0 JSR2
    LIT ") #18 DEO JMP2r

@read-object ( ref$ -> tag^ ohi* olo* )
    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 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 ,&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

@builtins

@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$ )
    STH2 STH2       ( [t$ h$] )
    #00 STH2r STH2r ( 00 h$ t$ )
    ;make-obj JMP2  ( cons$ )

@car ( ref$ -> h* )
    ;read-object JSR2     ( tag^ ohi* olo* )
    POP2 STH2             ( tag^ [ohi*] )
    #f0 AND ,&error JCN   ( [ohi*] ; tag should be 0 )
        STH2r JMP2r       ( ohi* )
    &error                ( [ohi*] )
        POP2r ;error JMP2 ( )

@cdr ( ref$ -> h* )
    ;read-object JSR2
    NIP2 STH2 ( tag^ [olo*] )
    #f0 AND ,&error JCN ( tag should be 0 )
        STH2r JMP2r
    &error
        POP2r ;error JMP2

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