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

    ( 00 start )
    ( 01 symbol )
    ( 02 string )
    ( 03 escape )
    ( 04 comment )
    @state $1
    @stack $2
    @buffer [ &pos $1 &input $40 ] ( max symbol size 64 )

|0100
    ;init-hoax JSR2
    #00 .state STZ
    ;on-key #10 DEO2
    ;reset-input JSR2
    ;demo JSR2
(    DEBUG EXIT )
    BRK

@reset-input ( -> )
    #0000 #0000 ;cons JSR2      ( pair$ )
    .stack STZ2                 ( ; stack<-pair )
    JMP2r

@complete-with ( v$ -> )
    .stack LDZ2                 ( v$ stack$ )
    STH2k SWP2 ;car! JSR2       ( [stack] ; car(stack)<-v )
    #0000 STH2r ;cons JSR2      ( cell$ )
    .stack STZ2                 ( stack<- )

@start-list ( -> )
    #0000 .stack LDZ2           ( 0000 stack$ )
    ;cons JSR2                  ( pair$ )
    DUP2 .stack STZ2            ( pair$ ; stack<-pair )

    .stack/pos LDZ              ( a^ )
    STHk LDZ2                   ( base$ [a^] )
    #0000 #0000 ;cons JSR2      ( base$ cell$ [a^] )
    STH2k ;car! JSR2            ( base$ [a^ cell$] )
    POP2 STH2r                  ( cell$ [a^] )
    INCr INCr STHkr             ( cell$ a+2^ [a+2^] )
    STZ2 STHr .stack/pos STZ    ( ; pos<-a+2 )
    JMP2r

@end-list ( -> )
    ;stack/pos LDA2k LDA2 ( pos* elem$ )
    STH2 #0004 SUB2       ( pos-4* [elem$] )


@on-key-start ( -> )
    #12 DEI
    DUP #09 EQU ,&skip JCN ( tab )
    DUP #0a EQU ,&skip JCN ( nl )
    DUP #0d EQU ,&skip JCN ( cr )
    DUP #20 EQU ,&skip JCN ( sp )
    DUP #20 LTH ,&control JCN ( control chars )
    DUP #7e GTH ,&control JCN ( delete + 8bit )
    DUP #28 EQU ,start-list JCN ( lpar )
    DUP #29 EQU ,&rpar JCN ( rpar )
                ,&printable JMP

    &rpar


    &skip POP BRK
    &control POP BRK ( todo )
    &printable

@on-key ( -> )
    .state LDZ #00 EQU ,on-key-start JCN
    .state LDZ #01 EQU ,on-key-symbol JCN
    .state LDZ #02 EQU ,on-key-string JCN
    .state LDZ #03 EQU ,on-key-escape JCN
    .state LDZ #04 EQU ,on-key-comment JCN
    #0000 DIV

(    #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 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
    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 ( -> )
    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 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 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-sym ( 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-sym 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-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* )

@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
@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

@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 ( lst$ -> h$ )
    ;read-object JSR2           ( tag^ ohi$ olo$ )
    POP2 STH2                   ( tag^ [ohi$] )
    ,cdr/shared JMP

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

@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$ -> )
    STH2 ;assert-cons JSR2      ( lst$ [x$] )
    DUP2 ;obj-to-addr JSR2      ( addr* [x$] )
    #0003 ADD2                  ( addr+3 [x$] )
    STH2r SWP2 STA2 JMP2r       ( ; addr+3<-x )

@find ( list$ x$ -> rest$ )
    STH2                        ( list$ [x$] )
    &loop                       ( list$ [x$] )
    ;read-object

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