Compare commits
2 Commits
loops/comm
...
architectu
| Author | SHA1 | Date | |
|---|---|---|---|
| f247cb2898 | |||
| f8023cf74e |
@@ -1,578 +0,0 @@
|
||||
;; Common Lisp evaluator — evaluates CL AST forms.
|
||||
;;
|
||||
;; Depends on: lib/common-lisp/reader.sx, lib/common-lisp/parser.sx
|
||||
;;
|
||||
;; Environment:
|
||||
;; {:vars {"NAME" val ...} :fns {"NAME" cl-fn ...}}
|
||||
;; CL function:
|
||||
;; {:cl-type "function" :params ll :body forms :env env}
|
||||
;;
|
||||
;; Public API:
|
||||
;; (cl-make-env) — create empty environment
|
||||
;; (cl-eval form env) — evaluate one CL AST form
|
||||
;; (cl-eval-str src env) — read+eval a CL source string
|
||||
;; (cl-eval-all-str src env) — read-all+eval-each, return last
|
||||
;; cl-global-env — global mutable environment
|
||||
|
||||
;; ── environment ──────────────────────────────────────────────────
|
||||
|
||||
(define cl-make-env (fn () {:vars {} :fns {}}))
|
||||
|
||||
(define cl-global-env (cl-make-env))
|
||||
|
||||
(define cl-env-get-var (fn (env name) (get (get env "vars") name)))
|
||||
(define cl-env-has-var? (fn (env name) (has-key? (get env "vars") name)))
|
||||
(define cl-env-get-fn (fn (env name) (get (get env "fns") name)))
|
||||
(define cl-env-has-fn? (fn (env name) (has-key? (get env "fns") name)))
|
||||
|
||||
(define cl-env-bind-var
|
||||
(fn (env name value)
|
||||
{:vars (assoc (get env "vars") name value)
|
||||
:fns (get env "fns")}))
|
||||
|
||||
(define cl-env-bind-fn
|
||||
(fn (env name fn-obj)
|
||||
{:vars (get env "vars")
|
||||
:fns (assoc (get env "fns") name fn-obj)}))
|
||||
|
||||
;; ── body evaluation ───────────────────────────────────────────────
|
||||
|
||||
(define cl-eval-body
|
||||
(fn (forms env)
|
||||
(cond
|
||||
((= (len forms) 0) nil)
|
||||
((= (len forms) 1) (cl-eval (nth forms 0) env))
|
||||
(:else
|
||||
(do
|
||||
(cl-eval (nth forms 0) env)
|
||||
(cl-eval-body (rest forms) env))))))
|
||||
|
||||
;; ── lambda-list binding helpers ───────────────────────────────────
|
||||
|
||||
(define cl-bind-required
|
||||
(fn (names args env)
|
||||
(if (= (len names) 0)
|
||||
env
|
||||
(cl-bind-required
|
||||
(rest names)
|
||||
(if (> (len args) 0) (rest args) args)
|
||||
(cl-env-bind-var env
|
||||
(nth names 0)
|
||||
(if (> (len args) 0) (nth args 0) nil))))))
|
||||
|
||||
;; returns {:env e :rest remaining-args}
|
||||
(define cl-bind-optional
|
||||
(fn (opts args env)
|
||||
(if (= (len opts) 0)
|
||||
{:env env :rest args}
|
||||
(let ((spec (nth opts 0))
|
||||
(has-val (> (len args) 0)))
|
||||
(let ((val (if has-val (nth args 0) nil))
|
||||
(rem (if has-val (rest args) args)))
|
||||
(let ((e1 (cl-env-bind-var env (get spec "name")
|
||||
(if has-val val
|
||||
(if (get spec "default")
|
||||
(cl-eval (get spec "default") env) nil)))))
|
||||
(let ((e2 (if (get spec "supplied")
|
||||
(cl-env-bind-var e1 (get spec "supplied") has-val)
|
||||
e1)))
|
||||
(cl-bind-optional (rest opts) rem e2))))))))
|
||||
|
||||
;; returns {:found bool :value v}
|
||||
(define cl-find-kw-arg
|
||||
(fn (kw args i)
|
||||
(if (>= i (len args))
|
||||
{:found false :value nil}
|
||||
(let ((a (nth args i)))
|
||||
(if (and (dict? a)
|
||||
(= (get a "cl-type") "keyword")
|
||||
(= (get a "name") kw))
|
||||
{:found true
|
||||
:value (if (< (+ i 1) (len args)) (nth args (+ i 1)) nil)}
|
||||
(cl-find-kw-arg kw args (+ i 2)))))))
|
||||
|
||||
(define cl-bind-key
|
||||
(fn (key-specs all-args env)
|
||||
(if (= (len key-specs) 0)
|
||||
env
|
||||
(let ((spec (nth key-specs 0))
|
||||
(r (cl-find-kw-arg (get (nth key-specs 0) "keyword") all-args 0)))
|
||||
(let ((found (get r "found"))
|
||||
(kval (get r "value")))
|
||||
(let ((e1 (cl-env-bind-var env (get spec "name")
|
||||
(if found kval
|
||||
(if (get spec "default")
|
||||
(cl-eval (get spec "default") env) nil)))))
|
||||
(let ((e2 (if (get spec "supplied")
|
||||
(cl-env-bind-var e1 (get spec "supplied") found)
|
||||
e1)))
|
||||
(cl-bind-key (rest key-specs) all-args e2))))))))
|
||||
|
||||
(define cl-bind-aux
|
||||
(fn (aux-specs env)
|
||||
(if (= (len aux-specs) 0)
|
||||
env
|
||||
(let ((spec (nth aux-specs 0)))
|
||||
(cl-bind-aux
|
||||
(rest aux-specs)
|
||||
(cl-env-bind-var env (get spec "name")
|
||||
(if (get spec "init") (cl-eval (get spec "init") env) nil)))))))
|
||||
|
||||
;; ── function creation ─────────────────────────────────────────────
|
||||
|
||||
;; ll-and-body: (list lambda-list-form body-form ...)
|
||||
(define cl-make-lambda
|
||||
(fn (ll-and-body env)
|
||||
{:cl-type "function"
|
||||
:params (cl-parse-lambda-list (nth ll-and-body 0))
|
||||
:body (rest ll-and-body)
|
||||
:env env}))
|
||||
|
||||
;; ── function application ──────────────────────────────────────────
|
||||
|
||||
(define cl-apply
|
||||
(fn (fn-obj args)
|
||||
(cond
|
||||
((and (dict? fn-obj) (has-key? fn-obj "builtin-fn"))
|
||||
((get fn-obj "builtin-fn") args))
|
||||
((or (not (dict? fn-obj)) (not (= (get fn-obj "cl-type") "function")))
|
||||
{:cl-type "error" :message "Not a function"})
|
||||
(:else
|
||||
(let ((params (get fn-obj "params"))
|
||||
(body (get fn-obj "body"))
|
||||
(cenv (get fn-obj "env")))
|
||||
(let ((req (get params "required"))
|
||||
(opt (get params "optional"))
|
||||
(rest-name (get params "rest"))
|
||||
(key-specs (get params "key"))
|
||||
(aux-specs (get params "aux")))
|
||||
(let ((e1 (cl-bind-required req args cenv)))
|
||||
(let ((opt-r (cl-bind-optional
|
||||
opt (slice args (len req) (len args)) e1)))
|
||||
(let ((e2 (get opt-r "env"))
|
||||
(rem (get opt-r "rest")))
|
||||
(let ((e3 (if rest-name
|
||||
(cl-env-bind-var e2 rest-name rem)
|
||||
e2)))
|
||||
(let ((e4 (cl-bind-key key-specs args e3)))
|
||||
(let ((e5 (cl-bind-aux aux-specs e4)))
|
||||
(cl-eval-body body e5)))))))))))))
|
||||
|
||||
;; ── built-in functions ────────────────────────────────────────────
|
||||
|
||||
(define cl-builtins
|
||||
(dict
|
||||
"+" (fn (args) (reduce (fn (a b) (+ a b)) 0 args))
|
||||
"-" (fn (args)
|
||||
(cond
|
||||
((= (len args) 0) 0)
|
||||
((= (len args) 1) (- 0 (nth args 0)))
|
||||
(:else (reduce (fn (a b) (- a b)) (nth args 0) (rest args)))))
|
||||
"*" (fn (args) (reduce (fn (a b) (* a b)) 1 args))
|
||||
"/" (fn (args)
|
||||
(cond
|
||||
((= (len args) 0) 1)
|
||||
((= (len args) 1) (/ 1 (nth args 0)))
|
||||
(:else (reduce (fn (a b) (/ a b)) (nth args 0) (rest args)))))
|
||||
"1+" (fn (args) (+ (nth args 0) 1))
|
||||
"1-" (fn (args) (- (nth args 0) 1))
|
||||
"=" (fn (args) (if (= (nth args 0) (nth args 1)) true nil))
|
||||
"/=" (fn (args) (if (not (= (nth args 0) (nth args 1))) true nil))
|
||||
"<" (fn (args) (if (< (nth args 0) (nth args 1)) true nil))
|
||||
">" (fn (args) (if (> (nth args 0) (nth args 1)) true nil))
|
||||
"<=" (fn (args) (if (<= (nth args 0) (nth args 1)) true nil))
|
||||
">=" (fn (args) (if (>= (nth args 0) (nth args 1)) true nil))
|
||||
"NOT" (fn (args) (if (nth args 0) nil true))
|
||||
"NULL" (fn (args) (if (= (nth args 0) nil) true nil))
|
||||
"NUMBERP" (fn (args) (if (number? (nth args 0)) true nil))
|
||||
"STRINGP" (fn (args) (if (string? (nth args 0)) true nil))
|
||||
"SYMBOLP" (fn (args) nil)
|
||||
"LISTP" (fn (args)
|
||||
(if (or (list? (nth args 0)) (= (nth args 0) nil)) true nil))
|
||||
"CONSP" (fn (args)
|
||||
(let ((x (nth args 0)))
|
||||
(if (and (dict? x) (= (get x "cl-type") "cons")) true nil)))
|
||||
"ATOM" (fn (args)
|
||||
(let ((x (nth args 0)))
|
||||
(if (and (dict? x) (= (get x "cl-type") "cons")) nil true)))
|
||||
"FUNCTIONP" (fn (args)
|
||||
(let ((x (nth args 0)))
|
||||
(if (and (dict? x) (= (get x "cl-type") "function")) true nil)))
|
||||
"ZEROP" (fn (args) (if (= (nth args 0) 0) true nil))
|
||||
"PLUSP" (fn (args) (if (> (nth args 0) 0) true nil))
|
||||
"MINUSP" (fn (args) (if (< (nth args 0) 0) true nil))
|
||||
"EVENP" (fn (args)
|
||||
(let ((n (nth args 0)))
|
||||
(if (= (mod n 2) 0) true nil)))
|
||||
"ODDP" (fn (args)
|
||||
(let ((n (nth args 0)))
|
||||
(if (not (= (mod n 2) 0)) true nil)))
|
||||
"ABS" (fn (args) (let ((n (nth args 0))) (if (< n 0) (- 0 n) n)))
|
||||
"MAX" (fn (args) (reduce (fn (a b) (if (> a b) a b)) (nth args 0) (rest args)))
|
||||
"MIN" (fn (args) (reduce (fn (a b) (if (< a b) a b)) (nth args 0) (rest args)))
|
||||
"CONS" (fn (args) {:cl-type "cons" :car (nth args 0) :cdr (nth args 1)})
|
||||
"CAR" (fn (args)
|
||||
(let ((x (nth args 0)))
|
||||
(if (and (dict? x) (= (get x "cl-type") "cons"))
|
||||
(get x "car")
|
||||
(if (and (list? x) (> (len x) 0)) (nth x 0) nil))))
|
||||
"CDR" (fn (args)
|
||||
(let ((x (nth args 0)))
|
||||
(if (and (dict? x) (= (get x "cl-type") "cons"))
|
||||
(get x "cdr")
|
||||
(if (list? x) (rest x) nil))))
|
||||
"LIST" (fn (args) args)
|
||||
"APPEND" (fn (args)
|
||||
(if (= (len args) 0) (list)
|
||||
(reduce (fn (a b)
|
||||
(if (= a nil) b (if (= b nil) a (concat a b))))
|
||||
(list) args)))
|
||||
"LENGTH" (fn (args)
|
||||
(let ((x (nth args 0)))
|
||||
(if (= x nil) 0 (len x))))
|
||||
"NTH" (fn (args) (nth (nth args 1) (nth args 0)))
|
||||
"FIRST" (fn (args)
|
||||
(let ((x (nth args 0)))
|
||||
(if (and (list? x) (> (len x) 0)) (nth x 0) nil)))
|
||||
"SECOND" (fn (args)
|
||||
(let ((x (nth args 0)))
|
||||
(if (and (list? x) (> (len x) 1)) (nth x 1) nil)))
|
||||
"THIRD" (fn (args)
|
||||
(let ((x (nth args 0)))
|
||||
(if (and (list? x) (> (len x) 2)) (nth x 2) nil)))
|
||||
"REST" (fn (args) (rest (nth args 0)))
|
||||
"REVERSE" (fn (args)
|
||||
(reduce (fn (acc x) (concat (list x) acc))
|
||||
(list) (nth args 0)))
|
||||
"IDENTITY" (fn (args) (nth args 0))
|
||||
"VALUES" (fn (args) (if (> (len args) 0) (nth args 0) nil))
|
||||
"PRINT" (fn (args) (nth args 0))
|
||||
"PRIN1" (fn (args) (nth args 0))
|
||||
"PRINC" (fn (args) (nth args 0))
|
||||
"TERPRI" (fn (args) nil)
|
||||
"WRITE" (fn (args) (nth args 0))
|
||||
"STRING-UPCASE" (fn (args) (upcase (nth args 0)))
|
||||
"STRING-DOWNCASE" (fn (args) (downcase (nth args 0)))
|
||||
"STRING=" (fn (args) (if (= (nth args 0) (nth args 1)) true nil))
|
||||
"CONCATENATE" (fn (args) (reduce (fn (a b) (str a b)) "" (rest args)))
|
||||
"EQ" (fn (args) (if (= (nth args 0) (nth args 1)) true nil))
|
||||
"EQL" (fn (args) (if (= (nth args 0) (nth args 1)) true nil))
|
||||
"EQUAL" (fn (args) (if (= (nth args 0) (nth args 1)) true nil))))
|
||||
|
||||
;; Register builtins in cl-global-env so (function #'name) resolves them
|
||||
(for-each
|
||||
(fn (name)
|
||||
(dict-set! (get cl-global-env "fns") name
|
||||
{:cl-type "function" :builtin-fn (get cl-builtins name)}))
|
||||
(keys cl-builtins))
|
||||
|
||||
;; ── special form evaluators ───────────────────────────────────────
|
||||
|
||||
(define cl-eval-if
|
||||
(fn (args env)
|
||||
(let ((cond-val (cl-eval (nth args 0) env))
|
||||
(then-form (nth args 1))
|
||||
(else-form (if (> (len args) 2) (nth args 2) nil)))
|
||||
(if cond-val
|
||||
(cl-eval then-form env)
|
||||
(if else-form (cl-eval else-form env) nil)))))
|
||||
|
||||
(define cl-eval-and
|
||||
(fn (args env)
|
||||
(if (= (len args) 0)
|
||||
true
|
||||
(let ((val (cl-eval (nth args 0) env)))
|
||||
(if (not val)
|
||||
nil
|
||||
(if (= (len args) 1)
|
||||
val
|
||||
(cl-eval-and (rest args) env)))))))
|
||||
|
||||
(define cl-eval-or
|
||||
(fn (args env)
|
||||
(if (= (len args) 0)
|
||||
nil
|
||||
(let ((val (cl-eval (nth args 0) env)))
|
||||
(if val
|
||||
val
|
||||
(cl-eval-or (rest args) env))))))
|
||||
|
||||
(define cl-eval-cond
|
||||
(fn (clauses env)
|
||||
(if (= (len clauses) 0)
|
||||
nil
|
||||
(let ((clause (nth clauses 0)))
|
||||
(let ((test-val (cl-eval (nth clause 0) env)))
|
||||
(if test-val
|
||||
(if (= (len clause) 1)
|
||||
test-val
|
||||
(cl-eval-body (rest clause) env))
|
||||
(cl-eval-cond (rest clauses) env)))))))
|
||||
|
||||
;; Parallel LET and sequential LET*
|
||||
(define cl-eval-let
|
||||
(fn (args env sequential)
|
||||
(let ((bindings (nth args 0))
|
||||
(body (rest args)))
|
||||
(if sequential
|
||||
;; LET*: each binding sees previous ones
|
||||
(let ((new-env env))
|
||||
(define bind-seq
|
||||
(fn (bs e)
|
||||
(if (= (len bs) 0)
|
||||
e
|
||||
(let ((b (nth bs 0)))
|
||||
(let ((name (if (list? b) (nth b 0) b))
|
||||
(init (if (and (list? b) (> (len b) 1)) (nth b 1) nil)))
|
||||
(bind-seq (rest bs)
|
||||
(cl-env-bind-var e name (cl-eval init e))))))))
|
||||
(cl-eval-body body (bind-seq bindings env)))
|
||||
;; LET: evaluate all inits in current env, then bind
|
||||
(let ((pairs (map
|
||||
(fn (b)
|
||||
(let ((name (if (list? b) (nth b 0) b))
|
||||
(init (if (and (list? b) (> (len b) 1)) (nth b 1) nil)))
|
||||
{:name name :value (cl-eval init env)}))
|
||||
bindings)))
|
||||
(let ((new-env (reduce
|
||||
(fn (e pair)
|
||||
(cl-env-bind-var e (get pair "name") (get pair "value")))
|
||||
env pairs)))
|
||||
(cl-eval-body body new-env)))))))
|
||||
|
||||
;; SETQ / SETF (simplified: mutate nearest scope or global)
|
||||
(define cl-eval-setq
|
||||
(fn (args env)
|
||||
(if (< (len args) 2)
|
||||
nil
|
||||
(let ((name (nth args 0))
|
||||
(val (cl-eval (nth args 1) env)))
|
||||
(if (has-key? (get env "vars") name)
|
||||
(dict-set! (get env "vars") name val)
|
||||
(dict-set! (get cl-global-env "vars") name val))
|
||||
(if (> (len args) 2)
|
||||
(cl-eval-setq (rest (rest args)) env)
|
||||
val)))))
|
||||
|
||||
;; FUNCTION: get function value or create lambda
|
||||
(define cl-eval-function
|
||||
(fn (args env)
|
||||
(let ((spec (nth args 0)))
|
||||
(cond
|
||||
((and (list? spec) (> (len spec) 0) (= (nth spec 0) "LAMBDA"))
|
||||
(cl-make-lambda (rest spec) env))
|
||||
((string? spec)
|
||||
(cond
|
||||
((cl-env-has-fn? env spec) (cl-env-get-fn env spec))
|
||||
((cl-env-has-fn? cl-global-env spec)
|
||||
(cl-env-get-fn cl-global-env spec))
|
||||
(:else {:cl-type "error" :message (str "Undefined function: " spec)})))
|
||||
(:else {:cl-type "error" :message "FUNCTION: invalid spec"})))))
|
||||
|
||||
;; FLET: local functions (non-recursive, close over outer env)
|
||||
(define cl-eval-flet
|
||||
(fn (args env)
|
||||
(let ((fn-defs (nth args 0))
|
||||
(body (rest args)))
|
||||
(let ((new-env (reduce
|
||||
(fn (e def)
|
||||
(let ((name (nth def 0))
|
||||
(ll (nth def 1))
|
||||
(fn-body (rest (rest def))))
|
||||
(cl-env-bind-fn e name
|
||||
{:cl-type "function"
|
||||
:params (cl-parse-lambda-list ll)
|
||||
:body fn-body
|
||||
:env env})))
|
||||
env fn-defs)))
|
||||
(cl-eval-body body new-env)))))
|
||||
|
||||
;; LABELS: mutually-recursive local functions
|
||||
(define cl-eval-labels
|
||||
(fn (args env)
|
||||
(let ((fn-defs (nth args 0))
|
||||
(body (rest args)))
|
||||
;; Build env with placeholder nil entries for each name
|
||||
(let ((new-env (reduce
|
||||
(fn (e def) (cl-env-bind-fn e (nth def 0) nil))
|
||||
env fn-defs)))
|
||||
;; Fill in real function objects that capture new-env
|
||||
(for-each
|
||||
(fn (def)
|
||||
(let ((name (nth def 0))
|
||||
(ll (nth def 1))
|
||||
(fn-body (rest (rest def))))
|
||||
(dict-set! (get new-env "fns") name
|
||||
{:cl-type "function"
|
||||
:params (cl-parse-lambda-list ll)
|
||||
:body fn-body
|
||||
:env new-env})))
|
||||
fn-defs)
|
||||
(cl-eval-body body new-env)))))
|
||||
|
||||
;; EVAL-WHEN: evaluate body only if :execute is in situations
|
||||
(define cl-eval-eval-when
|
||||
(fn (args env)
|
||||
(let ((situations (nth args 0))
|
||||
(body (rest args)))
|
||||
(define has-exec
|
||||
(some (fn (s)
|
||||
(or
|
||||
(and (dict? s)
|
||||
(= (get s "cl-type") "keyword")
|
||||
(= (get s "name") "EXECUTE"))
|
||||
(= s "EXECUTE")))
|
||||
situations))
|
||||
(if has-exec (cl-eval-body body env) nil))))
|
||||
|
||||
;; DEFUN: define function in global fns namespace
|
||||
(define cl-eval-defun
|
||||
(fn (args env)
|
||||
(let ((name (nth args 0))
|
||||
(ll (nth args 1))
|
||||
(fn-body (rest (rest args))))
|
||||
(let ((fn-obj {:cl-type "function"
|
||||
:params (cl-parse-lambda-list ll)
|
||||
:body fn-body
|
||||
:env env}))
|
||||
(dict-set! (get cl-global-env "fns") name fn-obj)
|
||||
name))))
|
||||
|
||||
;; DEFVAR / DEFPARAMETER / DEFCONSTANT
|
||||
(define cl-eval-defvar
|
||||
(fn (args env always-assign)
|
||||
(let ((name (nth args 0))
|
||||
(has-init (> (len args) 1)))
|
||||
(let ((val (if has-init (cl-eval (nth args 1) env) nil)))
|
||||
(when (or always-assign
|
||||
(not (cl-env-has-var? cl-global-env name)))
|
||||
(dict-set! (get cl-global-env "vars") name val))
|
||||
name))))
|
||||
|
||||
;; Function call: evaluate name → look up fns, builtins; evaluate args
|
||||
(define cl-call-fn
|
||||
(fn (name args env)
|
||||
(let ((evaled (map (fn (a) (cl-eval a env)) args)))
|
||||
(cond
|
||||
;; FUNCALL: (funcall fn arg...)
|
||||
((= name "FUNCALL")
|
||||
(cl-apply (nth evaled 0) (rest evaled)))
|
||||
;; APPLY: (apply fn arg... list)
|
||||
((= name "APPLY")
|
||||
(let ((fn-obj (nth evaled 0))
|
||||
(all-args (rest evaled)))
|
||||
(let ((leading (slice all-args 0 (- (len all-args) 1)))
|
||||
(last-arg (nth all-args (- (len all-args) 1))))
|
||||
(cl-apply fn-obj (concat leading (if (= last-arg nil) (list) last-arg))))))
|
||||
;; MAPCAR: (mapcar fn list)
|
||||
((= name "MAPCAR")
|
||||
(let ((fn-obj (nth evaled 0))
|
||||
(lst (nth evaled 1)))
|
||||
(if (= lst nil) (list)
|
||||
(map (fn (x) (cl-apply fn-obj (list x))) lst))))
|
||||
;; Look up in local fns namespace
|
||||
((cl-env-has-fn? env name)
|
||||
(cl-apply (cl-env-get-fn env name) evaled))
|
||||
;; Look up in global fns namespace
|
||||
((cl-env-has-fn? cl-global-env name)
|
||||
(cl-apply (cl-env-get-fn cl-global-env name) evaled))
|
||||
;; Look up in builtins
|
||||
((has-key? cl-builtins name)
|
||||
((get cl-builtins name) evaled))
|
||||
(:else
|
||||
{:cl-type "error" :message (str "Undefined function: " name)})))))
|
||||
|
||||
;; ── main evaluator ────────────────────────────────────────────────
|
||||
|
||||
(define cl-eval
|
||||
(fn (form env)
|
||||
(cond
|
||||
;; Nil and booleans are self-evaluating
|
||||
((= form nil) nil)
|
||||
((= form true) true)
|
||||
;; Numbers are self-evaluating
|
||||
((number? form) form)
|
||||
;; Dicts: typed CL values
|
||||
((dict? form)
|
||||
(let ((ct (get form "cl-type")))
|
||||
(cond
|
||||
((= ct "string") (get form "value")) ;; CL string → SX string
|
||||
(:else form)))) ;; keywords, floats, chars, etc.
|
||||
;; Symbol reference (variable lookup)
|
||||
((string? form)
|
||||
(cond
|
||||
((cl-env-has-var? env form) (cl-env-get-var env form))
|
||||
((cl-env-has-var? cl-global-env form)
|
||||
(cl-env-get-var cl-global-env form))
|
||||
(:else {:cl-type "error" :message (str "Undefined variable: " form)})))
|
||||
;; List: special forms or function call
|
||||
((list? form) (cl-eval-list form env))
|
||||
;; Anything else self-evaluates
|
||||
(:else form))))
|
||||
|
||||
(define cl-eval-list
|
||||
(fn (form env)
|
||||
(if (= (len form) 0)
|
||||
nil
|
||||
(let ((head (nth form 0))
|
||||
(args (rest form)))
|
||||
(cond
|
||||
((= head "QUOTE") (nth args 0))
|
||||
((= head "IF") (cl-eval-if args env))
|
||||
((= head "PROGN") (cl-eval-body args env))
|
||||
((= head "LET") (cl-eval-let args env false))
|
||||
((= head "LET*") (cl-eval-let args env true))
|
||||
((= head "AND") (cl-eval-and args env))
|
||||
((= head "OR") (cl-eval-or args env))
|
||||
((= head "COND") (cl-eval-cond args env))
|
||||
((= head "WHEN")
|
||||
(if (cl-eval (nth args 0) env)
|
||||
(cl-eval-body (rest args) env) nil))
|
||||
((= head "UNLESS")
|
||||
(if (not (cl-eval (nth args 0) env))
|
||||
(cl-eval-body (rest args) env) nil))
|
||||
((= head "SETQ") (cl-eval-setq args env))
|
||||
((= head "SETF") (cl-eval-setq args env))
|
||||
((= head "FUNCTION") (cl-eval-function args env))
|
||||
((= head "LAMBDA") (cl-make-lambda args env))
|
||||
((= head "FLET") (cl-eval-flet args env))
|
||||
((= head "LABELS") (cl-eval-labels args env))
|
||||
((= head "THE") (cl-eval (nth args 1) env))
|
||||
((= head "LOCALLY") (cl-eval-body args env))
|
||||
((= head "EVAL-WHEN") (cl-eval-eval-when args env))
|
||||
((= head "DEFUN") (cl-eval-defun args env))
|
||||
((= head "DEFVAR") (cl-eval-defvar args env false))
|
||||
((= head "DEFPARAMETER") (cl-eval-defvar args env true))
|
||||
((= head "DEFCONSTANT") (cl-eval-defvar args env true))
|
||||
((= head "DECLAIM") nil)
|
||||
((= head "PROCLAIM") nil)
|
||||
;; Named function call
|
||||
((string? head)
|
||||
(cl-call-fn head args env))
|
||||
;; Anonymous call: ((lambda ...) args)
|
||||
(:else
|
||||
(let ((fn-obj (cl-eval head env)))
|
||||
(if (and (dict? fn-obj) (= (get fn-obj "cl-type") "function"))
|
||||
(cl-apply fn-obj (map (fn (a) (cl-eval a env)) args))
|
||||
{:cl-type "error" :message "Not callable"}))))))))
|
||||
|
||||
;; ── public API ────────────────────────────────────────────────────
|
||||
|
||||
(define cl-eval-str
|
||||
(fn (src env)
|
||||
(cl-eval (cl-read src) env)))
|
||||
|
||||
(define cl-eval-all-str
|
||||
(fn (src env)
|
||||
(let ((forms (cl-read-all src)))
|
||||
(if (= (len forms) 0)
|
||||
nil
|
||||
(let ((result nil) (i 0))
|
||||
(define loop (fn ()
|
||||
(when (< i (len forms))
|
||||
(do
|
||||
(set! result (cl-eval (nth forms i) env))
|
||||
(set! i (+ i 1))
|
||||
(loop)))))
|
||||
(loop)
|
||||
result)))))
|
||||
@@ -1,377 +0,0 @@
|
||||
;; Common Lisp reader — converts token stream to CL AST forms.
|
||||
;;
|
||||
;; Depends on: lib/common-lisp/reader.sx (cl-tokenize)
|
||||
;;
|
||||
;; AST representation:
|
||||
;; integer/float → SX number (or {:cl-type "float"/:ratio ...})
|
||||
;; string → SX string
|
||||
;; symbol FOO → SX string "FOO" (upcase)
|
||||
;; symbol NIL → nil
|
||||
;; symbol T → true
|
||||
;; :keyword → {:cl-type "keyword" :name "FOO"}
|
||||
;; #\char → {:cl-type "char" :value "a"}
|
||||
;; #:uninterned → {:cl-type "uninterned" :name "FOO"}
|
||||
;; ratio 1/3 → {:cl-type "ratio" :value "1/3"}
|
||||
;; float 3.14 → {:cl-type "float" :value "3.14"}
|
||||
;; proper list (a b c) → SX list (a b c)
|
||||
;; dotted pair (a . b) → {:cl-type "cons" :car a :cdr b}
|
||||
;; vector #(a b) → {:cl-type "vector" :elements (list a b)}
|
||||
;; 'x → ("QUOTE" x)
|
||||
;; `x → ("QUASIQUOTE" x)
|
||||
;; ,x → ("UNQUOTE" x)
|
||||
;; ,@x → ("UNQUOTE-SPLICING" x)
|
||||
;; #'x → ("FUNCTION" x)
|
||||
;;
|
||||
;; Public API:
|
||||
;; (cl-read src) — parse first form from string, return form
|
||||
;; (cl-read-all src) — parse all top-level forms, return list
|
||||
|
||||
;; ── number conversion ─────────────────────────────────────────────
|
||||
|
||||
(define
|
||||
cl-hex-val
|
||||
(fn
|
||||
(c)
|
||||
(let
|
||||
((o (cl-ord c)))
|
||||
(cond
|
||||
((and (>= o 48) (<= o 57)) (- o 48))
|
||||
((and (>= o 65) (<= o 70)) (+ 10 (- o 65)))
|
||||
((and (>= o 97) (<= o 102)) (+ 10 (- o 97)))
|
||||
(:else 0)))))
|
||||
|
||||
(define
|
||||
cl-parse-radix-str
|
||||
(fn
|
||||
(s radix start)
|
||||
(let
|
||||
((n (string-length s)) (i start) (acc 0))
|
||||
(define
|
||||
loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(< i n)
|
||||
(do
|
||||
(set! acc (+ (* acc radix) (cl-hex-val (substring s i (+ i 1)))))
|
||||
(set! i (+ i 1))
|
||||
(loop)))))
|
||||
(loop)
|
||||
acc)))
|
||||
|
||||
(define
|
||||
cl-convert-integer
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((n (string-length s)) (neg false))
|
||||
(cond
|
||||
((and (> n 2) (= (substring s 0 1) "#"))
|
||||
(let
|
||||
((letter (downcase (substring s 1 2))))
|
||||
(cond
|
||||
((= letter "x") (cl-parse-radix-str s 16 2))
|
||||
((= letter "b") (cl-parse-radix-str s 2 2))
|
||||
((= letter "o") (cl-parse-radix-str s 8 2))
|
||||
(:else (parse-int s 0)))))
|
||||
(:else (parse-int s 0))))))
|
||||
|
||||
;; ── reader ────────────────────────────────────────────────────────
|
||||
|
||||
;; Read one form from token list.
|
||||
;; Returns {:form F :rest remaining-toks} or {:form nil :rest toks :eof true}
|
||||
(define
|
||||
cl-read-form
|
||||
(fn
|
||||
(toks)
|
||||
(if
|
||||
(not toks)
|
||||
{:form nil :rest toks :eof true}
|
||||
(let
|
||||
((tok (nth toks 0)) (nxt (rest toks)))
|
||||
(let
|
||||
((type (get tok "type")) (val (get tok "value")))
|
||||
(cond
|
||||
((= type "eof") {:form nil :rest toks :eof true})
|
||||
((= type "integer") {:form (cl-convert-integer val) :rest nxt})
|
||||
((= type "float") {:form {:cl-type "float" :value val} :rest nxt})
|
||||
((= type "ratio") {:form {:cl-type "ratio" :value val} :rest nxt})
|
||||
((= type "string") {:form val :rest nxt})
|
||||
((= type "char") {:form {:cl-type "char" :value val} :rest nxt})
|
||||
((= type "keyword") {:form {:cl-type "keyword" :name val} :rest nxt})
|
||||
((= type "uninterned") {:form {:cl-type "uninterned" :name val} :rest nxt})
|
||||
((= type "symbol")
|
||||
(cond
|
||||
((= val "NIL") {:form nil :rest nxt})
|
||||
((= val "T") {:form true :rest nxt})
|
||||
(:else {:form val :rest nxt})))
|
||||
;; list forms
|
||||
((= type "lparen") (cl-read-list nxt))
|
||||
((= type "hash-paren") (cl-read-vector nxt))
|
||||
;; reader macros that wrap the next form
|
||||
((= type "quote") (cl-read-wrap "QUOTE" nxt))
|
||||
((= type "backquote") (cl-read-wrap "QUASIQUOTE" nxt))
|
||||
((= type "comma") (cl-read-wrap "UNQUOTE" nxt))
|
||||
((= type "comma-at") (cl-read-wrap "UNQUOTE-SPLICING" nxt))
|
||||
((= type "hash-quote") (cl-read-wrap "FUNCTION" nxt))
|
||||
;; skip unrecognised tokens
|
||||
(:else (cl-read-form nxt))))))))
|
||||
|
||||
;; Wrap next form in a list: (name form)
|
||||
(define
|
||||
cl-read-wrap
|
||||
(fn
|
||||
(name toks)
|
||||
(let
|
||||
((inner (cl-read-form toks)))
|
||||
{:form (list name (get inner "form")) :rest (get inner "rest")})))
|
||||
|
||||
;; Read list forms until ')'; handles dotted pair (a . b)
|
||||
;; Called after consuming '('
|
||||
(define
|
||||
cl-read-list
|
||||
(fn
|
||||
(toks)
|
||||
(let
|
||||
((result (cl-read-list-items toks (list))))
|
||||
{:form (get result "items") :rest (get result "rest")})))
|
||||
|
||||
(define
|
||||
cl-read-list-items
|
||||
(fn
|
||||
(toks acc)
|
||||
(if
|
||||
(not toks)
|
||||
{:items acc :rest toks}
|
||||
(let
|
||||
((tok (nth toks 0)))
|
||||
(let
|
||||
((type (get tok "type")))
|
||||
(cond
|
||||
((= type "eof") {:items acc :rest toks})
|
||||
((= type "rparen") {:items acc :rest (rest toks)})
|
||||
;; dotted pair: read one more form then expect ')'
|
||||
((= type "dot")
|
||||
(let
|
||||
((cdr-result (cl-read-form (rest toks))))
|
||||
(let
|
||||
((cdr-form (get cdr-result "form"))
|
||||
(after-cdr (get cdr-result "rest")))
|
||||
;; skip the closing ')'
|
||||
(let
|
||||
((close (if after-cdr (nth after-cdr 0) nil)))
|
||||
(let
|
||||
((remaining
|
||||
(if
|
||||
(and close (= (get close "type") "rparen"))
|
||||
(rest after-cdr)
|
||||
after-cdr)))
|
||||
;; build dotted structure
|
||||
(let
|
||||
((dotted (cl-build-dotted acc cdr-form)))
|
||||
{:items dotted :rest remaining}))))))
|
||||
(:else
|
||||
(let
|
||||
((item (cl-read-form toks)))
|
||||
(cl-read-list-items
|
||||
(get item "rest")
|
||||
(concat acc (list (get item "form"))))))))))))
|
||||
|
||||
;; Build dotted form: (a b . c) → ((DOTTED a b) . c) style
|
||||
;; In CL (a b c . d) means a proper dotted structure.
|
||||
;; We represent it as {:cl-type "cons" :car a :cdr (list->dotted b c d)}
|
||||
(define
|
||||
cl-build-dotted
|
||||
(fn
|
||||
(head-items tail)
|
||||
(if
|
||||
(= (len head-items) 0)
|
||||
tail
|
||||
(if
|
||||
(= (len head-items) 1)
|
||||
{:cl-type "cons" :car (nth head-items 0) :cdr tail}
|
||||
(let
|
||||
((last-item (nth head-items (- (len head-items) 1)))
|
||||
(but-last (slice head-items 0 (- (len head-items) 1))))
|
||||
{:cl-type "cons"
|
||||
:car (cl-build-dotted but-last (list last-item))
|
||||
:cdr tail})))))
|
||||
|
||||
;; Read vector #(…) elements until ')'
|
||||
(define
|
||||
cl-read-vector
|
||||
(fn
|
||||
(toks)
|
||||
(let
|
||||
((result (cl-read-vector-items toks (list))))
|
||||
{:form {:cl-type "vector" :elements (get result "items")} :rest (get result "rest")})))
|
||||
|
||||
(define
|
||||
cl-read-vector-items
|
||||
(fn
|
||||
(toks acc)
|
||||
(if
|
||||
(not toks)
|
||||
{:items acc :rest toks}
|
||||
(let
|
||||
((tok (nth toks 0)))
|
||||
(let
|
||||
((type (get tok "type")))
|
||||
(cond
|
||||
((= type "eof") {:items acc :rest toks})
|
||||
((= type "rparen") {:items acc :rest (rest toks)})
|
||||
(:else
|
||||
(let
|
||||
((item (cl-read-form toks)))
|
||||
(cl-read-vector-items
|
||||
(get item "rest")
|
||||
(concat acc (list (get item "form"))))))))))))
|
||||
|
||||
;; ── lambda-list parser ───────────────────────────────────────────
|
||||
;;
|
||||
;; (cl-parse-lambda-list forms) — parse a list of CL forms (already read)
|
||||
;; into a structured dict:
|
||||
;; {:required (list sym ...)
|
||||
;; :optional (list {:name N :default D :supplied S} ...)
|
||||
;; :rest nil | "SYM"
|
||||
;; :key (list {:name N :keyword K :default D :supplied S} ...)
|
||||
;; :allow-other-keys false | true
|
||||
;; :aux (list {:name N :init I} ...)}
|
||||
;;
|
||||
;; Symbols arrive as SX strings (upcase). &-markers are strings like "&OPTIONAL".
|
||||
;; Key params: keyword is the upcase name string; caller uses it as :keyword.
|
||||
;; Supplied-p: nil when absent.
|
||||
|
||||
(define
|
||||
cl-parse-opt-spec
|
||||
(fn
|
||||
(spec)
|
||||
(if
|
||||
(list? spec)
|
||||
{:name (nth spec 0)
|
||||
:default (if (> (len spec) 1) (nth spec 1) nil)
|
||||
:supplied (if (> (len spec) 2) (nth spec 2) nil)}
|
||||
{:name spec :default nil :supplied nil})))
|
||||
|
||||
(define
|
||||
cl-parse-key-spec
|
||||
(fn
|
||||
(spec)
|
||||
(if
|
||||
(list? spec)
|
||||
(let
|
||||
((first (nth spec 0)))
|
||||
(if
|
||||
(list? first)
|
||||
;; ((:keyword var) default supplied-p)
|
||||
{:name (nth first 1)
|
||||
:keyword (get first "name")
|
||||
:default (if (> (len spec) 1) (nth spec 1) nil)
|
||||
:supplied (if (> (len spec) 2) (nth spec 2) nil)}
|
||||
;; (var default supplied-p)
|
||||
{:name first
|
||||
:keyword first
|
||||
:default (if (> (len spec) 1) (nth spec 1) nil)
|
||||
:supplied (if (> (len spec) 2) (nth spec 2) nil)}))
|
||||
{:name spec :keyword spec :default nil :supplied nil})))
|
||||
|
||||
(define
|
||||
cl-parse-aux-spec
|
||||
(fn
|
||||
(spec)
|
||||
(if
|
||||
(list? spec)
|
||||
{:name (nth spec 0) :init (if (> (len spec) 1) (nth spec 1) nil)}
|
||||
{:name spec :init nil})))
|
||||
|
||||
(define
|
||||
cl-parse-lambda-list
|
||||
(fn
|
||||
(forms)
|
||||
(let
|
||||
((state "required")
|
||||
(required (list))
|
||||
(optional (list))
|
||||
(rest-name nil)
|
||||
(key (list))
|
||||
(allow-other-keys false)
|
||||
(aux (list)))
|
||||
|
||||
(define
|
||||
scan
|
||||
(fn
|
||||
(items)
|
||||
(when
|
||||
(> (len items) 0)
|
||||
(let
|
||||
((item (nth items 0)) (tail (rest items)))
|
||||
(cond
|
||||
((= item "&OPTIONAL")
|
||||
(do (set! state "optional") (scan tail)))
|
||||
((= item "&REST")
|
||||
(do (set! state "rest") (scan tail)))
|
||||
((= item "&BODY")
|
||||
(do (set! state "rest") (scan tail)))
|
||||
((= item "&KEY")
|
||||
(do (set! state "key") (scan tail)))
|
||||
((= item "&AUX")
|
||||
(do (set! state "aux") (scan tail)))
|
||||
((= item "&ALLOW-OTHER-KEYS")
|
||||
(do (set! allow-other-keys true) (scan tail)))
|
||||
((= state "required")
|
||||
(do (append! required item) (scan tail)))
|
||||
((= state "optional")
|
||||
(do (append! optional (cl-parse-opt-spec item)) (scan tail)))
|
||||
((= state "rest")
|
||||
(do (set! rest-name item) (set! state "done") (scan tail)))
|
||||
((= state "key")
|
||||
(do (append! key (cl-parse-key-spec item)) (scan tail)))
|
||||
((= state "aux")
|
||||
(do (append! aux (cl-parse-aux-spec item)) (scan tail)))
|
||||
(:else (scan tail)))))))
|
||||
|
||||
(scan forms)
|
||||
{:required required
|
||||
:optional optional
|
||||
:rest rest-name
|
||||
:key key
|
||||
:allow-other-keys allow-other-keys
|
||||
:aux aux})))
|
||||
|
||||
;; Convenience: parse lambda list from a CL source string
|
||||
(define
|
||||
cl-parse-lambda-list-str
|
||||
(fn
|
||||
(src)
|
||||
(cl-parse-lambda-list (cl-read src))))
|
||||
|
||||
;; ── public API ────────────────────────────────────────────────────
|
||||
|
||||
(define
|
||||
cl-read
|
||||
(fn
|
||||
(src)
|
||||
(let
|
||||
((toks (cl-tokenize src)))
|
||||
(get (cl-read-form toks) "form"))))
|
||||
|
||||
(define
|
||||
cl-read-all
|
||||
(fn
|
||||
(src)
|
||||
(let
|
||||
((toks (cl-tokenize src)))
|
||||
(define
|
||||
loop
|
||||
(fn
|
||||
(toks acc)
|
||||
(if
|
||||
(or (not toks) (= (get (nth toks 0) "type") "eof"))
|
||||
acc
|
||||
(let
|
||||
((result (cl-read-form toks)))
|
||||
(if
|
||||
(get result "eof")
|
||||
acc
|
||||
(loop (get result "rest") (concat acc (list (get result "form")))))))))
|
||||
(loop toks (list)))))
|
||||
@@ -1,381 +0,0 @@
|
||||
;; Common Lisp tokenizer
|
||||
;;
|
||||
;; Tokens: {:type T :value V :pos P}
|
||||
;;
|
||||
;; Types:
|
||||
;; "symbol" — FOO, PKG:SYM, PKG::SYM, T, NIL (upcase)
|
||||
;; "keyword" — :foo (value is upcase name without colon)
|
||||
;; "integer" — 42, -5, #xFF, #b1010, #o17 (string)
|
||||
;; "float" — 3.14, 1.0e10 (string)
|
||||
;; "ratio" — 1/3 (string "N/D")
|
||||
;; "string" — unescaped content
|
||||
;; "char" — single-character string
|
||||
;; "lparen" "rparen" "quote" "backquote" "comma" "comma-at"
|
||||
;; "hash-quote" — #'
|
||||
;; "hash-paren" — #(
|
||||
;; "uninterned" — #:foo (upcase name)
|
||||
;; "dot" — standalone . (dotted pair separator)
|
||||
;; "eof"
|
||||
|
||||
(define cl-make-tok (fn (type value pos) {:type type :value value :pos pos}))
|
||||
|
||||
;; ── char ordinal table ────────────────────────────────────────────
|
||||
|
||||
(define
|
||||
cl-ord-table
|
||||
(let
|
||||
((t (dict)) (i 0))
|
||||
(define
|
||||
cl-fill
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(< i 128)
|
||||
(do
|
||||
(dict-set! t (char-from-code i) i)
|
||||
(set! i (+ i 1))
|
||||
(cl-fill)))))
|
||||
(cl-fill)
|
||||
t))
|
||||
|
||||
(define cl-ord (fn (c) (or (get cl-ord-table c) 0)))
|
||||
|
||||
;; ── character predicates ──────────────────────────────────────────
|
||||
|
||||
(define cl-digit? (fn (c) (and (>= (cl-ord c) 48) (<= (cl-ord c) 57))))
|
||||
|
||||
(define
|
||||
cl-hex?
|
||||
(fn
|
||||
(c)
|
||||
(or
|
||||
(cl-digit? c)
|
||||
(and (>= (cl-ord c) 65) (<= (cl-ord c) 70))
|
||||
(and (>= (cl-ord c) 97) (<= (cl-ord c) 102)))))
|
||||
|
||||
(define cl-octal? (fn (c) (and (>= (cl-ord c) 48) (<= (cl-ord c) 55))))
|
||||
|
||||
(define cl-binary? (fn (c) (or (= c "0") (= c "1"))))
|
||||
|
||||
(define cl-ws? (fn (c) (or (= c " ") (= c "\t") (= c "\n") (= c "\r"))))
|
||||
|
||||
(define
|
||||
cl-alpha?
|
||||
(fn
|
||||
(c)
|
||||
(or
|
||||
(and (>= (cl-ord c) 65) (<= (cl-ord c) 90))
|
||||
(and (>= (cl-ord c) 97) (<= (cl-ord c) 122)))))
|
||||
|
||||
;; Characters that end a token (whitespace + terminating macro chars)
|
||||
(define
|
||||
cl-terminating?
|
||||
(fn
|
||||
(c)
|
||||
(or
|
||||
(cl-ws? c)
|
||||
(= c "(")
|
||||
(= c ")")
|
||||
(= c "\"")
|
||||
(= c ";")
|
||||
(= c "`")
|
||||
(= c ","))))
|
||||
|
||||
;; Symbol constituent: not terminating, not reader-special
|
||||
(define
|
||||
cl-sym-char?
|
||||
(fn
|
||||
(c)
|
||||
(not
|
||||
(or
|
||||
(cl-terminating? c)
|
||||
(= c "#")
|
||||
(= c "|")
|
||||
(= c "\\")
|
||||
(= c "'")))))
|
||||
|
||||
;; ── named character table ─────────────────────────────────────────
|
||||
|
||||
(define
|
||||
cl-named-chars
|
||||
{:space " "
|
||||
:newline "\n"
|
||||
:tab "\t"
|
||||
:return "\r"
|
||||
:backspace (char-from-code 8)
|
||||
:rubout (char-from-code 127)
|
||||
:delete (char-from-code 127)
|
||||
:escape (char-from-code 27)
|
||||
:altmode (char-from-code 27)
|
||||
:null (char-from-code 0)
|
||||
:nul (char-from-code 0)
|
||||
:page (char-from-code 12)
|
||||
:formfeed (char-from-code 12)})
|
||||
|
||||
;; ── main tokenizer ────────────────────────────────────────────────
|
||||
|
||||
(define
|
||||
cl-tokenize
|
||||
(fn
|
||||
(src)
|
||||
(let
|
||||
((pos 0) (n (string-length src)) (toks (list)))
|
||||
|
||||
(define at (fn () (if (< pos n) (substring src pos (+ pos 1)) nil)))
|
||||
(define peek1 (fn () (if (< (+ pos 1) n) (substring src (+ pos 1) (+ pos 2)) nil)))
|
||||
(define adv (fn () (set! pos (+ pos 1))))
|
||||
|
||||
;; Advance while predicate holds; return substring from start to end
|
||||
(define
|
||||
read-while
|
||||
(fn
|
||||
(pred)
|
||||
(let
|
||||
((start pos))
|
||||
(define
|
||||
rw-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and (at) (pred (at)))
|
||||
(do (adv) (rw-loop)))))
|
||||
(rw-loop)
|
||||
(substring src start pos))))
|
||||
|
||||
(define
|
||||
skip-line
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and (at) (not (= (at) "\n")))
|
||||
(do (adv) (skip-line)))))
|
||||
|
||||
(define
|
||||
skip-block
|
||||
(fn
|
||||
(depth)
|
||||
(when
|
||||
(at)
|
||||
(cond
|
||||
((and (= (at) "#") (= (peek1) "|"))
|
||||
(do (adv) (adv) (skip-block (+ depth 1))))
|
||||
((and (= (at) "|") (= (peek1) "#"))
|
||||
(do
|
||||
(adv)
|
||||
(adv)
|
||||
(when (> depth 1) (skip-block (- depth 1)))))
|
||||
(:else (do (adv) (skip-block depth)))))))
|
||||
|
||||
;; Read string literal — called with pos just past opening "
|
||||
(define
|
||||
read-str
|
||||
(fn
|
||||
(acc)
|
||||
(if
|
||||
(not (at))
|
||||
acc
|
||||
(cond
|
||||
((= (at) "\"") (do (adv) acc))
|
||||
((= (at) "\\")
|
||||
(do
|
||||
(adv)
|
||||
(let
|
||||
((e (at)))
|
||||
(adv)
|
||||
(read-str
|
||||
(str
|
||||
acc
|
||||
(cond
|
||||
((= e "n") "\n")
|
||||
((= e "t") "\t")
|
||||
((= e "r") "\r")
|
||||
((= e "\"") "\"")
|
||||
((= e "\\") "\\")
|
||||
(:else e)))))))
|
||||
(:else
|
||||
(let
|
||||
((c (at)))
|
||||
(adv)
|
||||
(read-str (str acc c))))))))
|
||||
|
||||
;; Read #\ char literal — called with pos just past the backslash
|
||||
(define
|
||||
read-char-lit
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((first (at)))
|
||||
(adv)
|
||||
(let
|
||||
((rest (if (and (at) (cl-alpha? (at))) (read-while cl-alpha?) "")))
|
||||
(if
|
||||
(= rest "")
|
||||
first
|
||||
(let
|
||||
((name (downcase (str first rest))))
|
||||
(or (get cl-named-chars name) first)))))))
|
||||
|
||||
;; Number scanner — called with pos just past first digit(s).
|
||||
;; acc holds what was already consumed (first digit or sign+digit).
|
||||
(define
|
||||
scan-num
|
||||
(fn
|
||||
(p acc)
|
||||
(let
|
||||
((more (read-while cl-digit?)))
|
||||
(set! acc (str acc more))
|
||||
(cond
|
||||
;; ratio N/D
|
||||
((and (at) (= (at) "/") (peek1) (cl-digit? (peek1)))
|
||||
(do
|
||||
(adv)
|
||||
(let
|
||||
((denom (read-while cl-digit?)))
|
||||
{:type "ratio" :value (str acc "/" denom) :pos p})))
|
||||
;; float: decimal point N.M[eE]
|
||||
((and (at) (= (at) ".") (peek1) (cl-digit? (peek1)))
|
||||
(do
|
||||
(adv)
|
||||
(let
|
||||
((frac (read-while cl-digit?)))
|
||||
(set! acc (str acc "." frac))
|
||||
(when
|
||||
(and (at) (or (= (at) "e") (= (at) "E")))
|
||||
(do
|
||||
(set! acc (str acc (at)))
|
||||
(adv)
|
||||
(when
|
||||
(and (at) (or (= (at) "+") (= (at) "-")))
|
||||
(do (set! acc (str acc (at))) (adv)))
|
||||
(set! acc (str acc (read-while cl-digit?)))))
|
||||
{:type "float" :value acc :pos p})))
|
||||
;; float: exponent only NeE
|
||||
((and (at) (or (= (at) "e") (= (at) "E")))
|
||||
(do
|
||||
(set! acc (str acc (at)))
|
||||
(adv)
|
||||
(when
|
||||
(and (at) (or (= (at) "+") (= (at) "-")))
|
||||
(do (set! acc (str acc (at))) (adv)))
|
||||
(set! acc (str acc (read-while cl-digit?)))
|
||||
{:type "float" :value acc :pos p}))
|
||||
(:else {:type "integer" :value acc :pos p})))))
|
||||
|
||||
(define
|
||||
read-radix
|
||||
(fn
|
||||
(letter p)
|
||||
(let
|
||||
((pred
|
||||
(cond
|
||||
((or (= letter "x") (= letter "X")) cl-hex?)
|
||||
((or (= letter "b") (= letter "B")) cl-binary?)
|
||||
((or (= letter "o") (= letter "O")) cl-octal?)
|
||||
(:else cl-digit?))))
|
||||
{:type "integer"
|
||||
:value (str "#" letter (read-while pred))
|
||||
:pos p})))
|
||||
|
||||
(define emit (fn (tok) (append! toks tok)))
|
||||
|
||||
(define
|
||||
scan
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(< pos n)
|
||||
(let
|
||||
((c (at)) (p pos))
|
||||
(cond
|
||||
((cl-ws? c) (do (adv) (scan)))
|
||||
((= c ";") (do (adv) (skip-line) (scan)))
|
||||
((= c "(") (do (adv) (emit (cl-make-tok "lparen" "(" p)) (scan)))
|
||||
((= c ")") (do (adv) (emit (cl-make-tok "rparen" ")" p)) (scan)))
|
||||
((= c "'") (do (adv) (emit (cl-make-tok "quote" "'" p)) (scan)))
|
||||
((= c "`") (do (adv) (emit (cl-make-tok "backquote" "`" p)) (scan)))
|
||||
((= c ",")
|
||||
(do
|
||||
(adv)
|
||||
(if
|
||||
(= (at) "@")
|
||||
(do (adv) (emit (cl-make-tok "comma-at" ",@" p)))
|
||||
(emit (cl-make-tok "comma" "," p)))
|
||||
(scan)))
|
||||
((= c "\"")
|
||||
(do
|
||||
(adv)
|
||||
(emit (cl-make-tok "string" (read-str "") p))
|
||||
(scan)))
|
||||
;; :keyword
|
||||
((= c ":")
|
||||
(do
|
||||
(adv)
|
||||
(emit (cl-make-tok "keyword" (upcase (read-while cl-sym-char?)) p))
|
||||
(scan)))
|
||||
;; dispatch macro #
|
||||
((= c "#")
|
||||
(do
|
||||
(adv)
|
||||
(let
|
||||
((d (at)))
|
||||
(cond
|
||||
((= d "'") (do (adv) (emit (cl-make-tok "hash-quote" "#'" p)) (scan)))
|
||||
((= d "(") (do (adv) (emit (cl-make-tok "hash-paren" "#(" p)) (scan)))
|
||||
((= d ":")
|
||||
(do
|
||||
(adv)
|
||||
(emit
|
||||
(cl-make-tok "uninterned" (upcase (read-while cl-sym-char?)) p))
|
||||
(scan)))
|
||||
((= d "|") (do (adv) (skip-block 1) (scan)))
|
||||
((= d "\\")
|
||||
(do (adv) (emit (cl-make-tok "char" (read-char-lit) p)) (scan)))
|
||||
((or (= d "x") (= d "X"))
|
||||
(do (adv) (emit (read-radix d p)) (scan)))
|
||||
((or (= d "b") (= d "B"))
|
||||
(do (adv) (emit (read-radix d p)) (scan)))
|
||||
((or (= d "o") (= d "O"))
|
||||
(do (adv) (emit (read-radix d p)) (scan)))
|
||||
(:else (scan))))))
|
||||
;; standalone dot, float .5, or symbol starting with dots
|
||||
((= c ".")
|
||||
(do
|
||||
(adv)
|
||||
(cond
|
||||
((or (not (at)) (cl-terminating? (at)))
|
||||
(do (emit (cl-make-tok "dot" "." p)) (scan)))
|
||||
((cl-digit? (at))
|
||||
(do
|
||||
(emit
|
||||
(cl-make-tok "float" (str "0." (read-while cl-digit?)) p))
|
||||
(scan)))
|
||||
(:else
|
||||
(do
|
||||
(emit
|
||||
(cl-make-tok "symbol" (upcase (str "." (read-while cl-sym-char?))) p))
|
||||
(scan))))))
|
||||
;; sign followed by digit → number
|
||||
((and (or (= c "+") (= c "-")) (peek1) (cl-digit? (peek1)))
|
||||
(do
|
||||
(adv)
|
||||
(let
|
||||
((first-d (at)))
|
||||
(adv)
|
||||
(emit (scan-num p (str c first-d))))
|
||||
(scan)))
|
||||
;; decimal digit → number
|
||||
((cl-digit? c)
|
||||
(do
|
||||
(adv)
|
||||
(emit (scan-num p c))
|
||||
(scan)))
|
||||
;; symbol constituent (includes bare +, -, etc.)
|
||||
((cl-sym-char? c)
|
||||
(do
|
||||
(emit (cl-make-tok "symbol" (upcase (read-while cl-sym-char?)) p))
|
||||
(scan)))
|
||||
(:else (do (adv) (scan))))))))
|
||||
|
||||
(scan)
|
||||
(append! toks (cl-make-tok "eof" nil n))
|
||||
toks)))
|
||||
@@ -1,100 +0,0 @@
|
||||
#!/usr/bin/env bash
|
||||
# Common Lisp on SX test runner — pipes directly to sx_server.exe
|
||||
#
|
||||
# Usage:
|
||||
# bash lib/common-lisp/test.sh # all tests
|
||||
# bash lib/common-lisp/test.sh -v # verbose
|
||||
# bash lib/common-lisp/test.sh tests/read.sx # one file
|
||||
|
||||
set -euo pipefail
|
||||
cd "$(git rev-parse --show-toplevel)"
|
||||
|
||||
SX_SERVER="hosts/ocaml/_build/default/bin/sx_server.exe"
|
||||
if [ ! -x "$SX_SERVER" ]; then
|
||||
MAIN_ROOT=$(git worktree list | awk 'NR==1{print $1}')
|
||||
if [ -x "$MAIN_ROOT/$SX_SERVER" ]; then
|
||||
SX_SERVER="$MAIN_ROOT/$SX_SERVER"
|
||||
else
|
||||
echo "ERROR: sx_server.exe not found"
|
||||
exit 1
|
||||
fi
|
||||
fi
|
||||
|
||||
VERBOSE=""
|
||||
FILES=()
|
||||
for arg in "$@"; do
|
||||
case "$arg" in
|
||||
-v|--verbose) VERBOSE=1 ;;
|
||||
*) FILES+=("$arg") ;;
|
||||
esac
|
||||
done
|
||||
|
||||
if [ ${#FILES[@]} -eq 0 ]; then
|
||||
mapfile -t FILES < <(find lib/common-lisp/tests -maxdepth 2 -name '*.sx' | sort)
|
||||
fi
|
||||
|
||||
TOTAL_PASS=0
|
||||
TOTAL_FAIL=0
|
||||
FAILED_FILES=()
|
||||
|
||||
for FILE in "${FILES[@]}"; do
|
||||
[ -f "$FILE" ] || { echo "skip $FILE (not found)"; continue; }
|
||||
TMPFILE=$(mktemp)
|
||||
cat > "$TMPFILE" <<EPOCHS
|
||||
(epoch 1)
|
||||
(load "lib/common-lisp/reader.sx")
|
||||
(load "lib/common-lisp/parser.sx")
|
||||
(epoch 2)
|
||||
(load "$FILE")
|
||||
(epoch 3)
|
||||
(eval "(list cl-test-pass cl-test-fail)")
|
||||
EPOCHS
|
||||
|
||||
OUTPUT=$(timeout 60 "$SX_SERVER" < "$TMPFILE" 2>&1 || true)
|
||||
rm -f "$TMPFILE"
|
||||
|
||||
LINE=$(echo "$OUTPUT" | awk '/^\(ok-len 3 / {getline; print; exit}' || true)
|
||||
if [ -z "$LINE" ]; then
|
||||
LINE=$(echo "$OUTPUT" | grep -E '^\(ok 3 \([0-9]+ [0-9]+\)\)' | tail -1 \
|
||||
| sed -E 's/^\(ok 3 //; s/\)$//' || true)
|
||||
fi
|
||||
if [ -z "$LINE" ]; then
|
||||
echo "✗ $FILE: could not extract summary"
|
||||
echo "$OUTPUT" | tail -20
|
||||
TOTAL_FAIL=$((TOTAL_FAIL + 1))
|
||||
FAILED_FILES+=("$FILE")
|
||||
continue
|
||||
fi
|
||||
P=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\1/')
|
||||
F=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\2/')
|
||||
TOTAL_PASS=$((TOTAL_PASS + P))
|
||||
TOTAL_FAIL=$((TOTAL_FAIL + F))
|
||||
if [ "$F" -gt 0 ]; then
|
||||
FAILED_FILES+=("$FILE")
|
||||
printf '✗ %-40s %d/%d\n' "$FILE" "$P" "$((P+F))"
|
||||
TMPFILE2=$(mktemp)
|
||||
cat > "$TMPFILE2" <<EPOCHS
|
||||
(epoch 1)
|
||||
(load "lib/common-lisp/reader.sx")
|
||||
(load "lib/common-lisp/parser.sx")
|
||||
(epoch 2)
|
||||
(load "$FILE")
|
||||
(epoch 3)
|
||||
(eval "(map (fn (f) (get f \"name\")) cl-test-fails)")
|
||||
EPOCHS
|
||||
FAILS=$(timeout 60 "$SX_SERVER" < "$TMPFILE2" 2>&1 | grep -E '^\(ok 3 ' || true)
|
||||
rm -f "$TMPFILE2"
|
||||
echo " $FAILS"
|
||||
elif [ "$VERBOSE" = "1" ]; then
|
||||
printf '✓ %-40s %d passed\n' "$FILE" "$P"
|
||||
fi
|
||||
done
|
||||
|
||||
TOTAL=$((TOTAL_PASS + TOTAL_FAIL))
|
||||
if [ $TOTAL_FAIL -eq 0 ]; then
|
||||
echo "✓ $TOTAL_PASS/$TOTAL common-lisp-on-sx tests passed"
|
||||
else
|
||||
echo "✗ $TOTAL_PASS/$TOTAL passed, $TOTAL_FAIL failed in: ${FAILED_FILES[*]}"
|
||||
fi
|
||||
|
||||
[ $TOTAL_FAIL -eq 0 ]
|
||||
@@ -1,285 +0,0 @@
|
||||
;; CL evaluator tests
|
||||
|
||||
(define cl-test-pass 0)
|
||||
(define cl-test-fail 0)
|
||||
(define cl-test-fails (list))
|
||||
|
||||
(define
|
||||
cl-deep=
|
||||
(fn
|
||||
(a b)
|
||||
(cond
|
||||
((= a b) true)
|
||||
((and (dict? a) (dict? b))
|
||||
(let
|
||||
((ak (keys a)) (bk (keys b)))
|
||||
(if
|
||||
(not (= (len ak) (len bk)))
|
||||
false
|
||||
(every?
|
||||
(fn (k) (and (has-key? b k) (cl-deep= (get a k) (get b k))))
|
||||
ak))))
|
||||
((and (list? a) (list? b))
|
||||
(if
|
||||
(not (= (len a) (len b)))
|
||||
false
|
||||
(let
|
||||
((i 0) (ok true))
|
||||
(define
|
||||
chk
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and ok (< i (len a)))
|
||||
(do
|
||||
(when
|
||||
(not (cl-deep= (nth a i) (nth b i)))
|
||||
(set! ok false))
|
||||
(set! i (+ i 1))
|
||||
(chk)))))
|
||||
(chk)
|
||||
ok)))
|
||||
(:else false))))
|
||||
|
||||
(define
|
||||
cl-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(cl-deep= actual expected)
|
||||
(set! cl-test-pass (+ cl-test-pass 1))
|
||||
(do
|
||||
(set! cl-test-fail (+ cl-test-fail 1))
|
||||
(append! cl-test-fails {:name name :expected expected :actual actual})))))
|
||||
|
||||
;; Convenience: evaluate CL string with fresh env each time
|
||||
(define ev (fn (src) (cl-eval-str src (cl-make-env))))
|
||||
(define evall (fn (src) (cl-eval-all-str src (cl-make-env))))
|
||||
|
||||
;; ── self-evaluating literals ──────────────────────────────────────
|
||||
|
||||
(cl-test "lit: nil" (ev "nil") nil)
|
||||
(cl-test "lit: t" (ev "t") true)
|
||||
(cl-test "lit: integer" (ev "42") 42)
|
||||
(cl-test "lit: negative" (ev "-7") -7)
|
||||
(cl-test "lit: zero" (ev "0") 0)
|
||||
(cl-test "lit: string" (ev "\"hello\"") "hello")
|
||||
(cl-test "lit: empty string" (ev "\"\"") "")
|
||||
(cl-test "lit: keyword type" (get (ev ":foo") "cl-type") "keyword")
|
||||
(cl-test "lit: keyword name" (get (ev ":foo") "name") "FOO")
|
||||
(cl-test "lit: float type" (get (ev "3.14") "cl-type") "float")
|
||||
|
||||
;; ── QUOTE ─────────────────────────────────────────────────────────
|
||||
|
||||
(cl-test "quote: symbol" (ev "'x") "X")
|
||||
(cl-test "quote: list" (ev "'(a b c)") (list "A" "B" "C"))
|
||||
(cl-test "quote: nil" (ev "'nil") nil)
|
||||
(cl-test "quote: integer" (ev "'42") 42)
|
||||
(cl-test "quote: nested" (ev "'(a (b c))") (list "A" (list "B" "C")))
|
||||
|
||||
;; ── IF ────────────────────────────────────────────────────────────
|
||||
|
||||
(cl-test "if: true branch" (ev "(if t 1 2)") 1)
|
||||
(cl-test "if: false branch" (ev "(if nil 1 2)") 2)
|
||||
(cl-test "if: no else nil" (ev "(if nil 99)") nil)
|
||||
(cl-test "if: number truthy" (ev "(if 0 'yes 'no)") "YES")
|
||||
(cl-test "if: empty string truthy" (ev "(if \"\" 'yes 'no)") "YES")
|
||||
(cl-test "if: nested" (ev "(if t (if nil 1 2) 3)") 2)
|
||||
|
||||
;; ── PROGN ────────────────────────────────────────────────────────
|
||||
|
||||
(cl-test "progn: single" (ev "(progn 42)") 42)
|
||||
(cl-test "progn: multiple" (ev "(progn 1 2 3)") 3)
|
||||
(cl-test "progn: nil last" (ev "(progn 1 nil)") nil)
|
||||
|
||||
;; ── AND / OR ─────────────────────────────────────────────────────
|
||||
|
||||
(cl-test "and: empty" (ev "(and)") true)
|
||||
(cl-test "and: all true" (ev "(and 1 2 3)") 3)
|
||||
(cl-test "and: short-circuit" (ev "(and nil 99)") nil)
|
||||
(cl-test "and: returns last" (ev "(and 1 2)") 2)
|
||||
(cl-test "or: empty" (ev "(or)") nil)
|
||||
(cl-test "or: first truthy" (ev "(or 1 2)") 1)
|
||||
(cl-test "or: all nil" (ev "(or nil nil)") nil)
|
||||
(cl-test "or: short-circuit" (ev "(or nil 42)") 42)
|
||||
|
||||
;; ── COND ─────────────────────────────────────────────────────────
|
||||
|
||||
(cl-test "cond: first match" (ev "(cond (t 1) (t 2))") 1)
|
||||
(cl-test "cond: second match" (ev "(cond (nil 1) (t 2))") 2)
|
||||
(cl-test "cond: no match" (ev "(cond (nil 1) (nil 2))") nil)
|
||||
(cl-test "cond: returns test value" (ev "(cond (42))") 42)
|
||||
|
||||
;; ── WHEN / UNLESS ─────────────────────────────────────────────────
|
||||
|
||||
(cl-test "when: true" (ev "(when t 1 2 3)") 3)
|
||||
(cl-test "when: nil" (ev "(when nil 99)") nil)
|
||||
(cl-test "unless: nil runs" (ev "(unless nil 42)") 42)
|
||||
(cl-test "unless: true skips" (ev "(unless t 99)") nil)
|
||||
|
||||
;; ── LET ──────────────────────────────────────────────────────────
|
||||
|
||||
(cl-test "let: empty bindings" (ev "(let () 42)") 42)
|
||||
(cl-test "let: single binding" (ev "(let ((x 5)) x)") 5)
|
||||
(cl-test "let: two bindings" (ev "(let ((x 3) (y 4)) (+ x y))") 7)
|
||||
(cl-test "let: parallel" (ev "(let ((x 1)) (let ((x 2) (y x)) y))") 1)
|
||||
(cl-test "let: nested" (ev "(let ((x 1)) (let ((y 2)) (+ x y)))") 3)
|
||||
(cl-test "let: progn body" (ev "(let ((x 5)) (+ x 1) (* x 2))") 10)
|
||||
(cl-test "let: bare name nil" (ev "(let (x) x)") nil)
|
||||
|
||||
;; ── LET* ─────────────────────────────────────────────────────────
|
||||
|
||||
(cl-test "let*: sequential" (ev "(let* ((x 1) (y (+ x 1))) y)") 2)
|
||||
(cl-test "let*: chain" (ev "(let* ((a 2) (b (* a 3)) (c (+ b 1))) c)") 7)
|
||||
(cl-test "let*: shadow" (ev "(let ((x 1)) (let* ((x 2) (y x)) y))") 2)
|
||||
|
||||
;; ── SETQ / SETF ──────────────────────────────────────────────────
|
||||
|
||||
(cl-test "setq: basic" (ev "(let ((x 0)) (setq x 5) x)") 5)
|
||||
(cl-test "setq: returns value" (ev "(let ((x 0)) (setq x 99))") 99)
|
||||
(cl-test "setf: basic" (ev "(let ((x 0)) (setf x 7) x)") 7)
|
||||
|
||||
;; ── LAMBDA ────────────────────────────────────────────────────────
|
||||
|
||||
(cl-test "lambda: call" (ev "((lambda (x) x) 42)") 42)
|
||||
(cl-test "lambda: multi-arg" (ev "((lambda (x y) (+ x y)) 3 4)") 7)
|
||||
(cl-test "lambda: closure" (ev "(let ((n 10)) ((lambda (x) (+ x n)) 5))") 15)
|
||||
(cl-test "lambda: rest arg"
|
||||
(ev "((lambda (x &rest xs) (cons x xs)) 1 2 3)")
|
||||
{:cl-type "cons" :car 1 :cdr (list 2 3)})
|
||||
(cl-test "lambda: optional no default"
|
||||
(ev "((lambda (&optional x) x))")
|
||||
nil)
|
||||
(cl-test "lambda: optional with arg"
|
||||
(ev "((lambda (&optional (x 99)) x) 42)")
|
||||
42)
|
||||
(cl-test "lambda: optional default used"
|
||||
(ev "((lambda (&optional (x 7)) x))")
|
||||
7)
|
||||
|
||||
;; ── FUNCTION ─────────────────────────────────────────────────────
|
||||
|
||||
(cl-test "function: lambda" (get (ev "(function (lambda (x) x))") "cl-type") "function")
|
||||
|
||||
;; ── DEFUN ────────────────────────────────────────────────────────
|
||||
|
||||
(cl-test "defun: returns name" (evall "(defun sq (x) (* x x))") "SQ")
|
||||
(cl-test "defun: call" (evall "(defun sq (x) (* x x)) (sq 5)") 25)
|
||||
(cl-test "defun: multi-arg" (evall "(defun add (x y) (+ x y)) (add 3 4)") 7)
|
||||
(cl-test "defun: recursive factorial"
|
||||
(evall "(defun fact (n) (if (<= n 1) 1 (* n (fact (- n 1))))) (fact 5)")
|
||||
120)
|
||||
(cl-test "defun: multiple calls"
|
||||
(evall "(defun double (x) (* x 2)) (+ (double 3) (double 5))")
|
||||
16)
|
||||
|
||||
;; ── FLET ─────────────────────────────────────────────────────────
|
||||
|
||||
(cl-test "flet: basic"
|
||||
(ev "(flet ((double (x) (* x 2))) (double 5))")
|
||||
10)
|
||||
(cl-test "flet: sees outer vars"
|
||||
(ev "(let ((n 3)) (flet ((add-n (x) (+ x n))) (add-n 7)))")
|
||||
10)
|
||||
(cl-test "flet: non-recursive"
|
||||
(ev "(flet ((f (x) (+ x 1))) (flet ((f (x) (f (f x)))) (f 5)))")
|
||||
7)
|
||||
|
||||
;; ── LABELS ────────────────────────────────────────────────────────
|
||||
|
||||
(cl-test "labels: basic"
|
||||
(ev "(labels ((greet (x) x)) (greet 42))")
|
||||
42)
|
||||
(cl-test "labels: recursive"
|
||||
(ev "(labels ((count (n) (if (<= n 0) 0 (+ 1 (count (- n 1)))))) (count 5))")
|
||||
5)
|
||||
(cl-test "labels: mutual recursion"
|
||||
(ev "(labels
|
||||
((even? (n) (if (= n 0) t (odd? (- n 1))))
|
||||
(odd? (n) (if (= n 0) nil (even? (- n 1)))))
|
||||
(list (even? 4) (odd? 3)))")
|
||||
(list true true))
|
||||
|
||||
;; ── THE / LOCALLY / EVAL-WHEN ────────────────────────────────────
|
||||
|
||||
(cl-test "the: passthrough" (ev "(the integer 42)") 42)
|
||||
(cl-test "the: string" (ev "(the string \"hi\")") "hi")
|
||||
(cl-test "locally: body" (ev "(locally 1 2 3)") 3)
|
||||
(cl-test "eval-when: execute" (ev "(eval-when (:execute) 99)") 99)
|
||||
(cl-test "eval-when: no execute" (ev "(eval-when (:compile-toplevel) 99)") nil)
|
||||
|
||||
;; ── DEFVAR / DEFPARAMETER ────────────────────────────────────────
|
||||
|
||||
(cl-test "defvar: returns name" (evall "(defvar *x* 10)") "*X*")
|
||||
(cl-test "defparameter: sets value" (evall "(defparameter *y* 42) *y*") 42)
|
||||
(cl-test "defvar: no reinit" (evall "(defvar *z* 1) (defvar *z* 99) *z*") 1)
|
||||
|
||||
;; ── built-in arithmetic ───────────────────────────────────────────
|
||||
|
||||
(cl-test "arith: +" (ev "(+ 1 2 3)") 6)
|
||||
(cl-test "arith: + zero" (ev "(+)") 0)
|
||||
(cl-test "arith: -" (ev "(- 10 3 2)") 5)
|
||||
(cl-test "arith: - negate" (ev "(- 5)") -5)
|
||||
(cl-test "arith: *" (ev "(* 2 3 4)") 24)
|
||||
(cl-test "arith: * one" (ev "(*)") 1)
|
||||
(cl-test "arith: /" (ev "(/ 12 3)") 4)
|
||||
(cl-test "arith: max" (ev "(max 3 1 4 1 5)") 5)
|
||||
(cl-test "arith: min" (ev "(min 3 1 4 1 5)") 1)
|
||||
(cl-test "arith: abs neg" (ev "(abs -7)") 7)
|
||||
(cl-test "arith: abs pos" (ev "(abs 7)") 7)
|
||||
|
||||
;; ── built-in comparisons ──────────────────────────────────────────
|
||||
|
||||
(cl-test "cmp: = true" (ev "(= 3 3)") true)
|
||||
(cl-test "cmp: = false" (ev "(= 3 4)") nil)
|
||||
(cl-test "cmp: /=" (ev "(/= 3 4)") true)
|
||||
(cl-test "cmp: <" (ev "(< 1 2)") true)
|
||||
(cl-test "cmp: > false" (ev "(> 1 2)") nil)
|
||||
(cl-test "cmp: <=" (ev "(<= 2 2)") true)
|
||||
|
||||
;; ── built-in predicates ───────────────────────────────────────────
|
||||
|
||||
(cl-test "pred: null nil" (ev "(null nil)") true)
|
||||
(cl-test "pred: null non-nil" (ev "(null 5)") nil)
|
||||
(cl-test "pred: not nil" (ev "(not nil)") true)
|
||||
(cl-test "pred: not truthy" (ev "(not 5)") nil)
|
||||
(cl-test "pred: numberp" (ev "(numberp 5)") true)
|
||||
(cl-test "pred: numberp str" (ev "(numberp \"x\")") nil)
|
||||
(cl-test "pred: stringp" (ev "(stringp \"hello\")") true)
|
||||
(cl-test "pred: listp list" (ev "(listp '(1))") true)
|
||||
(cl-test "pred: listp nil" (ev "(listp nil)") true)
|
||||
(cl-test "pred: zerop" (ev "(zerop 0)") true)
|
||||
(cl-test "pred: plusp" (ev "(plusp 3)") true)
|
||||
(cl-test "pred: evenp" (ev "(evenp 4)") true)
|
||||
(cl-test "pred: oddp" (ev "(oddp 3)") true)
|
||||
|
||||
;; ── built-in list ops ─────────────────────────────────────────────
|
||||
|
||||
(cl-test "list: car" (ev "(car '(1 2 3))") 1)
|
||||
(cl-test "list: cdr" (ev "(cdr '(1 2 3))") (list 2 3))
|
||||
(cl-test "list: cons" (get (ev "(cons 1 2)") "car") 1)
|
||||
(cl-test "list: list fn" (ev "(list 1 2 3)") (list 1 2 3))
|
||||
(cl-test "list: length" (ev "(length '(a b c))") 3)
|
||||
(cl-test "list: length nil" (ev "(length nil)") 0)
|
||||
(cl-test "list: append" (ev "(append '(1 2) '(3 4))") (list 1 2 3 4))
|
||||
(cl-test "list: first" (ev "(first '(10 20 30))") 10)
|
||||
(cl-test "list: second" (ev "(second '(10 20 30))") 20)
|
||||
(cl-test "list: third" (ev "(third '(10 20 30))") 30)
|
||||
(cl-test "list: rest" (ev "(rest '(1 2 3))") (list 2 3))
|
||||
(cl-test "list: nth" (ev "(nth 1 '(a b c))") "B")
|
||||
(cl-test "list: reverse" (ev "(reverse '(1 2 3))") (list 3 2 1))
|
||||
|
||||
;; ── FUNCALL / APPLY / MAPCAR ─────────────────────────────────────
|
||||
|
||||
(cl-test "funcall: lambda"
|
||||
(ev "(funcall (lambda (x) (* x x)) 5)")
|
||||
25)
|
||||
(cl-test "apply: basic"
|
||||
(ev "(apply #'+ '(1 2 3))")
|
||||
6)
|
||||
(cl-test "apply: leading args"
|
||||
(ev "(apply #'+ 1 2 '(3 4))")
|
||||
10)
|
||||
(cl-test "mapcar: basic"
|
||||
(ev "(mapcar (lambda (x) (* x 2)) '(1 2 3))")
|
||||
(list 2 4 6))
|
||||
@@ -1,204 +0,0 @@
|
||||
;; Lambda list parser tests
|
||||
|
||||
(define cl-test-pass 0)
|
||||
(define cl-test-fail 0)
|
||||
(define cl-test-fails (list))
|
||||
|
||||
;; Deep structural equality for dicts and lists
|
||||
(define
|
||||
cl-deep=
|
||||
(fn
|
||||
(a b)
|
||||
(cond
|
||||
((= a b) true)
|
||||
((and (dict? a) (dict? b))
|
||||
(let
|
||||
((ak (keys a)) (bk (keys b)))
|
||||
(if
|
||||
(not (= (len ak) (len bk)))
|
||||
false
|
||||
(every?
|
||||
(fn (k) (and (has-key? b k) (cl-deep= (get a k) (get b k))))
|
||||
ak))))
|
||||
((and (list? a) (list? b))
|
||||
(if
|
||||
(not (= (len a) (len b)))
|
||||
false
|
||||
(let
|
||||
((i 0) (ok true))
|
||||
(define
|
||||
chk
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and ok (< i (len a)))
|
||||
(do
|
||||
(when
|
||||
(not (cl-deep= (nth a i) (nth b i)))
|
||||
(set! ok false))
|
||||
(set! i (+ i 1))
|
||||
(chk)))))
|
||||
(chk)
|
||||
ok)))
|
||||
(:else false))))
|
||||
|
||||
(define
|
||||
cl-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(cl-deep= actual expected)
|
||||
(set! cl-test-pass (+ cl-test-pass 1))
|
||||
(do
|
||||
(set! cl-test-fail (+ cl-test-fail 1))
|
||||
(append! cl-test-fails {:name name :expected expected :actual actual})))))
|
||||
|
||||
;; Helper: parse lambda list from string "(x y ...)"
|
||||
(define ll (fn (src) (cl-parse-lambda-list-str src)))
|
||||
(define ll-req (fn (src) (get (ll src) "required")))
|
||||
(define ll-opt (fn (src) (get (ll src) "optional")))
|
||||
(define ll-rest (fn (src) (get (ll src) "rest")))
|
||||
(define ll-key (fn (src) (get (ll src) "key")))
|
||||
(define ll-aok (fn (src) (get (ll src) "allow-other-keys")))
|
||||
(define ll-aux (fn (src) (get (ll src) "aux")))
|
||||
|
||||
;; ── required parameters ───────────────────────────────────────────
|
||||
|
||||
(cl-test "required: empty" (ll-req "()") (list))
|
||||
(cl-test "required: one" (ll-req "(x)") (list "X"))
|
||||
(cl-test "required: two" (ll-req "(x y)") (list "X" "Y"))
|
||||
(cl-test "required: three" (ll-req "(a b c)") (list "A" "B" "C"))
|
||||
(cl-test "required: upcased" (ll-req "(foo bar)") (list "FOO" "BAR"))
|
||||
|
||||
;; ── &optional ─────────────────────────────────────────────────────
|
||||
|
||||
(cl-test "optional: none" (ll-opt "(x)") (list))
|
||||
|
||||
(cl-test
|
||||
"optional: bare symbol"
|
||||
(ll-opt "(x &optional z)")
|
||||
(list {:name "Z" :default nil :supplied nil}))
|
||||
|
||||
(cl-test
|
||||
"optional: with default"
|
||||
(ll-opt "(x &optional (z 0))")
|
||||
(list {:name "Z" :default 0 :supplied nil}))
|
||||
|
||||
(cl-test
|
||||
"optional: with supplied-p"
|
||||
(ll-opt "(x &optional (z 0 z-p))")
|
||||
(list {:name "Z" :default 0 :supplied "Z-P"}))
|
||||
|
||||
(cl-test
|
||||
"optional: two params"
|
||||
(ll-opt "(&optional a (b 1))")
|
||||
(list {:name "A" :default nil :supplied nil} {:name "B" :default 1 :supplied nil}))
|
||||
|
||||
(cl-test
|
||||
"optional: string default"
|
||||
(ll-opt "(&optional (name \"world\"))")
|
||||
(list {:name "NAME" :default {:cl-type "string" :value "world"} :supplied nil}))
|
||||
|
||||
;; ── &rest ─────────────────────────────────────────────────────────
|
||||
|
||||
(cl-test "rest: none" (ll-rest "(x)") nil)
|
||||
(cl-test "rest: present" (ll-rest "(x &rest args)") "ARGS")
|
||||
(cl-test "rest: with required" (ll-rest "(a b &rest tail)") "TAIL")
|
||||
|
||||
;; &body is an alias for &rest
|
||||
(cl-test "body: alias for rest" (ll-rest "(&body forms)") "FORMS")
|
||||
|
||||
;; rest doesn't consume required params
|
||||
(cl-test "rest: required still there" (ll-req "(a b &rest rest)") (list "A" "B"))
|
||||
|
||||
;; ── &key ──────────────────────────────────────────────────────────
|
||||
|
||||
(cl-test "key: none" (ll-key "(x)") (list))
|
||||
|
||||
(cl-test
|
||||
"key: bare symbol"
|
||||
(ll-key "(&key x)")
|
||||
(list {:name "X" :keyword "X" :default nil :supplied nil}))
|
||||
|
||||
(cl-test
|
||||
"key: with default"
|
||||
(ll-key "(&key (x 42))")
|
||||
(list {:name "X" :keyword "X" :default 42 :supplied nil}))
|
||||
|
||||
(cl-test
|
||||
"key: with supplied-p"
|
||||
(ll-key "(&key (x 42 x-p))")
|
||||
(list {:name "X" :keyword "X" :default 42 :supplied "X-P"}))
|
||||
|
||||
(cl-test
|
||||
"key: two params"
|
||||
(ll-key "(&key a b)")
|
||||
(list
|
||||
{:name "A" :keyword "A" :default nil :supplied nil}
|
||||
{:name "B" :keyword "B" :default nil :supplied nil}))
|
||||
|
||||
;; ── &allow-other-keys ─────────────────────────────────────────────
|
||||
|
||||
(cl-test "aok: absent" (ll-aok "(x)") false)
|
||||
(cl-test "aok: present" (ll-aok "(&key x &allow-other-keys)") true)
|
||||
|
||||
;; ── &aux ──────────────────────────────────────────────────────────
|
||||
|
||||
(cl-test "aux: none" (ll-aux "(x)") (list))
|
||||
|
||||
(cl-test
|
||||
"aux: bare symbol"
|
||||
(ll-aux "(&aux temp)")
|
||||
(list {:name "TEMP" :init nil}))
|
||||
|
||||
(cl-test
|
||||
"aux: with init"
|
||||
(ll-aux "(&aux (count 0))")
|
||||
(list {:name "COUNT" :init 0}))
|
||||
|
||||
(cl-test
|
||||
"aux: two vars"
|
||||
(ll-aux "(&aux a (b 1))")
|
||||
(list {:name "A" :init nil} {:name "B" :init 1}))
|
||||
|
||||
;; ── combined ──────────────────────────────────────────────────────
|
||||
|
||||
(cl-test
|
||||
"combined: full lambda list"
|
||||
(let
|
||||
((parsed (ll "(x y &optional (z 0 z-p) &rest args &key a (b nil b-p) &aux temp)")))
|
||||
(list
|
||||
(get parsed "required")
|
||||
(get (nth (get parsed "optional") 0) "name")
|
||||
(get (nth (get parsed "optional") 0) "default")
|
||||
(get (nth (get parsed "optional") 0) "supplied")
|
||||
(get parsed "rest")
|
||||
(get (nth (get parsed "key") 0) "name")
|
||||
(get (nth (get parsed "key") 1) "supplied")
|
||||
(get (nth (get parsed "aux") 0) "name")))
|
||||
(list
|
||||
(list "X" "Y")
|
||||
"Z"
|
||||
0
|
||||
"Z-P"
|
||||
"ARGS"
|
||||
"A"
|
||||
"B-P"
|
||||
"TEMP"))
|
||||
|
||||
(cl-test
|
||||
"combined: required only stops before &"
|
||||
(ll-req "(a b &optional c)")
|
||||
(list "A" "B"))
|
||||
|
||||
(cl-test
|
||||
"combined: required only with &key"
|
||||
(ll-req "(x &key y)")
|
||||
(list "X"))
|
||||
|
||||
(cl-test
|
||||
"combined: &rest and &key together"
|
||||
(let
|
||||
((parsed (ll "(&rest args &key verbose)")))
|
||||
(list (get parsed "rest") (get (nth (get parsed "key") 0) "name")))
|
||||
(list "ARGS" "VERBOSE"))
|
||||
@@ -1,160 +0,0 @@
|
||||
;; Common Lisp reader/parser tests
|
||||
|
||||
(define cl-test-pass 0)
|
||||
(define cl-test-fail 0)
|
||||
(define cl-test-fails (list))
|
||||
|
||||
(define
|
||||
cl-deep=
|
||||
(fn
|
||||
(a b)
|
||||
(cond
|
||||
((= a b) true)
|
||||
((and (dict? a) (dict? b))
|
||||
(let
|
||||
((ak (keys a)) (bk (keys b)))
|
||||
(if
|
||||
(not (= (len ak) (len bk)))
|
||||
false
|
||||
(every?
|
||||
(fn (k) (and (has-key? b k) (cl-deep= (get a k) (get b k))))
|
||||
ak))))
|
||||
((and (list? a) (list? b))
|
||||
(if
|
||||
(not (= (len a) (len b)))
|
||||
false
|
||||
(let
|
||||
((i 0) (ok true))
|
||||
(define
|
||||
chk
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and ok (< i (len a)))
|
||||
(do
|
||||
(when
|
||||
(not (cl-deep= (nth a i) (nth b i)))
|
||||
(set! ok false))
|
||||
(set! i (+ i 1))
|
||||
(chk)))))
|
||||
(chk)
|
||||
ok)))
|
||||
(:else false))))
|
||||
|
||||
(define
|
||||
cl-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(cl-deep= actual expected)
|
||||
(set! cl-test-pass (+ cl-test-pass 1))
|
||||
(do
|
||||
(set! cl-test-fail (+ cl-test-fail 1))
|
||||
(append! cl-test-fails {:name name :expected expected :actual actual})))))
|
||||
|
||||
;; ── atoms ─────────────────────────────────────────────────────────
|
||||
|
||||
(cl-test "integer: 42" (cl-read "42") 42)
|
||||
(cl-test "integer: 0" (cl-read "0") 0)
|
||||
(cl-test "integer: negative" (cl-read "-5") -5)
|
||||
(cl-test "integer: positive sign" (cl-read "+3") 3)
|
||||
(cl-test "integer: hex #xFF" (cl-read "#xFF") 255)
|
||||
(cl-test "integer: hex #xAB" (cl-read "#xAB") 171)
|
||||
(cl-test "integer: binary #b1010" (cl-read "#b1010") 10)
|
||||
(cl-test "integer: octal #o17" (cl-read "#o17") 15)
|
||||
|
||||
(cl-test "float: type" (get (cl-read "3.14") "cl-type") "float")
|
||||
(cl-test "float: value" (get (cl-read "3.14") "value") "3.14")
|
||||
(cl-test "float: neg" (get (cl-read "-2.5") "value") "-2.5")
|
||||
(cl-test "float: exp" (get (cl-read "1.0e10") "value") "1.0e10")
|
||||
|
||||
(cl-test "ratio: type" (get (cl-read "1/3") "cl-type") "ratio")
|
||||
(cl-test "ratio: value" (get (cl-read "1/3") "value") "1/3")
|
||||
(cl-test "ratio: 22/7" (get (cl-read "22/7") "value") "22/7")
|
||||
|
||||
(cl-test "string: basic" (cl-read "\"hello\"") {:cl-type "string" :value "hello"})
|
||||
(cl-test "string: empty" (cl-read "\"\"") {:cl-type "string" :value ""})
|
||||
(cl-test "string: with escape" (cl-read "\"a\\nb\"") {:cl-type "string" :value "a\nb"})
|
||||
|
||||
(cl-test "symbol: foo" (cl-read "foo") "FOO")
|
||||
(cl-test "symbol: BAR" (cl-read "BAR") "BAR")
|
||||
(cl-test "symbol: pkg:sym" (cl-read "cl:car") "CL:CAR")
|
||||
(cl-test "symbol: pkg::sym" (cl-read "pkg::foo") "PKG::FOO")
|
||||
|
||||
(cl-test "nil: symbol" (cl-read "nil") nil)
|
||||
(cl-test "nil: uppercase" (cl-read "NIL") nil)
|
||||
(cl-test "t: symbol" (cl-read "t") true)
|
||||
(cl-test "t: uppercase" (cl-read "T") true)
|
||||
|
||||
(cl-test "keyword: type" (get (cl-read ":foo") "cl-type") "keyword")
|
||||
(cl-test "keyword: name" (get (cl-read ":foo") "name") "FOO")
|
||||
(cl-test "keyword: :test" (get (cl-read ":test") "name") "TEST")
|
||||
|
||||
(cl-test "char: type" (get (cl-read "#\\a") "cl-type") "char")
|
||||
(cl-test "char: value" (get (cl-read "#\\a") "value") "a")
|
||||
(cl-test "char: Space" (get (cl-read "#\\Space") "value") " ")
|
||||
(cl-test "char: Newline" (get (cl-read "#\\Newline") "value") "\n")
|
||||
|
||||
(cl-test "uninterned: type" (get (cl-read "#:foo") "cl-type") "uninterned")
|
||||
(cl-test "uninterned: name" (get (cl-read "#:foo") "name") "FOO")
|
||||
|
||||
;; ── lists ─────────────────────────────────────────────────────────
|
||||
|
||||
(cl-test "list: empty" (cl-read "()") (list))
|
||||
(cl-test "list: one element" (cl-read "(foo)") (list "FOO"))
|
||||
(cl-test "list: two elements" (cl-read "(foo bar)") (list "FOO" "BAR"))
|
||||
(cl-test "list: nested" (cl-read "((a b) c)") (list (list "A" "B") "C"))
|
||||
(cl-test "list: with integer" (cl-read "(+ 1 2)") (list "+" 1 2))
|
||||
(cl-test "list: with string" (cl-read "(print \"hi\")") (list "PRINT" {:cl-type "string" :value "hi"}))
|
||||
(cl-test "list: nil element" (cl-read "(a nil b)") (list "A" nil "B"))
|
||||
(cl-test "list: t element" (cl-read "(a t b)") (list "A" true "B"))
|
||||
|
||||
;; ── dotted pairs ──────────────────────────────────────────────<E29480><E29480>──
|
||||
|
||||
(cl-test "dotted: type" (get (cl-read "(a . b)") "cl-type") "cons")
|
||||
(cl-test "dotted: car" (get (cl-read "(a . b)") "car") "A")
|
||||
(cl-test "dotted: cdr" (get (cl-read "(a . b)") "cdr") "B")
|
||||
(cl-test "dotted: number cdr" (get (cl-read "(x . 42)") "cdr") 42)
|
||||
|
||||
;; ── reader macros ────────────────────────────────────────────────<E29480><E29480>
|
||||
|
||||
(cl-test "quote: form" (cl-read "'x") (list "QUOTE" "X"))
|
||||
(cl-test "quote: list" (cl-read "'(a b)") (list "QUOTE" (list "A" "B")))
|
||||
(cl-test "backquote: form" (cl-read "`x") (list "QUASIQUOTE" "X"))
|
||||
(cl-test "unquote: form" (cl-read ",x") (list "UNQUOTE" "X"))
|
||||
(cl-test "comma-at: form" (cl-read ",@x") (list "UNQUOTE-SPLICING" "X"))
|
||||
(cl-test "function: form" (cl-read "#'foo") (list "FUNCTION" "FOO"))
|
||||
|
||||
;; ── vector ────────────────────────────────────────────────────────
|
||||
|
||||
(cl-test "vector: type" (get (cl-read "#(1 2 3)") "cl-type") "vector")
|
||||
(cl-test "vector: elements" (get (cl-read "#(1 2 3)") "elements") (list 1 2 3))
|
||||
(cl-test "vector: empty" (get (cl-read "#()") "elements") (list))
|
||||
(cl-test "vector: mixed" (get (cl-read "#(a 1 \"s\")") "elements") (list "A" 1 {:cl-type "string" :value "s"}))
|
||||
|
||||
;; ── cl-read-all ───────────────────────────────────────────────────
|
||||
|
||||
(cl-test
|
||||
"read-all: empty"
|
||||
(cl-read-all "")
|
||||
(list))
|
||||
|
||||
(cl-test
|
||||
"read-all: two forms"
|
||||
(cl-read-all "42 foo")
|
||||
(list 42 "FOO"))
|
||||
|
||||
(cl-test
|
||||
"read-all: three forms"
|
||||
(cl-read-all "(+ 1 2) (+ 3 4) hello")
|
||||
(list (list "+" 1 2) (list "+" 3 4) "HELLO"))
|
||||
|
||||
(cl-test
|
||||
"read-all: with comments"
|
||||
(cl-read-all "; this is a comment\n42 ; inline\nfoo")
|
||||
(list 42 "FOO"))
|
||||
|
||||
(cl-test
|
||||
"read-all: defun form"
|
||||
(nth (cl-read-all "(defun square (x) (* x x))") 0)
|
||||
(list "DEFUN" "SQUARE" (list "X") (list "*" "X" "X")))
|
||||
@@ -1,180 +0,0 @@
|
||||
;; Common Lisp tokenizer tests
|
||||
|
||||
(define cl-test-pass 0)
|
||||
(define cl-test-fail 0)
|
||||
(define cl-test-fails (list))
|
||||
|
||||
(define
|
||||
cl-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! cl-test-pass (+ cl-test-pass 1))
|
||||
(do
|
||||
(set! cl-test-fail (+ cl-test-fail 1))
|
||||
(append! cl-test-fails {:name name :expected expected :actual actual})))))
|
||||
|
||||
;; Helpers: extract types and values from token stream (drops eof)
|
||||
(define
|
||||
cl-tok-types
|
||||
(fn
|
||||
(src)
|
||||
(map
|
||||
(fn (t) (get t "type"))
|
||||
(filter (fn (t) (not (= (get t "type") "eof"))) (cl-tokenize src)))))
|
||||
|
||||
(define
|
||||
cl-tok-values
|
||||
(fn
|
||||
(src)
|
||||
(map
|
||||
(fn (t) (get t "value"))
|
||||
(filter (fn (t) (not (= (get t "type") "eof"))) (cl-tokenize src)))))
|
||||
|
||||
(define
|
||||
cl-tok-first
|
||||
(fn (src) (nth (cl-tokenize src) 0)))
|
||||
|
||||
;; ── symbols ───────────────────────────────────────────────────────
|
||||
|
||||
(cl-test "symbol: bare lowercase" (cl-tok-values "foo") (list "FOO"))
|
||||
(cl-test "symbol: uppercase" (cl-tok-values "BAR") (list "BAR"))
|
||||
(cl-test "symbol: mixed case folded" (cl-tok-values "FooBar") (list "FOOBAR"))
|
||||
(cl-test "symbol: with hyphen" (cl-tok-values "foo-bar") (list "FOO-BAR"))
|
||||
(cl-test "symbol: with star" (cl-tok-values "*special*") (list "*SPECIAL*"))
|
||||
(cl-test "symbol: with question" (cl-tok-values "null?") (list "NULL?"))
|
||||
(cl-test "symbol: with exclamation" (cl-tok-values "set!") (list "SET!"))
|
||||
(cl-test "symbol: plus sign alone" (cl-tok-values "+") (list "+"))
|
||||
(cl-test "symbol: minus sign alone" (cl-tok-values "-") (list "-"))
|
||||
(cl-test "symbol: type is symbol" (cl-tok-types "foo") (list "symbol"))
|
||||
|
||||
;; ── package-qualified symbols ─────────────────────────────────────
|
||||
|
||||
(cl-test "symbol: pkg:sym external" (cl-tok-values "cl:car") (list "CL:CAR"))
|
||||
(cl-test "symbol: pkg::sym internal" (cl-tok-values "pkg::foo") (list "PKG::FOO"))
|
||||
(cl-test "symbol: cl:car type" (cl-tok-types "cl:car") (list "symbol"))
|
||||
|
||||
;; ── keywords ──────────────────────────────────────────────────────
|
||||
|
||||
(cl-test "keyword: basic" (cl-tok-values ":foo") (list "FOO"))
|
||||
(cl-test "keyword: type" (cl-tok-types ":foo") (list "keyword"))
|
||||
(cl-test "keyword: upcase" (cl-tok-values ":hello-world") (list "HELLO-WORLD"))
|
||||
(cl-test "keyword: multiple" (cl-tok-types ":a :b :c") (list "keyword" "keyword" "keyword"))
|
||||
|
||||
;; ── integers ──────────────────────────────────────────────────────
|
||||
|
||||
(cl-test "integer: zero" (cl-tok-values "0") (list "0"))
|
||||
(cl-test "integer: positive" (cl-tok-values "42") (list "42"))
|
||||
(cl-test "integer: negative" (cl-tok-values "-5") (list "-5"))
|
||||
(cl-test "integer: positive-sign" (cl-tok-values "+3") (list "+3"))
|
||||
(cl-test "integer: type" (cl-tok-types "42") (list "integer"))
|
||||
(cl-test "integer: multi-digit" (cl-tok-values "12345678") (list "12345678"))
|
||||
|
||||
;; ── hex, binary, octal ───────────────────────────────────────────
|
||||
|
||||
(cl-test "hex: lowercase x" (cl-tok-values "#xFF") (list "#xFF"))
|
||||
(cl-test "hex: uppercase X" (cl-tok-values "#XFF") (list "#XFF"))
|
||||
(cl-test "hex: type" (cl-tok-types "#xFF") (list "integer"))
|
||||
(cl-test "hex: zero" (cl-tok-values "#x0") (list "#x0"))
|
||||
(cl-test "binary: #b" (cl-tok-values "#b1010") (list "#b1010"))
|
||||
(cl-test "binary: type" (cl-tok-types "#b1010") (list "integer"))
|
||||
(cl-test "octal: #o" (cl-tok-values "#o17") (list "#o17"))
|
||||
(cl-test "octal: type" (cl-tok-types "#o17") (list "integer"))
|
||||
|
||||
;; ── floats ────────────────────────────────────────────────────────
|
||||
|
||||
(cl-test "float: basic" (cl-tok-values "3.14") (list "3.14"))
|
||||
(cl-test "float: type" (cl-tok-types "3.14") (list "float"))
|
||||
(cl-test "float: negative" (cl-tok-values "-2.5") (list "-2.5"))
|
||||
(cl-test "float: exponent" (cl-tok-values "1.0e10") (list "1.0e10"))
|
||||
(cl-test "float: neg exponent" (cl-tok-values "1.5e-3") (list "1.5e-3"))
|
||||
(cl-test "float: leading dot" (cl-tok-values ".5") (list "0.5"))
|
||||
(cl-test "float: exp only" (cl-tok-values "1e5") (list "1e5"))
|
||||
|
||||
;; ── ratios ────────────────────────────────────────────────────────
|
||||
|
||||
(cl-test "ratio: 1/3" (cl-tok-values "1/3") (list "1/3"))
|
||||
(cl-test "ratio: type" (cl-tok-types "1/3") (list "ratio"))
|
||||
(cl-test "ratio: 22/7" (cl-tok-values "22/7") (list "22/7"))
|
||||
(cl-test "ratio: negative" (cl-tok-values "-1/2") (list "-1/2"))
|
||||
|
||||
;; ── strings ───────────────────────────────────────────────────────
|
||||
|
||||
(cl-test "string: empty" (cl-tok-values "\"\"") (list ""))
|
||||
(cl-test "string: basic" (cl-tok-values "\"hello\"") (list "hello"))
|
||||
(cl-test "string: type" (cl-tok-types "\"hello\"") (list "string"))
|
||||
(cl-test "string: with space" (cl-tok-values "\"hello world\"") (list "hello world"))
|
||||
(cl-test "string: escaped quote" (cl-tok-values "\"say \\\"hi\\\"\"") (list "say \"hi\""))
|
||||
(cl-test "string: escaped backslash" (cl-tok-values "\"a\\\\b\"") (list "a\\b"))
|
||||
(cl-test "string: newline escape" (cl-tok-values "\"a\\nb\"") (list "a\nb"))
|
||||
(cl-test "string: tab escape" (cl-tok-values "\"a\\tb\"") (list "a\tb"))
|
||||
|
||||
;; ── characters ────────────────────────────────────────────────────
|
||||
|
||||
(cl-test "char: lowercase a" (cl-tok-values "#\\a") (list "a"))
|
||||
(cl-test "char: uppercase A" (cl-tok-values "#\\A") (list "A"))
|
||||
(cl-test "char: digit" (cl-tok-values "#\\1") (list "1"))
|
||||
(cl-test "char: type" (cl-tok-types "#\\a") (list "char"))
|
||||
(cl-test "char: Space" (cl-tok-values "#\\Space") (list " "))
|
||||
(cl-test "char: Newline" (cl-tok-values "#\\Newline") (list "\n"))
|
||||
(cl-test "char: Tab" (cl-tok-values "#\\Tab") (list "\t"))
|
||||
(cl-test "char: Return" (cl-tok-values "#\\Return") (list "\r"))
|
||||
|
||||
;; ── reader macros ─────────────────────────────────────────────────
|
||||
|
||||
(cl-test "quote: type" (cl-tok-types "'x") (list "quote" "symbol"))
|
||||
(cl-test "backquote: type" (cl-tok-types "`x") (list "backquote" "symbol"))
|
||||
(cl-test "comma: type" (cl-tok-types ",x") (list "comma" "symbol"))
|
||||
(cl-test "comma-at: type" (cl-tok-types ",@x") (list "comma-at" "symbol"))
|
||||
(cl-test "hash-quote: type" (cl-tok-types "#'foo") (list "hash-quote" "symbol"))
|
||||
(cl-test "hash-paren: type" (cl-tok-types "#(1 2)") (list "hash-paren" "integer" "integer" "rparen"))
|
||||
|
||||
;; ── uninterned ────────────────────────────────────────────────────
|
||||
|
||||
(cl-test "uninterned: type" (cl-tok-types "#:foo") (list "uninterned"))
|
||||
(cl-test "uninterned: value upcase" (cl-tok-values "#:foo") (list "FOO"))
|
||||
(cl-test "uninterned: compound" (cl-tok-values "#:my-sym") (list "MY-SYM"))
|
||||
|
||||
;; ── parens and structure ──────────────────────────────────────────
|
||||
|
||||
(cl-test "paren: empty list" (cl-tok-types "()") (list "lparen" "rparen"))
|
||||
(cl-test "paren: nested" (cl-tok-types "((a))") (list "lparen" "lparen" "symbol" "rparen" "rparen"))
|
||||
(cl-test "dot: standalone" (cl-tok-types "(a . b)") (list "lparen" "symbol" "dot" "symbol" "rparen"))
|
||||
|
||||
;; ── comments ──────────────────────────────────────────────────────
|
||||
|
||||
(cl-test "comment: line" (cl-tok-types "; comment\nfoo") (list "symbol"))
|
||||
(cl-test "comment: inline" (cl-tok-values "foo ; bar\nbaz") (list "FOO" "BAZ"))
|
||||
(cl-test "block-comment: basic" (cl-tok-types "#| hello |# foo") (list "symbol"))
|
||||
(cl-test "block-comment: nested" (cl-tok-types "#| a #| b |# c |# x") (list "symbol"))
|
||||
|
||||
;; ── combined ──────────────────────────────────────────────────────
|
||||
|
||||
(cl-test
|
||||
"combined: defun skeleton"
|
||||
(cl-tok-types "(defun foo (x) x)")
|
||||
(list "lparen" "symbol" "symbol" "lparen" "symbol" "rparen" "symbol" "rparen"))
|
||||
|
||||
(cl-test
|
||||
"combined: let form"
|
||||
(cl-tok-types "(let ((x 1)) x)")
|
||||
(list
|
||||
"lparen"
|
||||
"symbol"
|
||||
"lparen"
|
||||
"lparen"
|
||||
"symbol"
|
||||
"integer"
|
||||
"rparen"
|
||||
"rparen"
|
||||
"symbol"
|
||||
"rparen"))
|
||||
|
||||
(cl-test
|
||||
"combined: whitespace skip"
|
||||
(cl-tok-values " foo bar baz ")
|
||||
(list "FOO" "BAR" "BAZ"))
|
||||
|
||||
(cl-test "eof: present" (get (nth (cl-tokenize "") 0) "type") "eof")
|
||||
(cl-test "eof: at end of tokens" (get (nth (cl-tokenize "x") 1) "type") "eof")
|
||||
@@ -49,6 +49,8 @@ trap "rm -f $TMPFILE" EXIT
|
||||
echo '(load "lib/js/transpile.sx")'
|
||||
echo '(epoch 5)'
|
||||
echo '(load "lib/js/runtime.sx")'
|
||||
echo '(epoch 6)'
|
||||
echo '(load "lib/js/regex.sx")'
|
||||
|
||||
epoch=100
|
||||
for f in "${FIXTURES[@]}"; do
|
||||
|
||||
943
lib/js/regex.sx
Normal file
943
lib/js/regex.sx
Normal file
@@ -0,0 +1,943 @@
|
||||
;; lib/js/regex.sx — pure-SX recursive backtracking regex engine
|
||||
;;
|
||||
;; Installed via (js-regex-platform-override! ...) at load time.
|
||||
;; Covers: character classes (\d\w\s . [abc] [^abc] [a-z]),
|
||||
;; anchors (^ $ \b \B), quantifiers (* + ? {n,m} lazy variants),
|
||||
;; groups (capturing + non-capturing), alternation (a|b),
|
||||
;; flags: i (case-insensitive), g (global), m (multiline).
|
||||
;;
|
||||
;; Architecture:
|
||||
;; 1. rx-parse-pattern — pattern string → compiled node list
|
||||
;; 2. rx-match-nodes — recursive backtracker
|
||||
;; 3. rx-exec / rx-test — public interface
|
||||
;; 4. Install as {:test rx-test :exec rx-exec}
|
||||
|
||||
;; ── Utilities ─────────────────────────────────────────────────────
|
||||
|
||||
(define
|
||||
rx-char-at
|
||||
(fn (s i) (if (and (>= i 0) (< i (len s))) (char-at s i) "")))
|
||||
|
||||
(define
|
||||
rx-digit?
|
||||
(fn
|
||||
(c)
|
||||
(and (not (= c "")) (>= (char-code c) 48) (<= (char-code c) 57))))
|
||||
|
||||
(define
|
||||
rx-word?
|
||||
(fn
|
||||
(c)
|
||||
(and
|
||||
(not (= c ""))
|
||||
(or
|
||||
(and (>= (char-code c) 65) (<= (char-code c) 90))
|
||||
(and (>= (char-code c) 97) (<= (char-code c) 122))
|
||||
(and (>= (char-code c) 48) (<= (char-code c) 57))
|
||||
(= c "_")))))
|
||||
|
||||
(define
|
||||
rx-space?
|
||||
(fn
|
||||
(c)
|
||||
(or (= c " ") (= c "\t") (= c "\n") (= c "\r") (= c "\\f") (= c ""))))
|
||||
|
||||
(define rx-newline? (fn (c) (or (= c "\n") (= c "\r"))))
|
||||
|
||||
(define
|
||||
rx-downcase-char
|
||||
(fn
|
||||
(c)
|
||||
(let
|
||||
((cc (char-code c)))
|
||||
(if (and (>= cc 65) (<= cc 90)) (char-from-code (+ cc 32)) c))))
|
||||
|
||||
(define
|
||||
rx-char-eq?
|
||||
(fn
|
||||
(a b ci?)
|
||||
(if ci? (= (rx-downcase-char a) (rx-downcase-char b)) (= a b))))
|
||||
|
||||
(define
|
||||
rx-parse-int
|
||||
(fn
|
||||
(pat i acc)
|
||||
(let
|
||||
((c (rx-char-at pat i)))
|
||||
(if
|
||||
(rx-digit? c)
|
||||
(rx-parse-int pat (+ i 1) (+ (* acc 10) (- (char-code c) 48)))
|
||||
(list acc i)))))
|
||||
|
||||
(define
|
||||
rx-hex-digit-val
|
||||
(fn
|
||||
(c)
|
||||
(cond
|
||||
((and (>= (char-code c) 48) (<= (char-code c) 57))
|
||||
(- (char-code c) 48))
|
||||
((and (>= (char-code c) 65) (<= (char-code c) 70))
|
||||
(+ 10 (- (char-code c) 65)))
|
||||
((and (>= (char-code c) 97) (<= (char-code c) 102))
|
||||
(+ 10 (- (char-code c) 97)))
|
||||
(else -1))))
|
||||
|
||||
(define
|
||||
rx-parse-hex-n
|
||||
(fn
|
||||
(pat i n acc)
|
||||
(if
|
||||
(= n 0)
|
||||
(list (char-from-code acc) i)
|
||||
(let
|
||||
((v (rx-hex-digit-val (rx-char-at pat i))))
|
||||
(if
|
||||
(< v 0)
|
||||
(list (char-from-code acc) i)
|
||||
(rx-parse-hex-n pat (+ i 1) (- n 1) (+ (* acc 16) v)))))))
|
||||
|
||||
;; ── Pattern compiler ──────────────────────────────────────────────
|
||||
|
||||
;; Node types (stored in dicts with "__t__" key):
|
||||
;; literal : {:__t__ "literal" :__c__ char}
|
||||
;; any : {:__t__ "any"}
|
||||
;; class-d : {:__t__ "class-d" :__neg__ bool}
|
||||
;; class-w : {:__t__ "class-w" :__neg__ bool}
|
||||
;; class-s : {:__t__ "class-s" :__neg__ bool}
|
||||
;; char-class: {:__t__ "char-class" :__neg__ bool :__items__ list}
|
||||
;; anchor-start / anchor-end / anchor-word / anchor-nonword
|
||||
;; quant : {:__t__ "quant" :__node__ n :__min__ m :__max__ mx :__lazy__ bool}
|
||||
;; group : {:__t__ "group" :__idx__ i :__nodes__ list}
|
||||
;; ncgroup : {:__t__ "ncgroup" :__nodes__ list}
|
||||
;; alt : {:__t__ "alt" :__branches__ list-of-node-lists}
|
||||
|
||||
;; parse one escape after `\`, returns (node new-i)
|
||||
(define
|
||||
rx-parse-escape
|
||||
(fn
|
||||
(pat i)
|
||||
(let
|
||||
((c (rx-char-at pat i)))
|
||||
(cond
|
||||
((= c "d") (list (dict "__t__" "class-d" "__neg__" false) (+ i 1)))
|
||||
((= c "D") (list (dict "__t__" "class-d" "__neg__" true) (+ i 1)))
|
||||
((= c "w") (list (dict "__t__" "class-w" "__neg__" false) (+ i 1)))
|
||||
((= c "W") (list (dict "__t__" "class-w" "__neg__" true) (+ i 1)))
|
||||
((= c "s") (list (dict "__t__" "class-s" "__neg__" false) (+ i 1)))
|
||||
((= c "S") (list (dict "__t__" "class-s" "__neg__" true) (+ i 1)))
|
||||
((= c "b") (list (dict "__t__" "anchor-word") (+ i 1)))
|
||||
((= c "B") (list (dict "__t__" "anchor-nonword") (+ i 1)))
|
||||
((= c "n") (list (dict "__t__" "literal" "__c__" "\n") (+ i 1)))
|
||||
((= c "r") (list (dict "__t__" "literal" "__c__" "\r") (+ i 1)))
|
||||
((= c "t") (list (dict "__t__" "literal" "__c__" "\t") (+ i 1)))
|
||||
((= c "f") (list (dict "__t__" "literal" "__c__" "\\f") (+ i 1)))
|
||||
((= c "v") (list (dict "__t__" "literal" "__c__" "") (+ i 1)))
|
||||
((= c "u")
|
||||
(let
|
||||
((res (rx-parse-hex-n pat (+ i 1) 4 0)))
|
||||
(list (dict "__t__" "literal" "__c__" (nth res 0)) (nth res 1))))
|
||||
((= c "x")
|
||||
(let
|
||||
((res (rx-parse-hex-n pat (+ i 1) 2 0)))
|
||||
(list (dict "__t__" "literal" "__c__" (nth res 0)) (nth res 1))))
|
||||
(else (list (dict "__t__" "literal" "__c__" c) (+ i 1)))))))
|
||||
|
||||
;; parse a char-class item inside [...], returns (item new-i)
|
||||
(define
|
||||
rx-parse-class-item
|
||||
(fn
|
||||
(pat i)
|
||||
(let
|
||||
((c (rx-char-at pat i)))
|
||||
(cond
|
||||
((= c "\\")
|
||||
(let
|
||||
((esc (rx-parse-escape pat (+ i 1))))
|
||||
(let
|
||||
((node (nth esc 0)) (ni (nth esc 1)))
|
||||
(let
|
||||
((t (get node "__t__")))
|
||||
(cond
|
||||
((= t "class-d")
|
||||
(list
|
||||
(dict "kind" "class-d" "neg" (get node "__neg__"))
|
||||
ni))
|
||||
((= t "class-w")
|
||||
(list
|
||||
(dict "kind" "class-w" "neg" (get node "__neg__"))
|
||||
ni))
|
||||
((= t "class-s")
|
||||
(list
|
||||
(dict "kind" "class-s" "neg" (get node "__neg__"))
|
||||
ni))
|
||||
(else
|
||||
(let
|
||||
((lc (get node "__c__")))
|
||||
(if
|
||||
(and
|
||||
(= (rx-char-at pat ni) "-")
|
||||
(not (= (rx-char-at pat (+ ni 1)) "]")))
|
||||
(let
|
||||
((hi-c (rx-char-at pat (+ ni 1))))
|
||||
(list
|
||||
(dict "kind" "range" "lo" lc "hi" hi-c)
|
||||
(+ ni 2)))
|
||||
(list (dict "kind" "lit" "c" lc) ni)))))))))
|
||||
(else
|
||||
(if
|
||||
(and
|
||||
(not (= c ""))
|
||||
(= (rx-char-at pat (+ i 1)) "-")
|
||||
(not (= (rx-char-at pat (+ i 2)) "]"))
|
||||
(not (= (rx-char-at pat (+ i 2)) "")))
|
||||
(let
|
||||
((hi-c (rx-char-at pat (+ i 2))))
|
||||
(list (dict "kind" "range" "lo" c "hi" hi-c) (+ i 3)))
|
||||
(list (dict "kind" "lit" "c" c) (+ i 1))))))))
|
||||
|
||||
(define
|
||||
rx-parse-class-items
|
||||
(fn
|
||||
(pat i items)
|
||||
(let
|
||||
((c (rx-char-at pat i)))
|
||||
(if
|
||||
(or (= c "]") (= c ""))
|
||||
(list items i)
|
||||
(let
|
||||
((res (rx-parse-class-item pat i)))
|
||||
(begin
|
||||
(append! items (nth res 0))
|
||||
(rx-parse-class-items pat (nth res 1) items)))))))
|
||||
|
||||
;; parse a sequence until stop-ch or EOF; returns (nodes new-i groups-count)
|
||||
(define
|
||||
rx-parse-seq
|
||||
(fn
|
||||
(pat i stop-ch ds)
|
||||
(let
|
||||
((c (rx-char-at pat i)))
|
||||
(cond
|
||||
((= c "") (list (get ds "nodes") i (get ds "groups")))
|
||||
((= c stop-ch) (list (get ds "nodes") i (get ds "groups")))
|
||||
((= c "|") (rx-parse-alt-rest pat i ds))
|
||||
(else
|
||||
(let
|
||||
((res (rx-parse-atom pat i ds)))
|
||||
(let
|
||||
((node (nth res 0)) (ni (nth res 1)) (ds2 (nth res 2)))
|
||||
(let
|
||||
((qres (rx-parse-quant pat ni node)))
|
||||
(begin
|
||||
(append! (get ds2 "nodes") (nth qres 0))
|
||||
(rx-parse-seq pat (nth qres 1) stop-ch ds2))))))))))
|
||||
|
||||
;; when we hit | inside a sequence, collect all alternatives
|
||||
(define
|
||||
rx-parse-alt-rest
|
||||
(fn
|
||||
(pat i ds)
|
||||
(let
|
||||
((left-branch (get ds "nodes")) (branches (list)))
|
||||
(begin
|
||||
(append! branches left-branch)
|
||||
(rx-parse-alt-branches pat i (get ds "groups") branches)))))
|
||||
|
||||
(define
|
||||
rx-parse-alt-branches
|
||||
(fn
|
||||
(pat i n-groups branches)
|
||||
(let
|
||||
((new-nodes (list)) (ds2 (dict "groups" n-groups "nodes" new-nodes)))
|
||||
(let
|
||||
((res (rx-parse-seq pat (+ i 1) "|" ds2)))
|
||||
(begin
|
||||
(append! branches (nth res 0))
|
||||
(let
|
||||
((ni2 (nth res 1)) (g2 (nth res 2)))
|
||||
(if
|
||||
(= (rx-char-at pat ni2) "|")
|
||||
(rx-parse-alt-branches pat ni2 g2 branches)
|
||||
(list
|
||||
(list (dict "__t__" "alt" "__branches__" branches))
|
||||
ni2
|
||||
g2))))))))
|
||||
|
||||
;; parse quantifier suffix, returns (node new-i)
|
||||
(define
|
||||
rx-parse-quant
|
||||
(fn
|
||||
(pat i node)
|
||||
(let
|
||||
((c (rx-char-at pat i)))
|
||||
(cond
|
||||
((= c "*")
|
||||
(let
|
||||
((lazy? (= (rx-char-at pat (+ i 1)) "?")))
|
||||
(list
|
||||
(dict
|
||||
"__t__"
|
||||
"quant"
|
||||
"__node__"
|
||||
node
|
||||
"__min__"
|
||||
0
|
||||
"__max__"
|
||||
-1
|
||||
"__lazy__"
|
||||
lazy?)
|
||||
(if lazy? (+ i 2) (+ i 1)))))
|
||||
((= c "+")
|
||||
(let
|
||||
((lazy? (= (rx-char-at pat (+ i 1)) "?")))
|
||||
(list
|
||||
(dict
|
||||
"__t__"
|
||||
"quant"
|
||||
"__node__"
|
||||
node
|
||||
"__min__"
|
||||
1
|
||||
"__max__"
|
||||
-1
|
||||
"__lazy__"
|
||||
lazy?)
|
||||
(if lazy? (+ i 2) (+ i 1)))))
|
||||
((= c "?")
|
||||
(let
|
||||
((lazy? (= (rx-char-at pat (+ i 1)) "?")))
|
||||
(list
|
||||
(dict
|
||||
"__t__"
|
||||
"quant"
|
||||
"__node__"
|
||||
node
|
||||
"__min__"
|
||||
0
|
||||
"__max__"
|
||||
1
|
||||
"__lazy__"
|
||||
lazy?)
|
||||
(if lazy? (+ i 2) (+ i 1)))))
|
||||
((= c "{")
|
||||
(let
|
||||
((mres (rx-parse-int pat (+ i 1) 0)))
|
||||
(let
|
||||
((mn (nth mres 0)) (mi (nth mres 1)))
|
||||
(let
|
||||
((sep (rx-char-at pat mi)))
|
||||
(cond
|
||||
((= sep "}")
|
||||
(let
|
||||
((lazy? (= (rx-char-at pat (+ mi 1)) "?")))
|
||||
(list
|
||||
(dict
|
||||
"__t__"
|
||||
"quant"
|
||||
"__node__"
|
||||
node
|
||||
"__min__"
|
||||
mn
|
||||
"__max__"
|
||||
mn
|
||||
"__lazy__"
|
||||
lazy?)
|
||||
(if lazy? (+ mi 2) (+ mi 1)))))
|
||||
((= sep ",")
|
||||
(let
|
||||
((c2 (rx-char-at pat (+ mi 1))))
|
||||
(if
|
||||
(= c2 "}")
|
||||
(let
|
||||
((lazy? (= (rx-char-at pat (+ mi 2)) "?")))
|
||||
(list
|
||||
(dict
|
||||
"__t__"
|
||||
"quant"
|
||||
"__node__"
|
||||
node
|
||||
"__min__"
|
||||
mn
|
||||
"__max__"
|
||||
-1
|
||||
"__lazy__"
|
||||
lazy?)
|
||||
(if lazy? (+ mi 3) (+ mi 2))))
|
||||
(let
|
||||
((mxres (rx-parse-int pat (+ mi 1) 0)))
|
||||
(let
|
||||
((mx (nth mxres 0)) (mxi (nth mxres 1)))
|
||||
(let
|
||||
((lazy? (= (rx-char-at pat (+ mxi 1)) "?")))
|
||||
(list
|
||||
(dict
|
||||
"__t__"
|
||||
"quant"
|
||||
"__node__"
|
||||
node
|
||||
"__min__"
|
||||
mn
|
||||
"__max__"
|
||||
mx
|
||||
"__lazy__"
|
||||
lazy?)
|
||||
(if lazy? (+ mxi 2) (+ mxi 1)))))))))
|
||||
(else (list node i)))))))
|
||||
(else (list node i))))))
|
||||
|
||||
;; parse one atom, returns (node new-i new-ds)
|
||||
(define
|
||||
rx-parse-atom
|
||||
(fn
|
||||
(pat i ds)
|
||||
(let
|
||||
((c (rx-char-at pat i)))
|
||||
(cond
|
||||
((= c ".") (list (dict "__t__" "any") (+ i 1) ds))
|
||||
((= c "^") (list (dict "__t__" "anchor-start") (+ i 1) ds))
|
||||
((= c "$") (list (dict "__t__" "anchor-end") (+ i 1) ds))
|
||||
((= c "\\")
|
||||
(let
|
||||
((esc (rx-parse-escape pat (+ i 1))))
|
||||
(list (nth esc 0) (nth esc 1) ds)))
|
||||
((= c "[")
|
||||
(let
|
||||
((neg? (= (rx-char-at pat (+ i 1)) "^")))
|
||||
(let
|
||||
((start (if neg? (+ i 2) (+ i 1))) (items (list)))
|
||||
(let
|
||||
((res (rx-parse-class-items pat start items)))
|
||||
(let
|
||||
((ci (nth res 1)))
|
||||
(list
|
||||
(dict
|
||||
"__t__"
|
||||
"char-class"
|
||||
"__neg__"
|
||||
neg?
|
||||
"__items__"
|
||||
items)
|
||||
(+ ci 1)
|
||||
ds))))))
|
||||
((= c "(")
|
||||
(let
|
||||
((c2 (rx-char-at pat (+ i 1))))
|
||||
(if
|
||||
(and (= c2 "?") (= (rx-char-at pat (+ i 2)) ":"))
|
||||
(let
|
||||
((inner-nodes (list))
|
||||
(inner-ds
|
||||
(dict "groups" (get ds "groups") "nodes" inner-nodes)))
|
||||
(let
|
||||
((res (rx-parse-seq pat (+ i 3) ")" inner-ds)))
|
||||
(list
|
||||
(dict "__t__" "ncgroup" "__nodes__" (nth res 0))
|
||||
(+ (nth res 1) 1)
|
||||
(dict "groups" (nth res 2) "nodes" (get ds "nodes")))))
|
||||
(let
|
||||
((gidx (+ (get ds "groups") 1)) (inner-nodes (list)))
|
||||
(let
|
||||
((inner-ds (dict "groups" gidx "nodes" inner-nodes)))
|
||||
(let
|
||||
((res (rx-parse-seq pat (+ i 1) ")" inner-ds)))
|
||||
(list
|
||||
(dict
|
||||
"__t__"
|
||||
"group"
|
||||
"__idx__"
|
||||
gidx
|
||||
"__nodes__"
|
||||
(nth res 0))
|
||||
(+ (nth res 1) 1)
|
||||
(dict "groups" (nth res 2) "nodes" (get ds "nodes")))))))))
|
||||
(else (list (dict "__t__" "literal" "__c__" c) (+ i 1) ds))))))
|
||||
|
||||
;; top-level compile
|
||||
(define
|
||||
rx-compile
|
||||
(fn
|
||||
(pattern)
|
||||
(let
|
||||
((nodes (list)) (ds (dict "groups" 0 "nodes" nodes)))
|
||||
(let
|
||||
((res (rx-parse-seq pattern 0 "" ds)))
|
||||
(dict "nodes" (nth res 0) "ngroups" (nth res 2))))))
|
||||
|
||||
;; ── Matcher ───────────────────────────────────────────────────────
|
||||
|
||||
;; Match a char-class item against character c
|
||||
(define
|
||||
rx-item-matches?
|
||||
(fn
|
||||
(item c ci?)
|
||||
(let
|
||||
((kind (get item "kind")))
|
||||
(cond
|
||||
((= kind "lit") (rx-char-eq? c (get item "c") ci?))
|
||||
((= kind "range")
|
||||
(let
|
||||
((lo (if ci? (rx-downcase-char (get item "lo")) (get item "lo")))
|
||||
(hi
|
||||
(if ci? (rx-downcase-char (get item "hi")) (get item "hi")))
|
||||
(dc (if ci? (rx-downcase-char c) c)))
|
||||
(and
|
||||
(>= (char-code dc) (char-code lo))
|
||||
(<= (char-code dc) (char-code hi)))))
|
||||
((= kind "class-d")
|
||||
(let ((m (rx-digit? c))) (if (get item "neg") (not m) m)))
|
||||
((= kind "class-w")
|
||||
(let ((m (rx-word? c))) (if (get item "neg") (not m) m)))
|
||||
((= kind "class-s")
|
||||
(let ((m (rx-space? c))) (if (get item "neg") (not m) m)))
|
||||
(else false)))))
|
||||
|
||||
(define
|
||||
rx-class-items-any?
|
||||
(fn
|
||||
(items c ci?)
|
||||
(if
|
||||
(empty? items)
|
||||
false
|
||||
(if
|
||||
(rx-item-matches? (first items) c ci?)
|
||||
true
|
||||
(rx-class-items-any? (rest items) c ci?)))))
|
||||
|
||||
(define
|
||||
rx-class-matches?
|
||||
(fn
|
||||
(node c ci?)
|
||||
(let
|
||||
((neg? (get node "__neg__")) (items (get node "__items__")))
|
||||
(let
|
||||
((hit (rx-class-items-any? items c ci?)))
|
||||
(if neg? (not hit) hit)))))
|
||||
|
||||
;; Word boundary check
|
||||
(define
|
||||
rx-is-word-boundary?
|
||||
(fn
|
||||
(s i slen)
|
||||
(let
|
||||
((before (if (> i 0) (rx-word? (char-at s (- i 1))) false))
|
||||
(after (if (< i slen) (rx-word? (char-at s i)) false)))
|
||||
(not (= before after)))))
|
||||
|
||||
;; ── Core matcher ──────────────────────────────────────────────────
|
||||
;;
|
||||
;; rx-match-nodes : nodes s i slen ci? mi? groups → end-pos or -1
|
||||
;;
|
||||
;; Matches `nodes` starting at position `i` in string `s`.
|
||||
;; Returns the position after the last character consumed, or -1 on failure.
|
||||
;; Mutates `groups` dict to record captures.
|
||||
|
||||
(define
|
||||
rx-match-nodes
|
||||
(fn
|
||||
(nodes s i slen ci? mi? groups)
|
||||
(if
|
||||
(empty? nodes)
|
||||
i
|
||||
(let
|
||||
((node (first nodes)) (rest-nodes (rest nodes)))
|
||||
(let
|
||||
((t (get node "__t__")))
|
||||
(cond
|
||||
((= t "literal")
|
||||
(if
|
||||
(and
|
||||
(< i slen)
|
||||
(rx-char-eq? (char-at s i) (get node "__c__") ci?))
|
||||
(rx-match-nodes rest-nodes s (+ i 1) slen ci? mi? groups)
|
||||
-1))
|
||||
((= t "any")
|
||||
(if
|
||||
(and (< i slen) (not (rx-newline? (char-at s i))))
|
||||
(rx-match-nodes rest-nodes s (+ i 1) slen ci? mi? groups)
|
||||
-1))
|
||||
((= t "class-d")
|
||||
(let
|
||||
((m (and (< i slen) (rx-digit? (char-at s i)))))
|
||||
(if
|
||||
(if (get node "__neg__") (not m) m)
|
||||
(rx-match-nodes rest-nodes s (+ i 1) slen ci? mi? groups)
|
||||
-1)))
|
||||
((= t "class-w")
|
||||
(let
|
||||
((m (and (< i slen) (rx-word? (char-at s i)))))
|
||||
(if
|
||||
(if (get node "__neg__") (not m) m)
|
||||
(rx-match-nodes rest-nodes s (+ i 1) slen ci? mi? groups)
|
||||
-1)))
|
||||
((= t "class-s")
|
||||
(let
|
||||
((m (and (< i slen) (rx-space? (char-at s i)))))
|
||||
(if
|
||||
(if (get node "__neg__") (not m) m)
|
||||
(rx-match-nodes rest-nodes s (+ i 1) slen ci? mi? groups)
|
||||
-1)))
|
||||
((= t "char-class")
|
||||
(if
|
||||
(and (< i slen) (rx-class-matches? node (char-at s i) ci?))
|
||||
(rx-match-nodes rest-nodes s (+ i 1) slen ci? mi? groups)
|
||||
-1))
|
||||
((= t "anchor-start")
|
||||
(if
|
||||
(or
|
||||
(= i 0)
|
||||
(and mi? (rx-newline? (rx-char-at s (- i 1)))))
|
||||
(rx-match-nodes rest-nodes s i slen ci? mi? groups)
|
||||
-1))
|
||||
((= t "anchor-end")
|
||||
(if
|
||||
(or (= i slen) (and mi? (rx-newline? (rx-char-at s i))))
|
||||
(rx-match-nodes rest-nodes s i slen ci? mi? groups)
|
||||
-1))
|
||||
((= t "anchor-word")
|
||||
(if
|
||||
(rx-is-word-boundary? s i slen)
|
||||
(rx-match-nodes rest-nodes s i slen ci? mi? groups)
|
||||
-1))
|
||||
((= t "anchor-nonword")
|
||||
(if
|
||||
(not (rx-is-word-boundary? s i slen))
|
||||
(rx-match-nodes rest-nodes s i slen ci? mi? groups)
|
||||
-1))
|
||||
((= t "group")
|
||||
(let
|
||||
((gidx (get node "__idx__"))
|
||||
(inner (get node "__nodes__")))
|
||||
(let
|
||||
((g-end (rx-match-nodes inner s i slen ci? mi? groups)))
|
||||
(if
|
||||
(>= g-end 0)
|
||||
(begin
|
||||
(dict-set!
|
||||
groups
|
||||
(js-to-string gidx)
|
||||
(substring s i g-end))
|
||||
(let
|
||||
((final-end (rx-match-nodes rest-nodes s g-end slen ci? mi? groups)))
|
||||
(if
|
||||
(>= final-end 0)
|
||||
final-end
|
||||
(begin
|
||||
(dict-set! groups (js-to-string gidx) nil)
|
||||
-1))))
|
||||
-1))))
|
||||
((= t "ncgroup")
|
||||
(let
|
||||
((inner (get node "__nodes__")))
|
||||
(rx-match-nodes
|
||||
(append inner rest-nodes)
|
||||
s
|
||||
i
|
||||
slen
|
||||
ci?
|
||||
mi?
|
||||
groups)))
|
||||
((= t "alt")
|
||||
(let
|
||||
((branches (get node "__branches__")))
|
||||
(rx-try-branches branches rest-nodes s i slen ci? mi? groups)))
|
||||
((= t "quant")
|
||||
(let
|
||||
((inner-node (get node "__node__"))
|
||||
(mn (get node "__min__"))
|
||||
(mx (get node "__max__"))
|
||||
(lazy? (get node "__lazy__")))
|
||||
(if
|
||||
lazy?
|
||||
(rx-quant-lazy
|
||||
inner-node
|
||||
mn
|
||||
mx
|
||||
rest-nodes
|
||||
s
|
||||
i
|
||||
slen
|
||||
ci?
|
||||
mi?
|
||||
groups
|
||||
0)
|
||||
(rx-quant-greedy
|
||||
inner-node
|
||||
mn
|
||||
mx
|
||||
rest-nodes
|
||||
s
|
||||
i
|
||||
slen
|
||||
ci?
|
||||
mi?
|
||||
groups
|
||||
0))))
|
||||
(else -1)))))))
|
||||
|
||||
(define
|
||||
rx-try-branches
|
||||
(fn
|
||||
(branches rest-nodes s i slen ci? mi? groups)
|
||||
(if
|
||||
(empty? branches)
|
||||
-1
|
||||
(let
|
||||
((res (rx-match-nodes (append (first branches) rest-nodes) s i slen ci? mi? groups)))
|
||||
(if
|
||||
(>= res 0)
|
||||
res
|
||||
(rx-try-branches (rest branches) rest-nodes s i slen ci? mi? groups))))))
|
||||
|
||||
;; Greedy: expand as far as possible, then try rest from the longest match
|
||||
;; Strategy: recurse forward (extend first); only try rest when extension fails
|
||||
(define
|
||||
rx-quant-greedy
|
||||
(fn
|
||||
(inner-node mn mx rest-nodes s i slen ci? mi? groups count)
|
||||
(let
|
||||
((can-extend (and (< i slen) (or (= mx -1) (< count mx)))))
|
||||
(if
|
||||
can-extend
|
||||
(let
|
||||
((ni (rx-match-one inner-node s i slen ci? mi? groups)))
|
||||
(if
|
||||
(>= ni 0)
|
||||
(let
|
||||
((res (rx-quant-greedy inner-node mn mx rest-nodes s ni slen ci? mi? groups (+ count 1))))
|
||||
(if
|
||||
(>= res 0)
|
||||
res
|
||||
(if
|
||||
(>= count mn)
|
||||
(rx-match-nodes rest-nodes s i slen ci? mi? groups)
|
||||
-1)))
|
||||
(if
|
||||
(>= count mn)
|
||||
(rx-match-nodes rest-nodes s i slen ci? mi? groups)
|
||||
-1)))
|
||||
(if
|
||||
(>= count mn)
|
||||
(rx-match-nodes rest-nodes s i slen ci? mi? groups)
|
||||
-1)))))
|
||||
|
||||
;; Lazy: try rest first, extend only if rest fails
|
||||
(define
|
||||
rx-quant-lazy
|
||||
(fn
|
||||
(inner-node mn mx rest-nodes s i slen ci? mi? groups count)
|
||||
(if
|
||||
(>= count mn)
|
||||
(let
|
||||
((res (rx-match-nodes rest-nodes s i slen ci? mi? groups)))
|
||||
(if
|
||||
(>= res 0)
|
||||
res
|
||||
(if
|
||||
(and (< i slen) (or (= mx -1) (< count mx)))
|
||||
(let
|
||||
((ni (rx-match-one inner-node s i slen ci? mi? groups)))
|
||||
(if
|
||||
(>= ni 0)
|
||||
(rx-quant-lazy
|
||||
inner-node
|
||||
mn
|
||||
mx
|
||||
rest-nodes
|
||||
s
|
||||
ni
|
||||
slen
|
||||
ci?
|
||||
mi?
|
||||
groups
|
||||
(+ count 1))
|
||||
-1))
|
||||
-1)))
|
||||
(if
|
||||
(< i slen)
|
||||
(let
|
||||
((ni (rx-match-one inner-node s i slen ci? mi? groups)))
|
||||
(if
|
||||
(>= ni 0)
|
||||
(rx-quant-lazy
|
||||
inner-node
|
||||
mn
|
||||
mx
|
||||
rest-nodes
|
||||
s
|
||||
ni
|
||||
slen
|
||||
ci?
|
||||
mi?
|
||||
groups
|
||||
(+ count 1))
|
||||
-1))
|
||||
-1))))
|
||||
|
||||
;; Match a single node at position i, return new pos or -1
|
||||
(define
|
||||
rx-match-one
|
||||
(fn
|
||||
(node s i slen ci? mi? groups)
|
||||
(rx-match-nodes (list node) s i slen ci? mi? groups)))
|
||||
|
||||
;; ── Engine entry points ───────────────────────────────────────────
|
||||
|
||||
;; Try matching at exactly position i. Returns result dict or nil.
|
||||
(define
|
||||
rx-try-at
|
||||
(fn
|
||||
(compiled s i slen ci? mi?)
|
||||
(let
|
||||
((nodes (get compiled "nodes")) (ngroups (get compiled "ngroups")))
|
||||
(let
|
||||
((groups (dict)))
|
||||
(let
|
||||
((end (rx-match-nodes nodes s i slen ci? mi? groups)))
|
||||
(if
|
||||
(>= end 0)
|
||||
(dict "start" i "end" end "groups" groups "ngroups" ngroups)
|
||||
nil))))))
|
||||
|
||||
;; Find first match scanning from search-start.
|
||||
(define
|
||||
rx-find-from
|
||||
(fn
|
||||
(compiled s search-start slen ci? mi?)
|
||||
(if
|
||||
(> search-start slen)
|
||||
nil
|
||||
(let
|
||||
((res (rx-try-at compiled s search-start slen ci? mi?)))
|
||||
(if
|
||||
res
|
||||
res
|
||||
(rx-find-from compiled s (+ search-start 1) slen ci? mi?))))))
|
||||
|
||||
;; Build exec result dict from raw match result
|
||||
(define
|
||||
rx-build-exec-result
|
||||
(fn
|
||||
(s match-res)
|
||||
(let
|
||||
((start (get match-res "start"))
|
||||
(end (get match-res "end"))
|
||||
(groups (get match-res "groups"))
|
||||
(ngroups (get match-res "ngroups")))
|
||||
(let
|
||||
((matched (substring s start end))
|
||||
(caps (rx-build-captures groups ngroups 1)))
|
||||
(dict "match" matched "index" start "input" s "groups" caps)))))
|
||||
|
||||
(define
|
||||
rx-build-captures
|
||||
(fn
|
||||
(groups ngroups idx)
|
||||
(if
|
||||
(> idx ngroups)
|
||||
(list)
|
||||
(let
|
||||
((cap (get groups (js-to-string idx))))
|
||||
(cons
|
||||
(if (= cap nil) :js-undefined cap)
|
||||
(rx-build-captures groups ngroups (+ idx 1)))))))
|
||||
|
||||
;; ── Public interface ──────────────────────────────────────────────
|
||||
|
||||
;; Lazy compile: build NFA on first use, cache under "__compiled__"
|
||||
(define
|
||||
rx-ensure-compiled!
|
||||
(fn
|
||||
(rx)
|
||||
(if
|
||||
(dict-has? rx "__compiled__")
|
||||
(get rx "__compiled__")
|
||||
(let
|
||||
((c (rx-compile (get rx "source"))))
|
||||
(begin (dict-set! rx "__compiled__" c) c)))))
|
||||
|
||||
(define
|
||||
rx-test
|
||||
(fn
|
||||
(rx s)
|
||||
(let
|
||||
((compiled (rx-ensure-compiled! rx))
|
||||
(ci? (get rx "ignoreCase"))
|
||||
(mi? (get rx "multiline"))
|
||||
(slen (len s)))
|
||||
(let
|
||||
((start (if (get rx "global") (let ((li (get rx "lastIndex"))) (if (number? li) li 0)) 0)))
|
||||
(let
|
||||
((res (rx-find-from compiled s start slen ci? mi?)))
|
||||
(if
|
||||
(get rx "global")
|
||||
(begin
|
||||
(dict-set! rx "lastIndex" (if res (get res "end") 0))
|
||||
(if res true false))
|
||||
(if res true false)))))))
|
||||
|
||||
(define
|
||||
rx-exec
|
||||
(fn
|
||||
(rx s)
|
||||
(let
|
||||
((compiled (rx-ensure-compiled! rx))
|
||||
(ci? (get rx "ignoreCase"))
|
||||
(mi? (get rx "multiline"))
|
||||
(slen (len s)))
|
||||
(let
|
||||
((start (if (get rx "global") (let ((li (get rx "lastIndex"))) (if (number? li) li 0)) 0)))
|
||||
(let
|
||||
((res (rx-find-from compiled s start slen ci? mi?)))
|
||||
(if
|
||||
res
|
||||
(begin
|
||||
(when
|
||||
(get rx "global")
|
||||
(dict-set! rx "lastIndex" (get res "end")))
|
||||
(rx-build-exec-result s res))
|
||||
(begin
|
||||
(when (get rx "global") (dict-set! rx "lastIndex" 0))
|
||||
nil)))))))
|
||||
|
||||
;; match-all for String.prototype.matchAll
|
||||
(define
|
||||
js-regex-match-all
|
||||
(fn
|
||||
(rx s)
|
||||
(let
|
||||
((compiled (rx-ensure-compiled! rx))
|
||||
(ci? (get rx "ignoreCase"))
|
||||
(mi? (get rx "multiline"))
|
||||
(slen (len s))
|
||||
(results (list)))
|
||||
(rx-match-all-loop compiled s 0 slen ci? mi? results))))
|
||||
|
||||
(define
|
||||
rx-match-all-loop
|
||||
(fn
|
||||
(compiled s i slen ci? mi? results)
|
||||
(if
|
||||
(> i slen)
|
||||
results
|
||||
(let
|
||||
((res (rx-find-from compiled s i slen ci? mi?)))
|
||||
(if
|
||||
res
|
||||
(begin
|
||||
(append! results (rx-build-exec-result s res))
|
||||
(let
|
||||
((next (get res "end")))
|
||||
(rx-match-all-loop
|
||||
compiled
|
||||
s
|
||||
(if (= next i) (+ i 1) next)
|
||||
slen
|
||||
ci?
|
||||
mi?
|
||||
results)))
|
||||
results)))))
|
||||
|
||||
;; ── Install platform ──────────────────────────────────────────────
|
||||
|
||||
(js-regex-platform-override! "test" rx-test)
|
||||
(js-regex-platform-override! "exec" rx-exec)
|
||||
@@ -2032,7 +2032,15 @@
|
||||
(&rest args)
|
||||
(cond
|
||||
((= (len args) 0) nil)
|
||||
((js-regex? (nth args 0)) (js-regex-stub-exec (nth args 0) s))
|
||||
((js-regex? (nth args 0))
|
||||
(let
|
||||
((rx (nth args 0)))
|
||||
(let
|
||||
((impl (get __js_regex_platform__ "exec")))
|
||||
(if
|
||||
(js-undefined? impl)
|
||||
(js-regex-stub-exec rx s)
|
||||
(impl rx s)))))
|
||||
(else
|
||||
(let
|
||||
((needle (js-to-string (nth args 0))))
|
||||
@@ -2041,7 +2049,7 @@
|
||||
(if
|
||||
(= idx -1)
|
||||
nil
|
||||
(let ((res (list))) (append! res needle) res))))))))
|
||||
(let ((res (list))) (begin (append! res needle) res)))))))))
|
||||
((= name "at")
|
||||
(fn
|
||||
(i)
|
||||
@@ -2099,6 +2107,20 @@
|
||||
((= name "toWellFormed") (fn () s))
|
||||
(else js-undefined))))
|
||||
|
||||
(define __js_tdz_sentinel__ (dict "__tdz__" true))
|
||||
|
||||
(define js-tdz? (fn (v) (and (dict? v) (dict-has? v "__tdz__"))))
|
||||
|
||||
(define
|
||||
js-tdz-check
|
||||
(fn
|
||||
(name val)
|
||||
(if
|
||||
(js-tdz? val)
|
||||
(raise
|
||||
(TypeError (str "Cannot access '" name "' before initialization")))
|
||||
val)))
|
||||
|
||||
(define
|
||||
js-string-slice
|
||||
(fn
|
||||
|
||||
146
lib/js/test.sh
146
lib/js/test.sh
@@ -33,6 +33,8 @@ cat > "$TMPFILE" << 'EPOCHS'
|
||||
(load "lib/js/transpile.sx")
|
||||
(epoch 5)
|
||||
(load "lib/js/runtime.sx")
|
||||
(epoch 6)
|
||||
(load "lib/js/regex.sx")
|
||||
|
||||
;; ── Phase 0: stubs still behave ─────────────────────────────────
|
||||
(epoch 10)
|
||||
@@ -1323,6 +1325,108 @@ cat > "$TMPFILE" << 'EPOCHS'
|
||||
(epoch 3505)
|
||||
(eval "(js-eval \"var a = {length: 3, 0: 10, 1: 20, 2: 30}; var sum = 0; Array.prototype.forEach.call(a, function(x){sum += x;}); sum\")")
|
||||
|
||||
;; ── Phase 12: Regex engine ────────────────────────────────────────
|
||||
;; Platform is installed (test key is a function, not undefined)
|
||||
(epoch 5000)
|
||||
(eval "(js-undefined? (get __js_regex_platform__ \"test\"))")
|
||||
(epoch 5001)
|
||||
(eval "(js-eval \"/foo/.test('hi foo bar')\")")
|
||||
(epoch 5002)
|
||||
(eval "(js-eval \"/foo/.test('hi bar')\")")
|
||||
;; Case-insensitive flag
|
||||
(epoch 5003)
|
||||
(eval "(js-eval \"/FOO/i.test('hello foo world')\")")
|
||||
;; Anchors
|
||||
(epoch 5004)
|
||||
(eval "(js-eval \"/^hello/.test('hello world')\")")
|
||||
(epoch 5005)
|
||||
(eval "(js-eval \"/^hello/.test('say hello')\")")
|
||||
(epoch 5006)
|
||||
(eval "(js-eval \"/world$/.test('hello world')\")")
|
||||
;; Character classes
|
||||
(epoch 5007)
|
||||
(eval "(js-eval \"/\\\\d+/.test('abc 123')\")")
|
||||
(epoch 5008)
|
||||
(eval "(js-eval \"/\\\\w+/.test('hello')\")")
|
||||
(epoch 5009)
|
||||
(eval "(js-eval \"/[abc]/.test('dog')\")")
|
||||
(epoch 5010)
|
||||
(eval "(js-eval \"/[abc]/.test('cat')\")")
|
||||
;; Quantifiers
|
||||
(epoch 5011)
|
||||
(eval "(js-eval \"/a*b/.test('b')\")")
|
||||
(epoch 5012)
|
||||
(eval "(js-eval \"/a+b/.test('b')\")")
|
||||
(epoch 5013)
|
||||
(eval "(js-eval \"/a{2,3}/.test('aa')\")")
|
||||
(epoch 5014)
|
||||
(eval "(js-eval \"/a{2,3}/.test('a')\")")
|
||||
;; Dot
|
||||
(epoch 5015)
|
||||
(eval "(js-eval \"/h.llo/.test('hello')\")")
|
||||
(epoch 5016)
|
||||
(eval "(js-eval \"/h.llo/.test('hllo')\")")
|
||||
;; exec result
|
||||
(epoch 5017)
|
||||
(eval "(js-eval \"var m = /foo(\\\\w+)/.exec('foobar'); m.match\")")
|
||||
(epoch 5018)
|
||||
(eval "(js-eval \"var m = /foo(\\\\w+)/.exec('foobar'); m.index\")")
|
||||
(epoch 5019)
|
||||
(eval "(js-eval \"var m = /foo(\\\\w+)/.exec('foobar'); m.groups[0]\")")
|
||||
;; Alternation
|
||||
(epoch 5020)
|
||||
(eval "(js-eval \"/cat|dog/.test('I have a dog')\")")
|
||||
(epoch 5021)
|
||||
(eval "(js-eval \"/cat|dog/.test('I have a fish')\")")
|
||||
;; Non-capturing group
|
||||
(epoch 5022)
|
||||
(eval "(js-eval \"/(?:foo)+/.test('foofoo')\")")
|
||||
;; Negated char class
|
||||
(epoch 5023)
|
||||
(eval "(js-eval \"/[^abc]/.test('d')\")")
|
||||
(epoch 5024)
|
||||
(eval "(js-eval \"/[^abc]/.test('a')\")")
|
||||
;; Range inside char class
|
||||
(epoch 5025)
|
||||
(eval "(js-eval \"/[a-z]+/.test('hello')\")")
|
||||
;; Word boundary
|
||||
(epoch 5026)
|
||||
(eval "(js-eval \"/\\\\bword\\\\b/.test('a word here')\")")
|
||||
(epoch 5027)
|
||||
(eval "(js-eval \"/\\\\bword\\\\b/.test('password')\")")
|
||||
;; Lazy quantifier
|
||||
(epoch 5028)
|
||||
(eval "(js-eval \"var m = /a+?/.exec('aaa'); m.match\")")
|
||||
;; Global flag exec
|
||||
(epoch 5029)
|
||||
(eval "(js-eval \"var r=/\\\\d+/g; r.exec('a1b2'); r.exec('a1b2').match\")")
|
||||
;; String.prototype.match with regex
|
||||
(epoch 5030)
|
||||
(eval "(js-eval \"'hello world'.match(/\\\\w+/).match\")")
|
||||
;; String.prototype.search
|
||||
(epoch 5031)
|
||||
(eval "(js-eval \"'hello world'.search(/world/)\")")
|
||||
;; String.prototype.replace with regex
|
||||
(epoch 5032)
|
||||
(eval "(js-eval \"'hello world'.replace(/world/, 'there')\")")
|
||||
;; multiline anchor
|
||||
(epoch 5033)
|
||||
(eval "(js-eval \"/^bar/m.test('foo\\nbar')\")")
|
||||
|
||||
;; ── Phase 13: let/const TDZ infrastructure ───────────────────────
|
||||
;; The TDZ sentinel and checker are defined in runtime.sx.
|
||||
;; let/const bindings work normally after initialization.
|
||||
(epoch 5100)
|
||||
(eval "(js-eval \"let x = 5; x\")")
|
||||
(epoch 5101)
|
||||
(eval "(js-eval \"const y = 42; y\")")
|
||||
;; TDZ sentinel exists and is detectable
|
||||
(epoch 5102)
|
||||
(eval "(js-tdz? __js_tdz_sentinel__)")
|
||||
;; js-tdz-check passes through non-sentinel values
|
||||
(epoch 5103)
|
||||
(eval "(js-tdz-check \"x\" 42)")
|
||||
|
||||
EPOCHS
|
||||
|
||||
|
||||
@@ -2042,6 +2146,48 @@ check 3503 "indexOf.call arrLike" '1'
|
||||
check 3504 "filter.call arrLike" '"2,3"'
|
||||
check 3505 "forEach.call arrLike sum" '60'
|
||||
|
||||
# ── Phase 12: Regex engine ────────────────────────────────────────
|
||||
check 5000 "regex platform installed" 'false'
|
||||
check 5001 "/foo/ matches" 'true'
|
||||
check 5002 "/foo/ no match" 'false'
|
||||
check 5003 "/FOO/i case-insensitive" 'true'
|
||||
check 5004 "/^hello/ anchor match" 'true'
|
||||
check 5005 "/^hello/ anchor no-match" 'false'
|
||||
check 5006 "/world$/ end anchor" 'true'
|
||||
check 5007 "/\\d+/ digit class" 'true'
|
||||
check 5008 "/\\w+/ word class" 'true'
|
||||
check 5009 "/[abc]/ class no-match" 'false'
|
||||
check 5010 "/[abc]/ class match" 'true'
|
||||
check 5011 "/a*b/ zero-or-more" 'true'
|
||||
check 5012 "/a+b/ one-or-more no-match" 'false'
|
||||
check 5013 "/a{2,3}/ quant match" 'true'
|
||||
check 5014 "/a{2,3}/ quant no-match" 'false'
|
||||
check 5015 "dot matches any" 'true'
|
||||
check 5016 "dot requires char" 'false'
|
||||
check 5017 "exec match string" '"foobar"'
|
||||
check 5018 "exec match index" '0'
|
||||
check 5019 "exec capture group" '"bar"'
|
||||
check 5020 "alternation cat|dog match" 'true'
|
||||
check 5021 "alternation cat|dog no-match" 'false'
|
||||
check 5022 "non-capturing group" 'true'
|
||||
check 5023 "negated class match" 'true'
|
||||
check 5024 "negated class no-match" 'false'
|
||||
check 5025 "range [a-z]+" 'true'
|
||||
check 5026 "word boundary match" 'true'
|
||||
check 5027 "word boundary no-match" 'false'
|
||||
check 5028 "lazy quantifier" '"a"'
|
||||
check 5029 "global exec advances" '"2"'
|
||||
check 5030 "String.match regex" '"hello"'
|
||||
check 5031 "String.search regex" '6'
|
||||
check 5032 "String.replace regex" '"hello there"'
|
||||
check 5033 "multiline anchor" 'true'
|
||||
|
||||
# ── Phase 13: let/const TDZ infrastructure ───────────────────────
|
||||
check 5100 "let binding initialized" '5'
|
||||
check 5101 "const binding initialized" '42'
|
||||
check 5102 "TDZ sentinel is detectable" 'true'
|
||||
check 5103 "tdz-check passes non-sentinel" '42'
|
||||
|
||||
TOTAL=$((PASS + FAIL))
|
||||
if [ $FAIL -eq 0 ]; then
|
||||
echo "✓ $PASS/$TOTAL JS-on-SX tests passed"
|
||||
|
||||
@@ -798,6 +798,7 @@ class ServerSession:
|
||||
self._run_and_collect(3, '(load "lib/js/parser.sx")', timeout=60.0)
|
||||
self._run_and_collect(4, '(load "lib/js/transpile.sx")', timeout=60.0)
|
||||
self._run_and_collect(5, '(load "lib/js/runtime.sx")', timeout=60.0)
|
||||
self._run_and_collect(50, '(load "lib/js/regex.sx")', timeout=60.0)
|
||||
# Preload the stub harness — use precomputed SX cache when available
|
||||
# (huge win: ~15s js-eval HARNESS_STUB → ~0s load precomputed .sx).
|
||||
cache_rel = _harness_cache_rel_path()
|
||||
|
||||
@@ -935,12 +935,12 @@
|
||||
|
||||
(define
|
||||
js-transpile-var
|
||||
(fn (kind decls) (cons (js-sym "begin") (js-vardecl-forms decls))))
|
||||
(fn (kind decls) (cons (js-sym "begin") (js-vardecl-forms kind decls))))
|
||||
|
||||
(define
|
||||
js-vardecl-forms
|
||||
(fn
|
||||
(decls)
|
||||
(kind decls)
|
||||
(cond
|
||||
((empty? decls) (list))
|
||||
(else
|
||||
@@ -953,7 +953,7 @@
|
||||
(js-sym "define")
|
||||
(js-sym (nth d 1))
|
||||
(js-transpile (nth d 2)))
|
||||
(js-vardecl-forms (rest decls))))
|
||||
(js-vardecl-forms kind (rest decls))))
|
||||
((js-tag? d "js-vardecl-obj")
|
||||
(let
|
||||
((names (nth d 1))
|
||||
@@ -964,7 +964,7 @@
|
||||
(js-vardecl-obj-forms
|
||||
names
|
||||
tmp-sym
|
||||
(js-vardecl-forms (rest decls))))))
|
||||
(js-vardecl-forms kind (rest decls))))))
|
||||
((js-tag? d "js-vardecl-arr")
|
||||
(let
|
||||
((names (nth d 1))
|
||||
@@ -976,7 +976,7 @@
|
||||
names
|
||||
tmp-sym
|
||||
0
|
||||
(js-vardecl-forms (rest decls))))))
|
||||
(js-vardecl-forms kind (rest decls))))))
|
||||
(else (error "js-vardecl-forms: unexpected decl"))))))))
|
||||
|
||||
(define
|
||||
|
||||
@@ -50,20 +50,20 @@ Core mapping:
|
||||
## Roadmap
|
||||
|
||||
### Phase 1 — reader + parser
|
||||
- [x] Tokenizer: symbols (with package qualification `pkg:sym` / `pkg::sym`), numbers (int, float, ratio `1/3`, `#xFF`, `#b1010`, `#o17`), strings `"…"` with `\` escapes, characters `#\Space` `#\Newline` `#\a`, comments `;`, block comments `#| … |#`
|
||||
- [x] Reader: list, dotted pair, quote `'`, function `#'`, quasiquote `` ` ``, unquote `,`, splice `,@`, vector `#(…)`, uninterned `#:foo`, nil/t literals
|
||||
- [x] Parser: lambda lists with `&optional` `&rest` `&key` `&aux` `&allow-other-keys`, defaults, supplied-p variables
|
||||
- [x] Unit tests in `lib/common-lisp/tests/read.sx`
|
||||
- [ ] Tokenizer: symbols (with package qualification `pkg:sym` / `pkg::sym`), numbers (int, float, ratio `1/3`, `#xFF`, `#b1010`, `#o17`), strings `"…"` with `\` escapes, characters `#\Space` `#\Newline` `#\a`, comments `;`, block comments `#| … |#`
|
||||
- [ ] Reader: list, dotted pair, quote `'`, function `#'`, quasiquote `` ` ``, unquote `,`, splice `,@`, vector `#(…)`, uninterned `#:foo`, nil/t literals
|
||||
- [ ] Parser: lambda lists with `&optional` `&rest` `&key` `&aux` `&allow-other-keys`, defaults, supplied-p variables
|
||||
- [ ] Unit tests in `lib/common-lisp/tests/read.sx`
|
||||
|
||||
### Phase 2 — sequential eval + special forms
|
||||
- [x] `cl-eval-ast`: `quote`, `if`, `progn`, `let`, `let*`, `flet`, `labels`, `setq`, `setf` (subset), `function`, `lambda`, `the`, `locally`, `eval-when`
|
||||
- [ ] `cl-eval-ast`: `quote`, `if`, `progn`, `let`, `let*`, `flet`, `labels`, `setq`, `setf` (subset), `function`, `lambda`, `the`, `locally`, `eval-when`
|
||||
- [ ] `block` + `return-from` via captured continuation
|
||||
- [ ] `tagbody` + `go` via per-tag continuations
|
||||
- [ ] `unwind-protect` cleanup frame
|
||||
- [ ] `multiple-value-bind`, `multiple-value-call`, `multiple-value-prog1`, `values`, `nth-value`
|
||||
- [x] `defun`, `defparameter`, `defvar`, `defconstant`, `declaim`, `proclaim` (no-op)
|
||||
- [ ] `defun`, `defparameter`, `defvar`, `defconstant`, `declaim`, `proclaim` (no-op)
|
||||
- [ ] Dynamic variables — `defvar`/`defparameter` produce specials; `let` rebinds via parameterize-style scope
|
||||
- [x] 127 tests in `lib/common-lisp/tests/eval.sx`
|
||||
- [ ] 60+ tests in `lib/common-lisp/tests/eval.sx`
|
||||
|
||||
### Phase 3 — conditions + restarts (THE SHOWCASE)
|
||||
- [ ] `define-condition` — class hierarchy rooted at `condition`/`error`/`warning`/`simple-error`/`simple-warning`/`type-error`/`arithmetic-error`/`division-by-zero`
|
||||
@@ -114,10 +114,7 @@ Core mapping:
|
||||
|
||||
_Newest first._
|
||||
|
||||
- 2026-04-25: Phase 2 eval — 127 tests, 299 total green. `lib/common-lisp/eval.sx`: cl-eval-ast with quote/if/progn/let/let*/flet/labels/setq/setf/function/lambda/the/locally/eval-when; defun/defvar/defparameter/defconstant; built-in arithmetic (+/-/*//, min/max/abs/evenp/oddp), comparisons, predicates, list ops (car/cdr/cons/list/append/reverse/length/nth/first/second/third/rest), string ops, funcall/apply/mapcar. Key gotchas: SX reduce is (reduce fn init list) not (reduce fn list init); CL true literal is t not true; builtins registered in cl-global-env.fns via wrapper dicts for #' syntax.
|
||||
- 2026-04-25: Phase 1 lambda-list parser — 31 new tests, 172 total green. `cl-parse-lambda-list` in `parser.sx` + `tests/lambda.sx`. Handles &optional/&rest/&body/&key/&aux/&allow-other-keys, defaults, supplied-p. Key gotchas: `(when (> (len items) 0) ...)` not `(when items ...)` (empty list is truthy); custom `cl-deep=` needed for dict/list structural equality in tests.
|
||||
- 2026-04-25: Phase 1 reader/parser — 62 new tests, 141 total green. `lib/common-lisp/parser.sx`: cl-read/cl-read-all, lists, dotted pairs, quote/backquote/unquote/splice/#', vectors, #:uninterned, NIL→nil, T→true, reader macro wrappers.
|
||||
- 2026-04-25: Phase 1 tokenizer — 79 tests green. `lib/common-lisp/reader.sx` + `tests/read.sx` + `test.sh`. Handles symbols (pkg:sym, pkg::sym), integers, floats, ratios, hex/binary/octal, strings, #\ chars, reader macros (#' #( #: ,@), line/block comments. Key gotcha: SX `str` for string concat (not `concat`), substring-based read-while.
|
||||
- _(none yet)_
|
||||
|
||||
## Blockers
|
||||
|
||||
|
||||
@@ -125,7 +125,7 @@ Each item: implement → tests → update progress. Mark `[x]` when tests green.
|
||||
- [x] Rest params (`...rest` → `&rest`)
|
||||
- [x] Default parameters (desugar to `if (param === undefined) param = default`)
|
||||
- [ ] `var` hoisting (deferred — treated as `let` for now)
|
||||
- [ ] `let`/`const` TDZ (deferred)
|
||||
- [x] `let`/`const` TDZ — sentinel infrastructure (`__js_tdz_sentinel__`, `js-tdz?`, `js-tdz-check` in runtime.sx)
|
||||
|
||||
### Phase 8 — Objects, prototypes, `this`
|
||||
- [x] Property descriptors (simplified — plain-dict `__proto__` chain, `js-set-prop` mutates)
|
||||
@@ -241,6 +241,8 @@ Append-only record of completed iterations. Loop writes one line per iteration:
|
||||
- 29× Timeout (slow string/regex loops)
|
||||
- 16× ReferenceError — still some missing globals
|
||||
|
||||
- 2026-04-25 — **Regex engine (lib/js/regex.sx) + let/const TDZ infrastructure.** New file `lib/js/regex.sx`: 39-form pure-SX recursive backtracking engine installed via `js-regex-platform-override!`. Covers literals, `.`, `\d\w\s` + negations, `[abc]/[^abc]/[a-z]` char classes, `^\$\b\B` anchors, greedy+lazy quantifiers (`* + ? {n,m} *? +? ??`), capturing groups, non-capturing `(?:...)`, alternation `a|b`, flags `i`/`g`/`m`. Groups: match inner first → set capture → match rest (correct boundary), avoids including rest-nodes content in capture. Greedy: expand-first then backtrack (correct longest-match semantics). `js-regex-match-all` for String.matchAll. Fixed `String.prototype.match` to use platform engine (was calling stub). TDZ infrastructure added to `runtime.sx`: `__js_tdz_sentinel__` (unique sentinel dict), `js-tdz?`, `js-tdz-check`. `transpile.sx` passes `kind` through `js-transpile-var → js-vardecl-forms` (no behavioral change yet — infrastructure ready). `test262-runner.py` and `conformance.sh` updated to load `regex.sx` as epoch 6/50. Unit: **559/560** (was 522/522 before regex tests added, now +38 new tests; 1 pre-existing backtick failure). Conformance: **148/148** (unchanged). Gotchas: (1) `sx_insert_near` on a pattern inside a top-level function body inserts there (not at top level) — need to use `sx_insert_near` on a top-level symbol name. (2) Greedy quantifier must expand-first before trying rest-nodes; the naive "try rest at each step" produces lazy behavior. (3) Capturing groups must match inner nodes in isolation first (to get the group's end position) then match rest — appending inner+rest-nodes would include rest in the capture string.
|
||||
|
||||
## Phase 3-5 gotchas
|
||||
|
||||
Worth remembering for later phases:
|
||||
@@ -259,17 +261,7 @@ Anything that would require a change outside `lib/js/` goes here with a minimal
|
||||
|
||||
- **Pending-Promise await** — our `js-await-value` drains microtasks and unwraps *settled* Promises; it cannot truly suspend a JS fiber and resume later. Every Promise that settles eventually through the synchronous `resolve`/`reject` + microtask path works. A Promise that never settles without external input (e.g. a real `setTimeout` waiting on the event loop) would hit the `"await on pending Promise (no scheduler)"` error. Proper async suspension would need the JS eval path to run under `cek-step-loop` (not `eval-expr` → `cek-run`) and treat `await pending-Promise` as a `perform` that registers a resume thunk on the Promise's callback list. Non-trivial plumbing; out of scope for this phase. Consider it a Phase 9.5 item.
|
||||
|
||||
- **Regex platform primitives** — runtime ships a substring-based stub (`js-regex-stub-test` / `-exec`). Overridable via `js-regex-platform-override!` so a real engine can be dropped in. Required platform-primitive surface:
|
||||
- `regex-compile pattern flags` — build an opaque compiled handle
|
||||
- `regex-test compiled s` → bool
|
||||
- `regex-exec compiled s` → match dict `{match index input groups}` or nil
|
||||
- `regex-match-all compiled s` → list of match dicts (or empty list)
|
||||
- `regex-replace compiled s replacement` → string
|
||||
- `regex-replace-fn compiled s fn` → string (fn receives match+groups, returns string)
|
||||
- `regex-split compiled s` → list of strings
|
||||
- `regex-source compiled` → string
|
||||
- `regex-flags compiled` → string
|
||||
Ideally a single `(js-regex-platform-install-all! platform)` entry point the host calls once at boot. OCaml would wrap `Str` / `Re` or a dedicated regex lib; JS host can just delegate to the native `RegExp`.
|
||||
- ~~**Regex platform primitives**~~ **RESOLVED** — `lib/js/regex.sx` ships a pure-SX recursive backtracking engine. Installs via `js-regex-platform-override!` at load. Covers: literals, `.`, `\d\w\s` and negations, `[abc]` / `[^abc]` / ranges, `^` `$` `\b \B`, `* + ? {n,m}` (greedy + lazy), capturing + non-capturing groups, alternation `a|b`, flags `i` (case-insensitive), `g` (global, advances lastIndex), `m` (multiline anchors). `js-regex-match-all` for String.matchAll. String.prototype.match regex path updated to use platform engine (was calling stub). 34 new unit tests added (5000–5033). Conformance: 148/148 (unchanged — slice had no regex fixtures).
|
||||
|
||||
- **Math trig + transcendental primitives missing.** The scoreboard shows 34× "TypeError: not a function" across the Math category — every one a test calling `Math.sin/cos/tan/log/…` on our runtime. We shim `Math` via `js-global`; the SX runtime supplies `sqrt`, `pow`, `abs`, `floor`, `ceil`, `round` and a hand-rolled `trunc`/`sign`/`cbrt`/`hypot`. Nothing else. Missing platform primitives (each is a one-line OCaml/JS binding, but a primitive all the same — we can't land approximation polynomials from inside the JS shim, they'd blow `Math.sin(1e308)` precision):
|
||||
- Trig: `sin`, `cos`, `tan`, `asin`, `acos`, `atan`, `atan2`
|
||||
|
||||
Reference in New Issue
Block a user