progress

hoax.tal

@@ -114,12 +114,43 @@
 (    DEBUG EXIT )
     BRK
 
-@symbol-from-buf ( -> sym$ )
-    ( strategy: )
-    ( 1. read in groups of two )
-    ( 2. build recursively, save root )
-    ( 3. when done "fixup" the root )
-    ( 4. return fixed root )
+@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$ )
+
+@sym-from-buf ( -> sym$ )
+    ;buffer/input ;sym-from-buf-src JMP2
+
+( TODO: fix bug with len > 4 )
+@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 LDA ( child$ )
+        ;convert-sym-to-str JMP2 ( )
+    &done                        ( [addr*] )
+        POP2r JMP2r              ( )
 
 @buf-end ( -> )
     #00 ;buffer/pos LDA2 STA       ( ; addr<-00 )
@@ -146,11 +177,12 @@
     ;buf-add JSR2 BRK
 
 @end-string ( c -> )
-    ;on-key-ready #10 DEO2
-    ;echo JSR2 "string 20 00
-    ;buf-end JSR2
-    ;buffer/input ;print JSR2 NL
-    POP BRK
+    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
@@ -160,11 +192,13 @@
     ;buf-add JSR2 BRK
 
 @end-word0 ( c -> )
-    ;on-key-ready #10 DEO2
-    ;echo JSR2 "word 20 00
-    ;buf-end JSR2
-    ;buffer/input ;print JSR2 NL
-    POP JMP2r
+    POP ;on-key-ready #10 DEO2  ( )
+    ;echo JSR2 "word 20 00      ( )
+    ;sym-from-buf JSR2          ( obj$ )
+    ;display JSR2               ( )
+    ;buf-end JSR2 JMP2r         ( )
+(    ;buffer/input ;print JSR2 NL
+    POP JMP2r )
 
 @start-escape ( c -> )
     ;on-key-escaped #10 DEO2 POP BRK
@@ -239,6 +273,8 @@
     #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
@@ -342,11 +378,13 @@
 
 ( shared by strings/symbols )
 @display0-sym ( addr* -> )
-    LDAk #0f AND DUP #05 LTH ,&short JCN
+    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
+    &short                      ( addr* sz^ )
         #00 SWP SUB STH INC2    ( addr+1 [-len] )
     &loop                       ( pos [-i] )
         LDAk ,display0-char JSR ( pos [-i] )