forth: pictured numeric output <#/#/#S/#>/HOLD/SIGN + U./U.R/.R (Hayes 448/638, 70%)

lib/forth/runtime.sx

@@ -23,6 +23,7 @@
       (dict-set! s "cstack" (list))
       (dict-set! s "mem" (dict))
       (dict-set! s "here" 0)
+      (dict-set! s "hold" (list))
       s)))
 
 (define
@@ -311,6 +312,85 @@
       (forth-push state (forth-from-unsigned lo 32))
       (forth-push state (forth-from-unsigned hi 32)))))
 
+(define
+  forth-num-to-string-loop
+  (fn
+    (u base acc)
+    (if
+      (= u 0)
+      acc
+      (let
+        ((dig (mod u base)) (rest (floor (/ u base))))
+        (let
+          ((ch
+            (if
+              (< dig 10)
+              (char-from-code (+ 48 dig))
+              (char-from-code (+ 55 dig)))))
+          (forth-num-to-string-loop rest base (str ch acc)))))))
+
+(define
+  forth-num-to-string
+  (fn
+    (u base)
+    (if (= u 0) "0" (forth-num-to-string-loop u base ""))))
+
+(define
+  forth-spaces-str
+  (fn
+    (n)
+    (if (<= n 0) "" (str " " (forth-spaces-str (- n 1))))))
+
+(define
+  forth-join-hold
+  (fn
+    (parts)
+    (forth-join-hold-loop parts "")))
+
+(define
+  forth-join-hold-loop
+  (fn
+    (parts acc)
+    (if
+      (= (len parts) 0)
+      acc
+      (forth-join-hold-loop (rest parts) (str acc (first parts))))))
+
+(define
+  forth-pic-step
+  (fn
+    (state)
+    (let
+      ((hi (forth-pop state)) (lo (forth-pop state)))
+      (let
+        ((d (forth-double-from-cells-u lo hi))
+          (b (get (get state "vars") "base")))
+        (let
+          ((dig (mod d b)) (rest (floor (/ d b))))
+          (let
+            ((ch
+              (if
+                (< dig 10)
+                (char-from-code (+ 48 dig))
+                (char-from-code (+ 55 dig)))))
+            (dict-set! state "hold" (cons ch (get state "hold")))
+            (forth-double-push-u state rest)))))))
+
+(define
+  forth-pic-S-loop
+  (fn
+    (state)
+    (forth-pic-step state)
+    (let
+      ((hi (forth-pop state)) (lo (forth-pop state)))
+      (if
+        (and (= lo 0) (= hi 0))
+        (begin (forth-push state 0) (forth-push state 0))
+        (begin
+          (forth-push state lo)
+          (forth-push state hi)
+          (forth-pic-S-loop state))))))
+
 (define
   forth-double-push-s
   (fn
@@ -999,4 +1079,109 @@
             ((d1 (forth-double-from-cells-s lo1 hi1))
               (d2 (forth-double-from-cells-s lo2 hi2)))
             (forth-double-push-s s (if (< d1 d2) d1 d2))))))
+    (forth-def-prim! state "<#" (fn (s) (dict-set! s "hold" (list))))
+    (forth-def-prim!
+      state
+      "HOLD"
+      (fn
+        (s)
+        (let
+          ((c (forth-pop s)))
+          (dict-set!
+            s
+            "hold"
+            (cons (char-from-code c) (get s "hold"))))))
+    (forth-def-prim!
+      state
+      "SIGN"
+      (fn
+        (s)
+        (let
+          ((n (forth-pop s)))
+          (when
+            (< n 0)
+            (dict-set! s "hold" (cons "-" (get s "hold")))))))
+    (forth-def-prim!
+      state
+      "#"
+      (fn
+        (s)
+        (let
+          ((hi (forth-pop s)) (lo (forth-pop s)))
+          (let
+            ((d (forth-double-from-cells-u lo hi))
+              (b (get (get s "vars") "base")))
+            (let
+              ((dig (mod d b)) (rest (floor (/ d b))))
+              (let
+                ((ch
+                  (if
+                    (< dig 10)
+                    (char-from-code (+ 48 dig))
+                    (char-from-code (+ 55 dig)))))
+                (dict-set! s "hold" (cons ch (get s "hold")))
+                (forth-double-push-u s rest)))))))
+    (forth-def-prim!
+      state
+      "#S"
+      (fn
+        (s)
+        (forth-pic-S-loop s)))
+    (forth-def-prim!
+      state
+      "#>"
+      (fn
+        (s)
+        (forth-pop s)
+        (forth-pop s)
+        (let
+          ((str-out (forth-join-hold (get s "hold"))))
+          (let
+            ((addr (forth-alloc-bytes! s (len str-out))))
+            (forth-mem-write-string! s addr str-out)
+            (forth-push s addr)
+            (forth-push s (len str-out))))))
+    (forth-def-prim!
+      state
+      "U."
+      (fn
+        (s)
+        (let
+          ((u (forth-to-unsigned (forth-pop s) 32))
+            (b (get (get s "vars") "base")))
+          (forth-emit-str s (str (forth-num-to-string u b) " ")))))
+    (forth-def-prim!
+      state
+      "U.R"
+      (fn
+        (s)
+        (let
+          ((width (forth-pop s))
+            (u (forth-to-unsigned (forth-pop s) 32))
+            (b (get (get s "vars") "base")))
+          (let
+            ((digits (forth-num-to-string u b)))
+            (forth-emit-str
+              s
+              (forth-spaces-str (- width (len digits))))
+            (forth-emit-str s digits)))))
+    (forth-def-prim!
+      state
+      ".R"
+      (fn
+        (s)
+        (let
+          ((width (forth-pop s))
+            (n (forth-pop s))
+            (b (get (get s "vars") "base")))
+          (let
+            ((sign-prefix (if (< n 0) "-" ""))
+              (abs-digits
+                (forth-num-to-string (forth-to-unsigned (abs n) 32) b)))
+            (let
+              ((digits (str sign-prefix abs-digits)))
+              (forth-emit-str
+                s
+                (forth-spaces-str (- width (len digits))))
+              (forth-emit-str s digits))))))
     state))