very very wip

hoax.tal

@@ -105,22 +105,89 @@
 |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
-    ;on-char #10 DEO2
+    #00 .state STZ
+    ;on-key #10 DEO2
+    ;reset-input JSR2
     ;demo JSR2
 (    DEBUG EXIT )
     BRK
 
-@on-char ( -> )
+@reset-input ( -> )
-    #12 DEI #0a EQU ,&newline JCN
+    #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
+        BRK )
 
 @demo
     null ;null? JSR2 D
@@ -175,14 +242,12 @@
         EXIT
     &ok
         ( allocate 8192 5-byte object slots )
-        #2000 #0005 ;init-arena JSR2 ;objects STA2
+        #2000 #0005 ;init-arena JSR2 .objects STZ2
 
         ( set up buffers )
         ;buffer/input ;buffer/pos STA2
     JMP2r
 
-@buffer [ &pos $2 &input $80 ]
-
 @error ( -> )
     #0000 DIV ( TODO )
 
@@ -296,19 +361,19 @@
     &small #8000 ORA2 JMP2r
 
 @addr-to-obj ( addr* -> obj$ )
-    ;objects SUB2 #0005 DIV2 JMP2r
+    .objects LDZ2 SUB2 #0005 DIV2 JMP2r
 
 @obj-to-addr ( obj$ -> addr* )
-    #0005 MUL2 ;objects ADD2 JMP2r
+    #0005 MUL2 .objects LDZ2 ADD2 JMP2r
 
 @make ( tag^ -> addr* )
-    ;objects LDA2               ( tag^ arena* )
+    .objects LDZ2               ( tag^ arena* )
     ;alloc JSR2                 ( tag^ addr* )
     STH2k STA                   ( [addr*] )
     STH2r JMP2r                 ( addr* )
 
 @make-obj ( tag^ ohi$ olo$ -> object$ )
-    ;objects LDA2               ( tag^ ohi$ olo$ arena* )
+    .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 )
@@ -371,30 +436,22 @@
     &error                      ( [ptr$] )
         POP2r ;error JMP2       ( )
 
-@last ( lst$ -> lst1$ )
+@car! ( pair$ x$ -> pair$ )
-    DUP2 ;cdr JSR2              ( lst$ cdr$ )
+    STH2 ;assert-cons JSR2      ( pair$ [x$] )
-    ORAk ,&non-empty JCN        ( lst$ cdr$ )
+    DUP2 ;obj-to-addr JSR2      ( pair$ addr* [x$] )
-        POP2 JMP2r              ( lst$ )
+    INC2                        ( pair$ addr+1 [x$] )
-    &non-empty                  ( lst$ cdr$ )
+    STH2r SWP2 STA2 JMP2r       ( pair$ ; addr+1<-x )
-        NIP2 ;last JMP2         ( res$ )
 
-@car! ( lst$ x$ -> )
+@cdr! ( pair$ x$ -> )
     STH2 ;assert-cons JSR2      ( lst$ [x$] )
-    ;obj-to-addr JSR2           ( addr* [x$] )
+    DUP2 ;obj-to-addr JSR2      ( addr* [x$] )
-    INC2                        ( addr+1 [x$] )
-    STH2r SWP2 STA2             ( ; addr+3<-x )
-
-@cdr! ( lst$ x$ -> )
-    STH2 ;assert-cons JSR2      ( lst$ [x$] )
-    ;obj-to-addr JSR2           ( addr* [x$] )
     #0003 ADD2                  ( addr+3 [x$] )
-    STH2r SWP2 STA2             ( ; addr+3<-x )
+    STH2r SWP2 STA2 JMP2r       ( ; addr+3<-x )
 
-@append! ( lst$ x$ -> )
+@find ( list$ x$ -> rest$ )
-    #0000 ;cons JSR2 ;extend! JMP2
+    STH2                        ( list$ [x$] )
-
+    &loop                       ( list$ [x$] )
-@extend! ( lst$ tail$ -> )
+    ;read-object
-    SWP2 ;last JSR2 SWP2 ;cdr! JMP2
 
 |1004 ( ;arenas needs to be a multiple of 5 )
 ~alloc.tal