forth: \, POSTPONE-imm split, >NUMBER, DOES> — Hayes 486→618 (97%)

lib/forth/compiler.sx

@@ -101,6 +101,23 @@
         (s)
         (let ((pc (dict))) (dict-set! pc "v" 0) (forth-run-body s ops pc n))))))
 
+;; After `;` finalizes a body, walk it and attach to each does-rebind op
+;; the slice of ops that follow it — that slice becomes the runtime body
+;; of the just-CREATE'd word when the rebind fires.
+(define
+  forth-fixup-does!
+  (fn
+    (ops i n)
+    (when
+      (< i n)
+      (begin
+        (let
+          ((op (nth ops i)))
+          (when
+            (and (dict? op) (= (get op "kind") "does-rebind"))
+            (dict-set! op "deferred" (drop ops (+ i 1)))))
+        (forth-fixup-does! ops (+ i 1) n)))))
+
 (define
   forth-step-op
   (fn
@@ -124,8 +141,41 @@
         (forth-plusloop-step s op pc))
       ((and (dict? op) (= (get op "kind") "exit"))
         (dict-set! pc "v" 1000000000))
+      ((and (dict? op) (= (get op "kind") "does-rebind"))
+        (forth-do-does-rebind s op pc))
       (else (begin (op s) (dict-set! pc "v" (+ (get pc "v") 1)))))))
 
+(define
+  forth-do-does-rebind
+  (fn
+    (s op pc)
+    (let
+      ((target (get s "last-creator"))
+        (deferred (get op "deferred")))
+      (when
+        (nil? target)
+        (forth-error s "DOES>: no recent CREATE"))
+      (let
+        ((addr (get target "body-addr")))
+        (let
+          ((new-body (forth-make-does-body addr deferred)))
+          (dict-set! target "body" new-body)))
+      (dict-set! pc "v" 1000000000))))
+
+(define
+  forth-make-does-body
+  (fn
+    (addr deferred)
+    (let
+      ((n (len deferred)))
+      (fn
+        (s)
+        (forth-push s addr)
+        (let
+          ((pc2 (dict)))
+          (dict-set! pc2 "v" 0)
+          (forth-run-body s deferred pc2 n))))))
+
 (define
   forth-loop-step
   (fn
@@ -281,15 +331,17 @@
           (when (nil? def) (forth-error s "; outside definition"))
           (let
             ((ops (get def "body")))
-            (let
-              ((body-fn (forth-make-colon-body ops)))
-              (dict-set!
-                (get s "dict")
-                (downcase (get def "name"))
-                (forth-make-word "colon-def" body-fn false))
-              (dict-set! s "last-defined" (get def "name"))
-              (dict-set! s "current-def" nil)
-              (dict-set! s "compiling" false))))))
+            (begin
+              (forth-fixup-does! ops 0 (len ops))
+              (let
+                ((body-fn (forth-make-colon-body ops)))
+                (dict-set!
+                  (get s "dict")
+                  (downcase (get def "name"))
+                  (forth-make-word "colon-def" body-fn false))
+                (dict-set! s "last-defined" (get def "name"))
+                (dict-set! s "current-def" nil)
+                (dict-set! s "compiling" false)))))))
     (forth-def-prim-imm!
       state
       "IMMEDIATE"
@@ -492,7 +544,9 @@
         (s)
         (let
           ((tok (forth-next-token! s)))
-          (when (nil? tok) (forth-error s "CHAR expects a word"))
+          (when
+            (or (nil? tok) (= (len tok) 0))
+            (forth-error s "CHAR expects a word"))
           (forth-push s (char-code (substr tok 0 1))))))
     (forth-def-prim-imm!
       state
@@ -501,7 +555,9 @@
         (s)
         (let
           ((tok (forth-next-token! s)))
-          (when (nil? tok) (forth-error s "[CHAR] expects a word"))
+          (when
+            (or (nil? tok) (= (len tok) 0))
+            (forth-error s "[CHAR] expects a word"))
           (let
             ((c (char-code (substr tok 0 1))))
             (if
@@ -720,7 +776,8 @@
             (forth-def-prim! s name (fn (ss) (forth-push ss addr)))
             (let
               ((w (forth-lookup s name)))
-              (dict-set! w "body-addr" addr))))))
+              (dict-set! w "body-addr" addr)
+              (dict-set! s "last-creator" w))))))
     (forth-def-prim! state "CELL+" (fn (s) (forth-push s (+ (forth-pop s) 1))))
     (forth-def-prim! state "CELLS" (fn (s) nil))
     (forth-def-prim! state "ALIGN" (fn (s) nil))
