rose-ash/lib/common-lisp/runtime.sx

;; lib/common-lisp/runtime.sx — CL built-ins + condition system on SX
;;
;; Section 1-9:  Type predicates, arithmetic, characters, strings, gensym,
;;               multiple values, sets, radix formatting, list utilities.
;; Section 10:   Condition system (define-condition, signal/error/warn,
;;               handler-bind, handler-case, restart-case, invoke-restart).
;;
;; Primitives used from spec:
;;   char/char->integer/integer->char/char-upcase/char-downcase
;;   format   gensym   rational/rational?   make-set/set-member?/etc
;;   modulo/remainder/quotient/gcd/lcm/expt   number->string

;; ---------------------------------------------------------------------------
;; 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))))

;; ---------------------------------------------------------------------------
;; 10.  Condition system (Phase 3)
;;
;; Condition objects:
;;   {:cl-type "cl-condition" :class "NAME" :slots {slot-name val ...}}
;;
;; The built-in handler-bind / restart-case expect LITERAL handler specs in
;; source (they operate on the raw AST), so we implement our own handler and
;; restart stacks as mutable SX globals.
;; ---------------------------------------------------------------------------

;; ── condition class registry ───────────────────────────────────────────────
;;
;; Populated at load time with all ANSI standard condition types.
;; Also mutated by cl-define-condition.

(define
  cl-condition-classes
  (dict
    "condition"
    {:parents (list) :slots (list) :name "condition"}
    "serious-condition"
    {:parents (list "condition") :slots (list) :name "serious-condition"}
    "error"
    {:parents (list "serious-condition") :slots (list) :name "error"}
    "warning"
    {:parents (list "condition") :slots (list) :name "warning"}
    "simple-condition"
    {:parents (list "condition") :slots (list "format-control" "format-arguments") :name "simple-condition"}
    "simple-error"
    {:parents (list "error" "simple-condition") :slots (list "format-control" "format-arguments") :name "simple-error"}
    "simple-warning"
    {:parents (list "warning" "simple-condition") :slots (list "format-control" "format-arguments") :name "simple-warning"}
    "type-error"
    {:parents (list "error") :slots (list "datum" "expected-type") :name "type-error"}
    "arithmetic-error"
    {:parents (list "error") :slots (list "operation" "operands") :name "arithmetic-error"}
    "division-by-zero"
    {:parents (list "arithmetic-error") :slots (list) :name "division-by-zero"}
    "cell-error"
    {:parents (list "error") :slots (list "name") :name "cell-error"}
    "unbound-variable"
    {:parents (list "cell-error") :slots (list) :name "unbound-variable"}
    "undefined-function"
    {:parents (list "cell-error") :slots (list) :name "undefined-function"}
    "program-error"
    {:parents (list "error") :slots (list) :name "program-error"}
    "storage-condition"
    {:parents (list "serious-condition") :slots (list) :name "storage-condition"}))

;; ── condition predicates ───────────────────────────────────────────────────

(define
  cl-condition?
  (fn (x) (and (dict? x) (= (get x "cl-type") "cl-condition"))))

;; cl-condition-of-type? walks the class hierarchy.
;; We capture cl-condition-classes at define time via let to avoid
;; free-variable scoping issues at call time.

(define
  cl-condition-of-type?
  (let
    ((classes cl-condition-classes))
    (fn
      (c type-name)
      (if
        (not (cl-condition? c))
        false
        (let
          ((class-name (get c "class")))
          (define
            check
            (fn
              (n)
              (if
                (= n type-name)
                true
                (let
                  ((entry (get classes n)))
                  (if
                    (nil? entry)
                    false
                    (some (fn (p) (check p)) (get entry "parents")))))))
          (check class-name))))))

;; ── condition constructors ─────────────────────────────────────────────────

;; cl-define-condition registers a new condition class.
;; name:       string (condition class name)
;; parents:    list of strings (parent class names)
;; slot-names: list of strings

