From 1ad8e74aa651590e22ac94f109bb25e86c503ce1 Mon Sep 17 00:00:00 2001
From: giles <giles.bradshaw@rose-ash.com>
Date: Fri, 1 May 2026 21:00:22 +0000
Subject: [PATCH] cl-runtime: add lib/common-lisp/runtime.sx + test.sh (68/68
 pass)
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

Type predicates, arithmetic, chars (inline α/digit/case),
format, gensym, values, sets, radix, list utilities.
cl-empty? guards all list traversal against () vs nil in sx_server.
Load spec/stdlib.sx in test.sh to expose format.
Fix lib/r7rs.sx number->string to use (= (len r) 0) not (nil? r).

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
---
 lib/common-lisp/runtime.sx | 306 +++++++++++++++++++++++++++++++++++++
 lib/common-lisp/test.sh    | 302 ++++++++++++++++++++++++++++++++++++
 lib/r7rs.sx                |   2 +-
 3 files changed, 609 insertions(+), 1 deletion(-)
 create mode 100644 lib/common-lisp/runtime.sx
 create mode 100755 lib/common-lisp/test.sh

diff --git a/lib/common-lisp/runtime.sx b/lib/common-lisp/runtime.sx
new file mode 100644
index 00000000..dccbdb09
--- /dev/null
+++ b/lib/common-lisp/runtime.sx
@@ -0,0 +1,306 @@
+;; lib/common-lisp/runtime.sx — CL built-ins using SX spec primitives
+;;
+;; Provides CL-specific wrappers and helpers. Deliberately thin: wherever
+;; an SX spec primitive already does the job, we alias it rather than
+;; reinventing it.
+;;
+;; Primitives used from spec:
+;;   char/char->integer/integer->char/char-upcase/char-downcase
+;;   format   (Phase 21 — must be loaded before this file)
+;;   gensym   (Phase 12)
+;;   rational/rational?  (Phase 16)
+;;   make-set/set-member?/set-union/etc  (Phase 18)
+;;   open-input-string/read-char/etc  (Phase 14)
+;;   modulo/remainder/quotient/gcd/lcm/expt  (Phase 2 / Phase 15)
+;;   number->string with radix  (Phase 15)
+
+;; ---------------------------------------------------------------------------
+;; 1.  Type predicates
+;; ---------------------------------------------------------------------------
+
+(define (cl-null? x) (= x nil))
+(define (cl-consp? x) (and (list? x) (not (cl-empty? x))))
+(define (cl-listp? x) (or (cl-empty? x) (list? x)))
+(define (cl-atom? x) (not (cl-consp? x)))
+
+(define
+  (cl-numberp? x)
+  (let ((t (type-of x))) (or (= t "number") (= t "rational"))))
+
+(define cl-integerp? integer?)
+(define cl-floatp? float?)
+(define cl-rationalp? rational?)
+
+(define (cl-realp? x) (or (integer? x) (float? x) (rational? x)))
+
+(define cl-characterp? char?)
+(define cl-stringp? (fn (x) (= (type-of x) "string")))
+(define cl-symbolp? (fn (x) (= (type-of x) "symbol")))
+(define cl-keywordp? (fn (x) (= (type-of x) "keyword")))
+
+(define
+  (cl-functionp? x)
+  (let
+    ((t (type-of x)))
+    (or
+      (= t "function")
+      (= t "lambda")
+      (= t "native-fn")
+      (= t "component"))))
+
+(define cl-vectorp? vector?)
+(define cl-arrayp? vector?)
+
+;; sx_server: (rest (list x)) returns () not nil — cl-empty? handles both
+(define
+  (cl-empty? x)
+  (or (nil? x) (and (list? x) (= (len x) 0))))
+
+;; ---------------------------------------------------------------------------
+;; 2.  Arithmetic — thin aliases to spec primitives
+;; ---------------------------------------------------------------------------
+
+(define cl-mod modulo)
+(define cl-rem remainder)
+(define cl-gcd gcd)
+(define cl-lcm lcm)
+(define cl-expt expt)
+(define cl-floor floor)
+(define cl-ceiling ceil)
+(define cl-truncate truncate)
+(define cl-round round)
+(define cl-abs (fn (x) (if (< x 0) (- 0 x) x)))
+(define cl-min (fn (a b) (if (< a b) a b)))
+(define cl-max (fn (a b) (if (> a b) a b)))
+(define cl-quotient quotient)
+
+(define
+  (cl-signum x)
+  (cond
+    ((> x 0) 1)
+    ((< x 0) -1)
+    (else 0)))
+
+(define (cl-evenp? n) (= (modulo n 2) 0))
+(define (cl-oddp? n) (= (modulo n 2) 1))
+(define (cl-zerop? n) (= n 0))
+(define (cl-plusp? n) (> n 0))
+(define (cl-minusp? n) (< n 0))
+
+;; ---------------------------------------------------------------------------
+;; 3.  Character functions — alias spec char primitives + CL name mapping
+;; ---------------------------------------------------------------------------
+
+(define cl-char->integer char->integer)
+(define cl-integer->char integer->char)
+(define cl-char-upcase char-upcase)
+(define cl-char-downcase char-downcase)
+(define cl-char-code char->integer)
+(define cl-code-char integer->char)
+
+(define cl-char=? char=?)
+(define cl-char<? char<?)
+(define cl-char>? char>?)
+(define cl-char<=? char<=?)
+(define cl-char>=? char>=?)
+(define cl-char-ci=? char-ci=?)
+(define cl-char-ci<? char-ci<?)
+(define cl-char-ci>? char-ci>?)
+
+;; Inline predicates — char-alphabetic?/char-numeric? unreliable in sx_server
+(define
+  (cl-alpha-char-p c)
+  (let
+    ((n (char->integer c)))
+    (or
+      (and (>= n 65) (<= n 90))
+      (and (>= n 97) (<= n 122)))))
+
+(define
+  (cl-digit-char-p c)
+  (let ((n (char->integer c))) (and (>= n 48) (<= n 57))))
+
+(define
+  (cl-alphanumericp c)
+  (let
+    ((n (char->integer c)))
+    (or
+      (and (>= n 48) (<= n 57))
+      (and (>= n 65) (<= n 90))
+      (and (>= n 97) (<= n 122)))))
+
+(define
+  (cl-upper-case-p c)
+  (let ((n (char->integer c))) (and (>= n 65) (<= n 90))))
+
+(define
+  (cl-lower-case-p c)
+  (let ((n (char->integer c))) (and (>= n 97) (<= n 122))))
+
+;; Named character constants
+(define cl-char-space (integer->char 32))
+(define cl-char-newline (integer->char 10))
+(define cl-char-tab (integer->char 9))
+(define cl-char-backspace (integer->char 8))
+(define cl-char-return (integer->char 13))
+(define cl-char-null (integer->char 0))
+(define cl-char-escape (integer->char 27))
+(define cl-char-delete (integer->char 127))
+
+;; ---------------------------------------------------------------------------
+;; 4.  String + IO — use spec format and ports
+;; ---------------------------------------------------------------------------
+
+;; CL format: (cl-format nil "~a ~a" x y) — nil destination means return string
+(define
+  (cl-format dest template &rest args)
+  (let ((s (apply format (cons template args)))) (if (= dest nil) s s)))
+
+(define cl-write-to-string write-to-string)
+(define cl-princ-to-string display-to-string)
+
+;; CL read-from-string: parse value from a string using SX port
+(define
+  (cl-read-from-string s)
+  (let ((p (open-input-string s))) (read p)))
+
+;; String stream (output)
+(define cl-make-string-output-stream open-output-string)
+(define cl-get-output-stream-string get-output-string)
+
+;; String stream (input)
+(define cl-make-string-input-stream open-input-string)
+
+;; ---------------------------------------------------------------------------
+;; 5.  Gensym
+;; ---------------------------------------------------------------------------
+
+(define cl-gensym gensym)
+(define cl-gentemp gensym)
+
+;; ---------------------------------------------------------------------------
+;; 6.  Multiple values (CL: values / nth-value)
+;; ---------------------------------------------------------------------------
+
+(define (cl-values &rest args) {:_values true :_list args})
+
+(define
+  (cl-call-with-values producer consumer)
+  (let
+    ((mv (producer)))
+    (if
+      (and (dict? mv) (get mv :_values))
+      (apply consumer (get mv :_list))
+      (consumer mv))))
+
+(define
+  (cl-nth-value n mv)
+  (cond
+    ((and (dict? mv) (get mv :_values))
+      (let
+        ((lst (get mv :_list)))
+        (if (>= n (len lst)) nil (nth lst n))))
+    ((= n 0) mv)
+    (else nil)))
+
+;; ---------------------------------------------------------------------------
+;; 7.  Sets (CL: adjoin / member / union / intersection / set-difference)
+;; ---------------------------------------------------------------------------
+
+(define cl-make-set make-set)
+(define cl-set? set?)
+(define cl-set-add set-add!)
+(define cl-set-memberp set-member?)
+(define cl-set-remove set-remove!)
+(define cl-set-union set-union)
+(define cl-set-intersect set-intersection)
+(define cl-set-difference set-difference)
+(define cl-list->set list->set)
+(define cl-set->list set->list)
+
+;; CL: (member item list) — returns tail starting at item, or nil
+(define
+  (cl-member item lst)
+  (cond
+    ((cl-empty? lst) nil)
+    ((equal? item (first lst)) lst)
+    (else (cl-member item (rest lst)))))
+
+;; CL: (adjoin item list) — cons only if not already present
+(define (cl-adjoin item lst) (if (cl-member item lst) lst (cons item lst)))
+
+;; ---------------------------------------------------------------------------
+;; 8.  Radix formatting  (CL: (write-to-string n :base radix))
+;; ---------------------------------------------------------------------------
+
+(define (cl-integer-to-string n radix) (number->string n radix))
+
+(define (cl-string-to-integer s radix) (string->number s radix))
+
+;; CL ~R directive helpers
+(define (cl-format-binary n) (number->string n 2))
+(define (cl-format-octal n) (number->string n 8))
+(define (cl-format-hex n) (number->string n 16))
+(define (cl-format-decimal n) (number->string n 10))
+
+;; ---------------------------------------------------------------------------
+;; 9.  List utilities — cl-empty? guards against () from rest
+;; ---------------------------------------------------------------------------
+
+(define
+  (cl-last lst)
+  (cond
+    ((cl-empty? lst) nil)
+    ((cl-empty? (rest lst)) lst)
+    (else (cl-last (rest lst)))))
+
+(define
+  (cl-butlast lst)
+  (if
+    (or (cl-empty? lst) (cl-empty? (rest lst)))
+    nil
+    (cons (first lst) (cl-butlast (rest lst)))))
+
+(define
+  (cl-nthcdr n lst)
+  (if (= n 0) lst (cl-nthcdr (- n 1) (rest lst))))
+
+(define (cl-nth n lst) (first (cl-nthcdr n lst)))
+
+(define (cl-list-length lst) (len lst))
+
+(define
+  (cl-copy-list lst)
+  (if (cl-empty? lst) nil (cons (first lst) (cl-copy-list (rest lst)))))
+
+(define
+  (cl-flatten lst)
+  (cond
+    ((cl-empty? lst) nil)
+    ((list? (first lst))
+      (append (cl-flatten (first lst)) (cl-flatten (rest lst))))
+    (else (cons (first lst) (cl-flatten (rest lst))))))
+
+;; CL: (assoc key alist) — returns matching pair or nil
+(define
+  (cl-assoc key alist)
+  (cond
+    ((cl-empty? alist) nil)
+    ((equal? key (first (first alist))) (first alist))
+    (else (cl-assoc key (rest alist)))))
+
+;; CL: (rassoc val alist) — reverse assoc (match on second element)
+(define
+  (cl-rassoc val alist)
+  (cond
+    ((cl-empty? alist) nil)
+    ((equal? val (first (rest (first alist)))) (first alist))
+    (else (cl-rassoc val (rest alist)))))
+
+;; CL: (getf plist key) — property list lookup
+(define
+  (cl-getf plist key)
+  (cond
+    ((or (cl-empty? plist) (cl-empty? (rest plist))) nil)
+    ((equal? (first plist) key) (first (rest plist)))
+    (else (cl-getf (rest (rest plist)) key))))
diff --git a/lib/common-lisp/test.sh b/lib/common-lisp/test.sh
new file mode 100755
index 00000000..4a7fe07c
--- /dev/null
+++ b/lib/common-lisp/test.sh
@@ -0,0 +1,302 @@
+#!/usr/bin/env bash
+# lib/common-lisp/test.sh — quick smoke-test the CL runtime layer.
+# Uses sx_server.exe epoch protocol (same as lib/lua/test.sh).
+#
+# Usage:
+#   bash lib/common-lisp/test.sh
+#   bash lib/common-lisp/test.sh -v
+
+set -uo pipefail
+cd "$(git rev-parse --show-toplevel)"
+
+SX_SERVER="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}"
+if [ ! -x "$SX_SERVER" ]; then
+  SX_SERVER="/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe"
+fi
+if [ ! -x "$SX_SERVER" ]; then
+  echo "ERROR: sx_server.exe not found. Run: cd hosts/ocaml && dune build"
+  exit 1
+fi
+
+VERBOSE="${1:-}"
+PASS=0; FAIL=0; ERRORS=""
+TMPFILE=$(mktemp); trap "rm -f $TMPFILE" EXIT
+
+cat > "$TMPFILE" << 'EPOCHS'
+(epoch 1)
+(load "spec/stdlib.sx")
+(load "lib/common-lisp/runtime.sx")
+
+;; --- Type predicates ---
+(epoch 10)
+(eval "(cl-null? nil)")
+(epoch 11)
+(eval "(cl-null? false)")
+(epoch 12)
+(eval "(cl-consp? (list 1 2))")
+(epoch 13)
+(eval "(cl-consp? nil)")
+(epoch 14)
+(eval "(cl-listp? nil)")
+(epoch 15)
+(eval "(cl-listp? (list 1))")
+(epoch 16)
+(eval "(cl-atom? nil)")
+(epoch 17)
+(eval "(cl-atom? (list 1))")
+(epoch 18)
+(eval "(cl-integerp? 42)")
+(epoch 19)
+(eval "(cl-floatp? 3.14)")
+(epoch 20)
+(eval "(cl-characterp? (integer->char 65))")
+(epoch 21)
+(eval "(cl-stringp? \"hello\")")
+
+;; --- Arithmetic ---
+(epoch 30)
+(eval "(cl-mod 10 3)")
+(epoch 31)
+(eval "(cl-rem 10 3)")
+(epoch 32)
+(eval "(cl-quotient 10 3)")
+(epoch 33)
+(eval "(cl-gcd 12 8)")
+(epoch 34)
+(eval "(cl-lcm 4 6)")
+(epoch 35)
+(eval "(cl-abs -5)")
+(epoch 36)
+(eval "(cl-abs 5)")
+(epoch 37)
+(eval "(cl-min 2 7)")
+(epoch 38)
+(eval "(cl-max 2 7)")
+(epoch 39)
+(eval "(cl-evenp? 4)")
+(epoch 40)
+(eval "(cl-evenp? 3)")
+(epoch 41)
+(eval "(cl-oddp? 7)")
+(epoch 42)
+(eval "(cl-zerop? 0)")
+(epoch 43)
+(eval "(cl-plusp? 1)")
+(epoch 44)
+(eval "(cl-minusp? -1)")
+(epoch 45)
+(eval "(cl-signum 42)")
+(epoch 46)
+(eval "(cl-signum -7)")
+(epoch 47)
+(eval "(cl-signum 0)")
+
+;; --- Characters ---
+(epoch 50)
+(eval "(cl-char-code (integer->char 65))")
+(epoch 51)
+(eval "(char? (cl-code-char 65))")
+(epoch 52)
+(eval "(cl-char=? (integer->char 65) (integer->char 65))")
+(epoch 53)
+(eval "(cl-char<? (integer->char 65) (integer->char 90))")
+(epoch 54)
+(eval "(cl-char-code cl-char-space)")
+(epoch 55)
+(eval "(cl-char-code cl-char-newline)")
+(epoch 56)
+(eval "(cl-alpha-char-p (integer->char 65))")
+(epoch 57)
+(eval "(cl-digit-char-p (integer->char 48))")
+
+;; --- Format ---
+(epoch 60)
+(eval "(cl-format nil \"hello\")")
+(epoch 61)
+(eval "(cl-format nil \"~a\" \"world\")")
+(epoch 62)
+(eval "(cl-format nil \"~d\" 42)")
+(epoch 63)
+(eval "(cl-format nil \"~x\" 255)")
+(epoch 64)
+(eval "(cl-format nil \"x=~d y=~d\" 3 4)")
+
+;; --- Gensym ---
+(epoch 70)
+(eval "(= (type-of (cl-gensym)) \"symbol\")")
+(epoch 71)
+(eval "(not (= (cl-gensym) (cl-gensym)))")
+
+;; --- Sets ---
+(epoch 80)
+(eval "(cl-set? (cl-make-set))")
+(epoch 81)
+(eval "(let ((s (cl-make-set))) (do (cl-set-add s 1) (cl-set-memberp s 1)))")
+(epoch 82)
+(eval "(cl-set-memberp (cl-make-set) 42)")
+(epoch 83)
+(eval "(cl-set-memberp (cl-list->set (list 1 2 3)) 2)")
+
+;; --- Lists ---
+(epoch 90)
+(eval "(cl-nth 0 (list 1 2 3))")
+(epoch 91)
+(eval "(cl-nth 2 (list 1 2 3))")
+(epoch 92)
+(eval "(cl-last (list 1 2 3))")
+(epoch 93)
+(eval "(cl-butlast (list 1 2 3))")
+(epoch 94)
+(eval "(cl-nthcdr 1 (list 1 2 3))")
+(epoch 95)
+(eval "(cl-assoc \"b\" (list (list \"a\" 1) (list \"b\" 2)))")
+(epoch 96)
+(eval "(cl-assoc \"z\" (list (list \"a\" 1)))")
+(epoch 97)
+(eval "(cl-getf (list \"x\" 42 \"y\" 99) \"x\")")
+(epoch 98)
+(eval "(cl-adjoin 0 (list 1 2))")
+(epoch 99)
+(eval "(cl-adjoin 1 (list 1 2))")
+(epoch 100)
+(eval "(cl-member 2 (list 1 2 3))")
+(epoch 101)
+(eval "(cl-member 9 (list 1 2 3))")
+(epoch 102)
+(eval "(cl-flatten (list 1 (list 2 3) 4))")
+
+;; --- Radix ---
+(epoch 110)
+(eval "(cl-format-binary 10)")
+(epoch 111)
+(eval "(cl-format-octal 15)")
+(epoch 112)
+(eval "(cl-format-hex 255)")
+(epoch 113)
+(eval "(cl-format-decimal 42)")
+(epoch 114)
+(eval "(cl-integer-to-string 31 16)")
+(epoch 115)
+(eval "(cl-string-to-integer \"1f\" 16)")
+
+EPOCHS
+
+OUTPUT=$(timeout 30 "$SX_SERVER" < "$TMPFILE" 2>/dev/null)
+
+check() {
+  local epoch="$1" desc="$2" expected="$3"
+  local actual
+  # ok-len format: value appears on the line AFTER "(ok-len N length)"
+  actual=$(echo "$OUTPUT" | grep -A1 "^(ok-len $epoch " | tail -1 || true)
+  # strip any leading "(ok-len ...)" if grep -A1 returned it instead
+  if echo "$actual" | grep -q "^(ok-len"; then actual=""; fi
+  if [ -z "$actual" ]; then
+    actual=$(echo "$OUTPUT" | grep "^(ok $epoch " | head -1 || true)
+  fi
+  if [ -z "$actual" ]; then
+    actual=$(echo "$OUTPUT" | grep "^(error $epoch " | head -1 || true)
+  fi
+  [ -z "$actual" ] && actual="<no output for epoch $epoch>"
+
+  if echo "$actual" | grep -qF -- "$expected"; then
+    PASS=$((PASS+1))
+    [ "$VERBOSE" = "-v" ] && echo "  ok $desc"
+  else
+    FAIL=$((FAIL+1))
+    ERRORS+="  FAIL [$desc] (epoch $epoch) expected: $expected | actual: $actual
+"
+  fi
+}
+
+# Type predicates
+check 10  "cl-null? nil"           "true"
+check 11  "cl-null? false"         "false"
+check 12  "cl-consp? pair"         "true"
+check 13  "cl-consp? nil"          "false"
+check 14  "cl-listp? nil"          "true"
+check 15  "cl-listp? list"         "true"
+check 16  "cl-atom? nil"           "true"
+check 17  "cl-atom? pair"          "false"
+check 18  "cl-integerp?"           "true"
+check 19  "cl-floatp?"             "true"
+check 20  "cl-characterp?"         "true"
+check 21  "cl-stringp?"            "true"
+
+# Arithmetic
+check 30  "cl-mod 10 3"            "1"
+check 31  "cl-rem 10 3"            "1"
+check 32  "cl-quotient 10 3"       "3"
+check 33  "cl-gcd 12 8"            "4"
+check 34  "cl-lcm 4 6"             "12"
+check 35  "cl-abs -5"              "5"
+check 36  "cl-abs 5"               "5"
+check 37  "cl-min 2 7"             "2"
+check 38  "cl-max 2 7"             "7"
+check 39  "cl-evenp? 4"            "true"
+check 40  "cl-evenp? 3"            "false"
+check 41  "cl-oddp? 7"             "true"
+check 42  "cl-zerop? 0"            "true"
+check 43  "cl-plusp? 1"            "true"
+check 44  "cl-minusp? -1"          "true"
+check 45  "cl-signum pos"          "1"
+check 46  "cl-signum neg"          "-1"
+check 47  "cl-signum zero"         "0"
+
+# Characters
+check 50  "cl-char-code"           "65"
+check 51  "code-char returns char" "true"
+check 52  "cl-char=?"              "true"
+check 53  "cl-char<?"              "true"
+check 54  "cl-char-space code"     "32"
+check 55  "cl-char-newline code"   "10"
+check 56  "cl-alpha-char-p A"      "true"
+check 57  "cl-digit-char-p 0"      "true"
+
+# Format
+check 60  "cl-format plain"        '"hello"'
+check 61  "cl-format ~a"           '"world"'
+check 62  "cl-format ~d"           '"42"'
+check 63  "cl-format ~x"           '"ff"'
+check 64  "cl-format multi"        '"x=3 y=4"'
+
+# Gensym
+check 70  "gensym returns symbol"  "true"
+check 71  "gensyms are unique"     "true"
+
+# Sets
+check 80  "make-set is set?"       "true"
+check 81  "set-add + member"       "true"
+check 82  "member in empty"        "false"
+check 83  "list->set member"       "true"
+
+# Lists
+check 90  "cl-nth 0"               "1"
+check 91  "cl-nth 2"               "3"
+check 92  "cl-last"                "(3)"
+check 93  "cl-butlast"             "(1 2)"
+check 94  "cl-nthcdr 1"            "(2 3)"
+check 95  "cl-assoc hit"           '("b" 2)'
+check 96  "cl-assoc miss"          "nil"
+check 97  "cl-getf hit"            "42"
+check 98  "cl-adjoin new"          "(0 1 2)"
+check 99  "cl-adjoin dup"          "(1 2)"
+check 100 "cl-member hit"          "(2 3)"
+check 101 "cl-member miss"         "nil"
+check 102 "cl-flatten"             "(1 2 3 4)"
+
+# Radix
+check 110 "cl-format-binary 10"    '"1010"'
+check 111 "cl-format-octal 15"     '"17"'
+check 112 "cl-format-hex 255"      '"ff"'
+check 113 "cl-format-decimal 42"   '"42"'
+check 114 "n->s base 16"           '"1f"'
+check 115 "s->n base 16"           "31"
+
+TOTAL=$((PASS+FAIL))
+if [ $FAIL -eq 0 ]; then
+  echo "ok $PASS/$TOTAL lib/common-lisp tests passed"
+else
+  echo "FAIL $PASS/$TOTAL passed, $FAIL failed:"
+  echo "$ERRORS"
+fi
+[ $FAIL -eq 0 ]
diff --git a/lib/r7rs.sx b/lib/r7rs.sx
index 38a91f27..b2b303dd 100644
--- a/lib/r7rs.sx
+++ b/lib/r7rs.sx
@@ -76,7 +76,7 @@
 (define number->string
   (let ((prim-n->s number->string))
     (fn (n &rest r)
-      (if (nil? r) (str n) (prim-n->s n (first r))))))
+      (if (= (len r) 0) (str n) (prim-n->s n (first r))))))
 
 (define
   string->number