@@ -778,13 +835,16 @@
           (let
             ((w (forth-lookup s name)))
             (when (nil? w) (forth-error s (str name " ?")))
-            (forth-def-append!
-              s
-              (fn
-                (ss)
-                (forth-def-append!
-                  ss
-                  (fn (sss) (forth-execute-word sss w)))))))))
+            (if
+              (get w "immediate?")
+              (forth-def-append! s (fn (ss) (forth-execute-word ss w)))
+              (forth-def-append!
+                s
+                (fn
+                  (ss)
+                  (forth-def-append!
+                    ss
+                    (fn (sss) (forth-execute-word sss w))))))))))
     (forth-def-prim!
       state
       ">BODY"
@@ -793,6 +853,13 @@
         (let
           ((w (forth-pop s)))
           (forth-push s (or (get w "body-addr") 0)))))
+    ;; `\` would normally consume the rest of the parse line; we have no
+    ;; line concept so we make it a no-op. Conformance.sh already strips
+    ;; standalone `\ ...` comments at preprocess time — `\` here only
+    ;; appears as `POSTPONE \` (Hayes' IFFLOORED/IFSYM trick), so we
+    ;; mark it IMMEDIATE per ANS so `POSTPONE \` resolves to a call-`\`
+    ;; in the outer body rather than a current-def append.
+    (forth-def-prim-imm! state "\\" (fn (s) nil))
     (forth-def-prim-imm!
       state
       "SLITERAL"
@@ -807,6 +874,24 @@
               (forth-mem-write-string! s new-addr content)
               (forth-def-append! s (fn (ss) (forth-push ss new-addr)))
               (forth-def-append! s (fn (ss) (forth-push ss u))))))))
+    (forth-def-prim!
+      state
+      ">NUMBER"
+      (fn
+        (s)
+        (let
+          ((u (forth-pop s))
+            (addr (forth-pop s))
+            (hi (forth-pop s))
+            (lo (forth-pop s)))
+          (let
+            ((d (forth-double-from-cells-u lo hi))
+              (b (get (get s "vars") "base")))
+            (let
+              ((result (forth-numparse-loop s addr u d b)))
+              (forth-double-push-u s (nth result 0))
+              (forth-push s (nth result 1))
+              (forth-push s (nth result 2)))))))
     (forth-def-prim!
       state
       "COMPARE"
@@ -1062,6 +1147,18 @@
           ((op (dict)))
           (dict-set! op "kind" "exit")
           (forth-def-append! s op))))
+    (forth-def-prim-imm!
+      state
+      "DOES>"
+      (fn
+        (s)
+        (when
+          (not (get s "compiling"))
+          (forth-error s "DOES> outside definition"))
+        (let
+          ((op (dict)))
+          (dict-set! op "kind" "does-rebind")
+          (forth-def-append! s op))))
     (forth-def-prim!
       state
       "UNLOOP"

lib/forth/conformance.sh

@@ -27,12 +27,16 @@ cd "$ROOT"
 awk '
 {
   line = $0
+  # protect POSTPONE \ so the comment-strip below leaves the literal \ alone
+  gsub(/POSTPONE[ \t]+\\/, "POSTPONE @@BS@@", line)
   # strip leading/embedded \ line comments (must be \ followed by space or EOL)
   gsub(/(^|[ \t])\\([ \t].*|$)/, " ", line)
   # strip ( ... ) block comments that sit on one line
   gsub(/\([^)]*\)/, " ", line)
   # strip TESTING … metadata lines (rest of line, incl. bare TESTING)
   sub(/TESTING([ \t].*)?$/, " ", line)
+  # restore the protected backslash
+  gsub(/@@BS@@/, "\\", line)
   print line
 }' "$SOURCE" > "$PREPROC"
 

lib/forth/hayes-runner.sx

@@ -11,6 +11,7 @@
 (define hayes-actual-set false)
 (define hayes-failures (list))
 (define hayes-first-error "")
+(define hayes-error-hist (dict))
 
 (define
   hayes-reset!
@@ -23,7 +24,8 @@
     (set! hayes-actual (list))
     (set! hayes-actual-set false)
     (set! hayes-failures (list))
-    (set! hayes-first-error "")))
+    (set! hayes-first-error "")
+    (set! hayes-error-hist (dict))))
 
 (define
   hayes-slice
@@ -97,6 +99,25 @@
 ;; Run a single preprocessed chunk (string of Forth source) on the shared
 ;; state. Catch any raised error and move on — the chunk boundary is a
 ;; safe resume point.
+(define
+  hayes-bump-error-key!
+  (fn
+    (err)
+    (let
+      ((msg (str err)))
+      (let
+        ((space-idx (index-of msg " ")))
+        (let
+          ((key
+            (if
+              (> space-idx 0)
+              (substr msg 0 space-idx)
+              msg)))
+          (dict-set!
+            hayes-error-hist
+            key
+            (+ 1 (or (get hayes-error-hist key) 0))))))))
+
 (define
   hayes-run-chunk
   (fn
@@ -109,6 +130,7 @@
             (when
               (= (len hayes-first-error) 0)
               (set! hayes-first-error (str err)))
+            (hayes-bump-error-key! err)
             (dict-set! state "dstack" (list))
             (dict-set! state "rstack" (list))
             (dict-set! state "compiling" false)
@@ -131,4 +153,6 @@
       "total"
       (+ (+ hayes-pass hayes-fail) hayes-error)
       "first-error"
-      hayes-first-error)))
+      hayes-first-error
+      "error-hist"
+      hayes-error-hist)))

lib/forth/runtime.sx

@@ -421,6 +421,40 @@
       ((forth-match-at state a1 i a2 u2 0) i)
       (else (forth-search-bytes state a1 u1 a2 u2 (+ i 1))))))
 
+(define
+  forth-digit-of-byte
+  (fn
+    (c base)
+    (let
+      ((v
+        (cond
+          ((and (>= c 48) (<= c 57)) (- c 48))
+          ((and (>= c 65) (<= c 90)) (- c 55))
+          ((and (>= c 97) (<= c 122)) (- c 87))
+          (else -1))))
+      (if (or (< v 0) (>= v base)) -1 v))))
+
+(define
+  forth-numparse-loop
+  (fn
+    (state addr u acc base)
+    (if
+      (= u 0)
+      (list acc addr u)
+      (let
+        ((c (forth-mem-read state addr)))
+        (let
+          ((dig (forth-digit-of-byte c base)))
+          (if
+            (< dig 0)
+            (list acc addr u)
+            (forth-numparse-loop
+              state
+              (+ addr 1)
+              (- u 1)
+              (+ (* acc base) dig)
+              base)))))))
+
 (define
   forth-pic-S-loop
   (fn

lib/forth/scoreboard.json

@@ -1,12 +1,12 @@
 {
   "source": "gerryjackson/forth2012-test-suite src/core.fr",
-  "generated_at": "2026-04-25T02:53:26Z",
+  "generated_at": "2026-04-25T03:32:23Z",
   "chunks_available": 638,
   "chunks_fed": 638,
   "total": 638,
-  "pass": 486,
+  "pass": 618,
   "fail": 14,
-  "error": 138,
-  "percent": 76,
+  "error": 6,
+  "percent": 96,
   "note": "completed"
 }

lib/forth/scoreboard.md

@@ -5,13 +5,13 @@
 | chunks available  | 638 |
 | chunks fed        | 638 |
 | total             | 638 |
-| pass              | 486 |
+| pass              | 618 |
 | fail              | 14 |
-| error             | 138 |
-| percent           | 76% |
+| error             | 6 |
+| percent           | 96% |
 
 - **Source**: `gerryjackson/forth2012-test-suite` `src/core.fr`
-- **Generated**: 2026-04-25T02:53:26Z
+- **Generated**: 2026-04-25T03:32:23Z
 - **Note**: completed
 
 A "chunk" is any preprocessed segment ending at a `}T` (every Hayes test