(define
  cl-define-condition
  (fn
    (name parents slot-names)
    (begin (dict-set! cl-condition-classes name {:parents parents :slots slot-names :name name}) name)))

;; cl-make-condition constructs a condition object.
;; Keyword args (alternating slot-name/value pairs) populate the slots dict.

(define
  cl-make-condition
  (fn
    (name &rest kw-args)
    (let
      ((slots (dict)))
      (define
        fill
        (fn
          (args)
          (when
            (>= (len args) 2)
            (begin
              (dict-set! slots (first args) (first (rest args)))
              (fill (rest (rest args)))))))
      (fill kw-args)
      {:cl-type "cl-condition" :slots slots :class name})))

;; ── condition accessors ────────────────────────────────────────────────────

(define
  cl-condition-slot
  (fn
    (c slot-name)
    (if (cl-condition? c) (get (get c "slots") slot-name) nil)))

(define
  cl-condition-message
  (fn
    (c)
    (if
      (not (cl-condition? c))
      (str c)
      (let
        ((slots (get c "slots")))
        (or
          (get slots "message")
          (get slots "format-control")
          (str "Condition: " (get c "class")))))))

(define
  cl-simple-condition-format-control
  (fn (c) (cl-condition-slot c "format-control")))

(define
  cl-simple-condition-format-arguments
  (fn (c) (cl-condition-slot c "format-arguments")))

(define cl-type-error-datum (fn (c) (cl-condition-slot c "datum")))

(define
  cl-type-error-expected-type
  (fn (c) (cl-condition-slot c "expected-type")))

(define
  cl-arithmetic-error-operation
  (fn (c) (cl-condition-slot c "operation")))

(define
  cl-arithmetic-error-operands
  (fn (c) (cl-condition-slot c "operands")))

;; ── mutable handler + restart stacks ──────────────────────────────────────
;;
;; Handler entry: {:type "type-name" :fn (fn (condition) result)}
;; Restart entry: {:name "restart-name" :fn (fn (&optional arg) result) :escape k}
;;
;; New handlers are prepended (checked first = most recent handler wins).

(define cl-handler-stack (list))
(define cl-restart-stack (list))

(define
  cl-push-handlers
  (fn (entries) (set! cl-handler-stack (append entries cl-handler-stack))))

(define
  cl-pop-handlers
  (fn
    (n)
    (set! cl-handler-stack (slice cl-handler-stack n (len cl-handler-stack)))))

(define
  cl-push-restarts
  (fn (entries) (set! cl-restart-stack (append entries cl-restart-stack))))

(define
  cl-pop-restarts
  (fn
    (n)
    (set! cl-restart-stack (slice cl-restart-stack n (len cl-restart-stack)))))

;; ── cl-signal (non-unwinding) ─────────────────────────────────────────────
;;
;; Walks cl-handler-stack; for each matching entry, calls the handler fn.
;; Handlers return normally — signal continues to the next matching handler.

(define
  cl-signal-obj
  (fn
    (obj stack)
    (if
      (empty? stack)
      nil
      (let
        ((entry (first stack)))
        (if
          (cl-condition-of-type? obj (get entry "type"))
          (begin ((get entry "fn") obj) (cl-signal-obj obj (rest stack)))
          (cl-signal-obj obj (rest stack)))))))

(define
  cl-signal
  (fn
    (c)
    (let
      ((obj (if (cl-condition? c) c (cl-make-condition "simple-condition" "format-control" (str c)))))
      (cl-signal-obj obj cl-handler-stack))))

;; ── cl-error ───────────────────────────────────────────────────────────────
;;
;; Signals an error. If no handler catches it, raises a host-level error.

(define
  cl-error
  (fn
    (c &rest args)
    (let
      ((obj (cond ((cl-condition? c) c) ((string? c) (cl-make-condition "simple-error" "format-control" c "format-arguments" args)) (:else (cl-make-condition "simple-error" "format-control" (str c))))))
      (cl-signal-obj obj cl-handler-stack)
      (error (str "Unhandled CL error: " (cl-condition-message obj))))))

