forth: Phase 4 strings — S"/C"/."/TYPE/COUNT/CMOVE/FILL/BLANK (+16; Hayes 168/590)

lib/forth/compiler.sx

@@ -139,6 +139,50 @@
                 (forth-rpush s next)
                 (dict-set! pc "v" (get (get op "target") "v"))))))))))
 
+;; Parse input tokens until one ends in `"`. Returns joined content with
+;; single spaces between tokens (emulating standard Forth S"-style parse).
+(define
+  forth-parse-quote
+  (fn
+    (state)
+    (forth-parse-quote-loop state (list))))
+
+(define
+  forth-parse-quote-loop
+  (fn
+    (state parts)
+    (let
+      ((tok (forth-next-token! state)))
+      (if
+        (nil? tok)
+        (forth-error state "unterminated string")
+        (let
+          ((n (len tok)))
+          (if
+            (and (> n 0) (= (substr tok (- n 1) 1) "\""))
+            (let
+              ((final (substr tok 0 (- n 1))))
+              (forth-join-parts (concat parts (list final)) " "))
+            (forth-parse-quote-loop state (concat parts (list tok)))))))))
+
+(define
+  forth-join-parts
+  (fn
+    (parts sep)
+    (if
+      (= (len parts) 0)
+      ""
+      (forth-join-loop (rest parts) sep (first parts)))))
+
+(define
+  forth-join-loop
+  (fn
+    (xs sep acc)
+    (if
+      (= (len xs) 0)
+      acc
+      (forth-join-loop (rest-of xs) sep (str acc sep (first xs))))))
+
 (define
   forth-find-do
   (fn
@@ -413,6 +457,51 @@
             (for-each
               (fn (t) (dict-set! t "v" exit-pc))
               (get marker "leaves"))))))
+    (forth-def-prim-imm!
+      state
+      "S\""
+      (fn
+        (s)
+        (let
+          ((content (forth-parse-quote s)))
+          (if
+            (get s "compiling")
+            (let
+              ((addr (forth-alloc-bytes! s (len content))))
+              (forth-mem-write-string! s addr content)
+              (forth-def-append! s (fn (ss) (forth-push ss addr)))
+              (forth-def-append! s (fn (ss) (forth-push ss (len content)))))
+            (let
+              ((addr (forth-alloc-bytes! s (len content))))
+              (forth-mem-write-string! s addr content)
+              (forth-push s addr)
+              (forth-push s (len content)))))))
+    (forth-def-prim-imm!
+      state
+      "C\""
+      (fn
+        (s)
+        (let
+          ((content (forth-parse-quote s)))
+          (let
+            ((addr (forth-alloc-bytes! s (+ 1 (len content)))))
+            (forth-mem-write! s addr (len content))
+            (forth-mem-write-string! s (+ addr 1) content)
+            (if
+              (get s "compiling")
+              (forth-def-append! s (fn (ss) (forth-push ss addr)))
+              (forth-push s addr))))))
+    (forth-def-prim-imm!
+      state
+      ".\""
+      (fn
+        (s)
+        (let
+          ((content (forth-parse-quote s)))
+          (if
+            (get s "compiling")
+            (forth-def-append! s (fn (ss) (forth-emit-str ss content)))
+            (forth-emit-str s content)))))
     (forth-def-prim-imm!
       state
       "LEAVE"