;; ── cl-warn ────────────────────────────────────────────────────────────────

(define
  cl-warn
  (fn
    (c &rest args)
    (let
      ((obj (cond ((cl-condition? c) c) ((string? c) (cl-make-condition "simple-warning" "format-control" c "format-arguments" args)) (:else (cl-make-condition "simple-warning" "format-control" (str c))))))
      (cl-signal-obj obj cl-handler-stack))))

;; ── cl-handler-bind (non-unwinding) ───────────────────────────────────────
;;
;; bindings: list of (type-name handler-fn) pairs
;; thunk:    (fn () body)

(define
  cl-handler-bind
  (fn
    (bindings thunk)
    (let
      ((entries (map (fn (b) {:fn (first (rest b)) :type (first b)}) bindings)))
      (begin
        (cl-push-handlers entries)
        (let
          ((result (thunk)))
          (begin (cl-pop-handlers (len entries)) result))))))

;; ── cl-handler-case (unwinding) ───────────────────────────────────────────
;;
;; thunk: (fn () body)
;; cases: list of (type-name handler-fn) pairs
;;
;; Uses call/cc for the escape continuation.

(define
  cl-handler-case
  (fn
    (thunk &rest cases)
    (call/cc
      (fn
        (escape)
        (let
          ((entries (map (fn (c) {:fn (fn (x) (escape ((first (rest c)) x))) :type (first c)}) cases)))
          (begin
            (cl-push-handlers entries)
            (let
              ((result (thunk)))
              (begin (cl-pop-handlers (len entries)) result))))))))

;; ── cl-restart-case ────────────────────────────────────────────────────────
;;
;; thunk:    (fn () body)
;; restarts: list of (name params body-fn) triples
;;   body-fn is (fn () val) or (fn (arg) val)

(define
  cl-restart-case
  (fn
    (thunk &rest restarts)
    (call/cc
      (fn
        (escape)
        (let
          ((entries (map (fn (r) {:fn (first (rest (rest r))) :escape escape :name (first r)}) restarts)))
          (begin
            (cl-push-restarts entries)
            (let
              ((result (thunk)))
              (begin (cl-pop-restarts (len entries)) result))))))))

;; ── cl-with-simple-restart ─────────────────────────────────────────────────

(define
  cl-with-simple-restart
  (fn
    (name description thunk)
    (cl-restart-case thunk (list name (list) (fn () nil)))))

;; ── find-restart / invoke-restart / compute-restarts ──────────────────────

(define
  cl-find-restart-entry
  (fn
    (name stack)
    (if
      (empty? stack)
      nil
      (let
        ((entry (first stack)))
        (if
          (= (get entry "name") name)
          entry
          (cl-find-restart-entry name (rest stack)))))))

(define
  cl-find-restart
  (fn (name) (cl-find-restart-entry name cl-restart-stack)))

(define
  cl-invoke-restart
  (fn
    (name &rest args)
    (let
      ((entry (cl-find-restart-entry name cl-restart-stack)))
      (if
        (nil? entry)
        (error (str "No active restart: " name))
        (let
          ((restart-fn (get entry "fn")) (escape (get entry "escape")))
          (escape
            (if (empty? args) (restart-fn) (restart-fn (first args)))))))))

(define
  cl-compute-restarts
  (fn () (map (fn (e) (get e "name")) cl-restart-stack)))

;; ── with-condition-restarts (stub — association is advisory) ──────────────

(define cl-with-condition-restarts (fn (c restarts thunk) (thunk)))

;; ── cl-cerror ──────────────────────────────────────────────────────────────
;;
;; Signals a continuable error. The "continue" restart is established;
;; invoke-restart "continue" to proceed past the error.

(define
  cl-cerror
  (fn
    (continue-string c &rest args)
    (let
      ((obj (if (cl-condition? c) c (cl-make-condition "simple-error" "format-control" (str c) "format-arguments" args))))
      (cl-restart-case
        (fn () (cl-signal-obj obj cl-handler-stack))
        (list "continue" (list) (fn () nil))))))