Compare commits
6 Commits
loops/comm
...
loops/tcl
| Author | SHA1 | Date | |
|---|---|---|---|
| c8d7fdd59a | |||
| 82da16e4bb | |||
| 35aa998fcc | |||
| 6ee052593c | |||
| 1a17d8d232 | |||
| 666e29d5f0 |
@@ -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")
|
|
||||||
41
lib/tcl/parser.sx
Normal file
41
lib/tcl/parser.sx
Normal file
@@ -0,0 +1,41 @@
|
|||||||
|
; Tcl parser — thin layer over tcl-tokenize
|
||||||
|
; Adds tcl-parse entry point and word utility fns
|
||||||
|
|
||||||
|
; Entry point: parse Tcl source to a list of commands.
|
||||||
|
; Returns same structure as tcl-tokenize.
|
||||||
|
(define tcl-parse (fn (src) (tcl-tokenize src)))
|
||||||
|
|
||||||
|
; True if word has no substitutions — value can be read statically.
|
||||||
|
; braced words are always simple. compound words are simple when all
|
||||||
|
; parts are plain text with no var/cmd parts.
|
||||||
|
(define tcl-word-simple?
|
||||||
|
(fn (word)
|
||||||
|
(cond
|
||||||
|
((= (get word :type) "braced") true)
|
||||||
|
((= (get word :type) "compound")
|
||||||
|
(let ((parts (get word :parts)))
|
||||||
|
(every? (fn (p) (= (get p :type) "text")) parts)))
|
||||||
|
(else false))))
|
||||||
|
|
||||||
|
; Concatenate text parts of a simple word into a single string.
|
||||||
|
; For braced words returns :value directly.
|
||||||
|
; For compound words with only text parts, joins them.
|
||||||
|
; Returns nil for words with substitutions.
|
||||||
|
(define tcl-word-literal
|
||||||
|
(fn (word)
|
||||||
|
(cond
|
||||||
|
((= (get word :type) "braced") (get word :value))
|
||||||
|
((= (get word :type) "compound")
|
||||||
|
(if (tcl-word-simple? word)
|
||||||
|
(join "" (map (fn (p) (get p :value)) (get word :parts)))
|
||||||
|
nil))
|
||||||
|
(else nil))))
|
||||||
|
|
||||||
|
; Number of words in a parsed command.
|
||||||
|
(define tcl-cmd-len
|
||||||
|
(fn (cmd) (len (get cmd :words))))
|
||||||
|
|
||||||
|
; Nth word literal from a command (index 0 = command name).
|
||||||
|
; Returns nil if word has substitutions.
|
||||||
|
(define tcl-nth-literal
|
||||||
|
(fn (cmd n) (tcl-word-literal (nth (get cmd :words) n))))
|
||||||
570
lib/tcl/runtime.sx
Normal file
570
lib/tcl/runtime.sx
Normal file
@@ -0,0 +1,570 @@
|
|||||||
|
; Tcl-on-SX runtime evaluator
|
||||||
|
; State: {:frame frame :commands cmd-table :result last-result :output accumulated-output}
|
||||||
|
|
||||||
|
(define make-frame (fn (level parent) {:level level :locals {} :parent parent}))
|
||||||
|
|
||||||
|
(define
|
||||||
|
frame-lookup
|
||||||
|
(fn
|
||||||
|
(frame name)
|
||||||
|
(if
|
||||||
|
(nil? frame)
|
||||||
|
nil
|
||||||
|
(let
|
||||||
|
((val (get (get frame :locals) name)))
|
||||||
|
(if (nil? val) (frame-lookup (get frame :parent) name) val)))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
frame-set-top
|
||||||
|
(fn
|
||||||
|
(frame name val)
|
||||||
|
(assoc frame :locals (assoc (get frame :locals) name val))))
|
||||||
|
|
||||||
|
(define make-tcl-interp (fn () {:result "" :output "" :code 0 :frame (make-frame 0 nil) :commands {}}))
|
||||||
|
|
||||||
|
(define
|
||||||
|
tcl-register
|
||||||
|
(fn
|
||||||
|
(interp name f)
|
||||||
|
(assoc interp :commands (assoc (get interp :commands) name f))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
tcl-var-get
|
||||||
|
(fn
|
||||||
|
(interp name)
|
||||||
|
(let
|
||||||
|
((val (frame-lookup (get interp :frame) name)))
|
||||||
|
(if
|
||||||
|
(nil? val)
|
||||||
|
(error (str "can't read \"" name "\": no such variable"))
|
||||||
|
val))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
tcl-var-set
|
||||||
|
(fn
|
||||||
|
(interp name val)
|
||||||
|
(assoc interp :frame (frame-set-top (get interp :frame) name val))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
tcl-eval-parts
|
||||||
|
(fn
|
||||||
|
(parts interp)
|
||||||
|
(reduce
|
||||||
|
(fn
|
||||||
|
(acc part)
|
||||||
|
(let
|
||||||
|
((type (get part :type)) (cur-interp (get acc :interp)))
|
||||||
|
(cond
|
||||||
|
((equal? type "text") {:values (append (get acc :values) (list (get part :value))) :interp cur-interp})
|
||||||
|
((equal? type "var") {:values (append (get acc :values) (list (tcl-var-get cur-interp (get part :name)))) :interp cur-interp})
|
||||||
|
((equal? type "var-arr")
|
||||||
|
(let
|
||||||
|
((key-acc (tcl-eval-parts (get part :key) cur-interp)))
|
||||||
|
(let
|
||||||
|
((key (join "" (get key-acc :values)))
|
||||||
|
(next-interp (get key-acc :interp)))
|
||||||
|
{:values (append (get acc :values) (list (tcl-var-get next-interp (str (get part :name) "(" key ")")))) :interp next-interp})))
|
||||||
|
((equal? type "cmd")
|
||||||
|
(let
|
||||||
|
((new-interp (tcl-eval-string cur-interp (get part :src))))
|
||||||
|
{:values (append (get acc :values) (list (get new-interp :result))) :interp new-interp}))
|
||||||
|
(else (error (str "tcl: unknown part type: " type))))))
|
||||||
|
{:values (quote ()) :interp interp}
|
||||||
|
parts)))
|
||||||
|
|
||||||
|
(define
|
||||||
|
tcl-eval-word
|
||||||
|
(fn
|
||||||
|
(word interp)
|
||||||
|
(let
|
||||||
|
((type (get word :type)))
|
||||||
|
(cond
|
||||||
|
((equal? type "braced") {:interp interp :value (get word :value)})
|
||||||
|
((equal? type "compound")
|
||||||
|
(let
|
||||||
|
((result (tcl-eval-parts (get word :parts) interp)))
|
||||||
|
{:interp (get result :interp) :value (join "" (get result :values))}))
|
||||||
|
((equal? type "expand") (tcl-eval-word (get word :word) interp))
|
||||||
|
(else (error (str "tcl: unknown word type: " type)))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
tcl-list-split
|
||||||
|
(fn
|
||||||
|
(s)
|
||||||
|
(define chars (split s ""))
|
||||||
|
(define len-s (len chars))
|
||||||
|
(define
|
||||||
|
go
|
||||||
|
(fn
|
||||||
|
(i acc cur-item depth)
|
||||||
|
(if
|
||||||
|
(>= i len-s)
|
||||||
|
(if (> (len cur-item) 0) (append acc (list cur-item)) acc)
|
||||||
|
(let
|
||||||
|
((c (nth chars i)))
|
||||||
|
(cond
|
||||||
|
((equal? c "{")
|
||||||
|
(if
|
||||||
|
(= depth 0)
|
||||||
|
(go (+ i 1) acc "" (+ depth 1))
|
||||||
|
(go (+ i 1) acc (str cur-item c) (+ depth 1))))
|
||||||
|
((equal? c "}")
|
||||||
|
(if
|
||||||
|
(= depth 1)
|
||||||
|
(go (+ i 1) (append acc (list cur-item)) "" 0)
|
||||||
|
(go (+ i 1) acc (str cur-item c) (- depth 1))))
|
||||||
|
((equal? c " ")
|
||||||
|
(if
|
||||||
|
(and (= depth 0) (> (len cur-item) 0))
|
||||||
|
(go (+ i 1) (append acc (list cur-item)) "" 0)
|
||||||
|
(go
|
||||||
|
(+ i 1)
|
||||||
|
acc
|
||||||
|
(if (> depth 0) (str cur-item c) cur-item)
|
||||||
|
depth)))
|
||||||
|
(else (go (+ i 1) acc (str cur-item c) depth)))))))
|
||||||
|
(go 0 (list) "" 0)))
|
||||||
|
|
||||||
|
(define
|
||||||
|
tcl-eval-words
|
||||||
|
(fn
|
||||||
|
(words interp)
|
||||||
|
(reduce
|
||||||
|
(fn
|
||||||
|
(acc w)
|
||||||
|
(let
|
||||||
|
((cur-interp (get acc :interp)))
|
||||||
|
(if
|
||||||
|
(equal? (get w :type) "expand")
|
||||||
|
(let
|
||||||
|
((wr (tcl-eval-word (get w :word) cur-interp)))
|
||||||
|
{:values (append (get acc :values) (tcl-list-split (get wr :value))) :interp (get wr :interp)})
|
||||||
|
(let ((wr (tcl-eval-word w cur-interp))) {:values (append (get acc :values) (list (get wr :value))) :interp (get wr :interp)}))))
|
||||||
|
{:values (quote ()) :interp interp}
|
||||||
|
words)))
|
||||||
|
|
||||||
|
(define
|
||||||
|
tcl-eval-cmd
|
||||||
|
(fn
|
||||||
|
(interp cmd)
|
||||||
|
(let
|
||||||
|
((wr (tcl-eval-words (get cmd :words) interp)))
|
||||||
|
(let
|
||||||
|
((words (get wr :values)) (cur-interp (get wr :interp)))
|
||||||
|
(if
|
||||||
|
(= 0 (len words))
|
||||||
|
cur-interp
|
||||||
|
(let
|
||||||
|
((cmd-name (first words)) (cmd-args (rest words)))
|
||||||
|
(let
|
||||||
|
((cmd-fn (get (get cur-interp :commands) cmd-name)))
|
||||||
|
(if
|
||||||
|
(nil? cmd-fn)
|
||||||
|
(error (str "unknown command: \"" cmd-name "\""))
|
||||||
|
(cmd-fn cur-interp cmd-args)))))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
tcl-eval-script
|
||||||
|
(fn
|
||||||
|
(interp cmds)
|
||||||
|
(if
|
||||||
|
(or (= 0 (len cmds)) (not (= 0 (get interp :code))))
|
||||||
|
interp
|
||||||
|
(tcl-eval-script (tcl-eval-cmd interp (first cmds)) (rest cmds)))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
tcl-eval-string
|
||||||
|
(fn (interp src) (tcl-eval-script interp (tcl-parse src))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
tcl-cmd-set
|
||||||
|
(fn
|
||||||
|
(interp args)
|
||||||
|
(if
|
||||||
|
(= (len args) 1)
|
||||||
|
(assoc interp :result (tcl-var-get interp (first args)))
|
||||||
|
(let
|
||||||
|
((val (nth args 1)))
|
||||||
|
(assoc (tcl-var-set interp (first args) val) :result val)))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
tcl-cmd-puts
|
||||||
|
(fn
|
||||||
|
(interp args)
|
||||||
|
(let
|
||||||
|
((text (last args))
|
||||||
|
(no-nl
|
||||||
|
(and
|
||||||
|
(> (len args) 1)
|
||||||
|
(equal? (first args) "-nonewline"))))
|
||||||
|
(let
|
||||||
|
((line (if no-nl text (str text "\n"))))
|
||||||
|
(assoc interp :output (str (get interp :output) line))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
tcl-cmd-incr
|
||||||
|
(fn
|
||||||
|
(interp args)
|
||||||
|
(let
|
||||||
|
((name (first args))
|
||||||
|
(delta
|
||||||
|
(if
|
||||||
|
(> (len args) 1)
|
||||||
|
(parse-int (nth args 1))
|
||||||
|
1)))
|
||||||
|
(let
|
||||||
|
((new-val (str (+ (parse-int (tcl-var-get interp name)) delta))))
|
||||||
|
(assoc (tcl-var-set interp name new-val) :result new-val)))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
tcl-cmd-append
|
||||||
|
(fn
|
||||||
|
(interp args)
|
||||||
|
(let
|
||||||
|
((name (first args)) (suffix (join "" (rest args))))
|
||||||
|
(let
|
||||||
|
((cur (let ((v (frame-lookup (get interp :frame) name))) (if (nil? v) "" v))))
|
||||||
|
(let
|
||||||
|
((new-val (str cur suffix)))
|
||||||
|
(assoc (tcl-var-set interp name new-val) :result new-val))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
tcl-true?
|
||||||
|
(fn
|
||||||
|
(s)
|
||||||
|
(not
|
||||||
|
(or (equal? s "0") (equal? s "") (equal? s "false") (equal? s "no")))))
|
||||||
|
|
||||||
|
(define tcl-false? (fn (s) (not (tcl-true? s))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
tcl-expr-compute
|
||||||
|
(fn
|
||||||
|
(tokens)
|
||||||
|
(let
|
||||||
|
((n (len tokens)))
|
||||||
|
(cond
|
||||||
|
((= n 1) (first tokens))
|
||||||
|
((= n 2)
|
||||||
|
(let
|
||||||
|
((op (first tokens)) (x (nth tokens 1)))
|
||||||
|
(if
|
||||||
|
(equal? op "!")
|
||||||
|
(if (tcl-false? x) "1" "0")
|
||||||
|
(error (str "expr: unknown unary op: " op)))))
|
||||||
|
((= n 3)
|
||||||
|
(let
|
||||||
|
((l (first tokens)) (op (nth tokens 1)) (r (nth tokens 2)))
|
||||||
|
(cond
|
||||||
|
((equal? op "+") (str (+ (parse-int l) (parse-int r))))
|
||||||
|
((equal? op "-") (str (- (parse-int l) (parse-int r))))
|
||||||
|
((equal? op "*") (str (* (parse-int l) (parse-int r))))
|
||||||
|
((equal? op "/") (str (/ (parse-int l) (parse-int r))))
|
||||||
|
((equal? op "%") (str (mod (parse-int l) (parse-int r))))
|
||||||
|
((equal? op "==") (if (equal? l r) "1" "0"))
|
||||||
|
((equal? op "!=") (if (equal? l r) "0" "1"))
|
||||||
|
((equal? op "<")
|
||||||
|
(if (< (parse-int l) (parse-int r)) "1" "0"))
|
||||||
|
((equal? op ">")
|
||||||
|
(if (> (parse-int l) (parse-int r)) "1" "0"))
|
||||||
|
((equal? op "<=")
|
||||||
|
(if (<= (parse-int l) (parse-int r)) "1" "0"))
|
||||||
|
((equal? op ">=")
|
||||||
|
(if (>= (parse-int l) (parse-int r)) "1" "0"))
|
||||||
|
((equal? op "&&")
|
||||||
|
(if (and (tcl-true? l) (tcl-true? r)) "1" "0"))
|
||||||
|
((equal? op "||")
|
||||||
|
(if (or (tcl-true? l) (tcl-true? r)) "1" "0"))
|
||||||
|
(else (error (str "expr: unknown op: " op))))))
|
||||||
|
(else (error (str "expr: complex expr not yet supported")))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
tcl-expr-eval
|
||||||
|
(fn
|
||||||
|
(interp s)
|
||||||
|
(let
|
||||||
|
((cmds (tcl-parse s)))
|
||||||
|
(if
|
||||||
|
(= 0 (len cmds))
|
||||||
|
{:result "0" :interp interp}
|
||||||
|
(let
|
||||||
|
((wr (tcl-eval-words (get (first cmds) :words) interp)))
|
||||||
|
{:result (tcl-expr-compute (get wr :values)) :interp (get wr :interp)})))))
|
||||||
|
|
||||||
|
(define tcl-cmd-break (fn (interp args) (assoc interp :code 3)))
|
||||||
|
|
||||||
|
(define tcl-cmd-continue (fn (interp args) (assoc interp :code 4)))
|
||||||
|
|
||||||
|
(define
|
||||||
|
tcl-cmd-return
|
||||||
|
(fn
|
||||||
|
(interp args)
|
||||||
|
(let
|
||||||
|
((val (if (> (len args) 0) (last args) "")))
|
||||||
|
(assoc (assoc interp :result val) :code 2))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
tcl-cmd-error
|
||||||
|
(fn
|
||||||
|
(interp args)
|
||||||
|
(let
|
||||||
|
((msg (if (> (len args) 0) (first args) "error")))
|
||||||
|
(assoc (assoc interp :result msg) :code 1))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
tcl-cmd-unset
|
||||||
|
(fn
|
||||||
|
(interp args)
|
||||||
|
(reduce
|
||||||
|
(fn
|
||||||
|
(i name)
|
||||||
|
(let
|
||||||
|
((frame (get i :frame)))
|
||||||
|
(let
|
||||||
|
((new-locals (reduce (fn (acc k) (if (equal? k name) acc (assoc acc k (get (get frame :locals) k)))) {} (keys (get frame :locals)))))
|
||||||
|
(assoc i :frame (assoc frame :locals new-locals)))))
|
||||||
|
interp
|
||||||
|
args)))
|
||||||
|
|
||||||
|
(define
|
||||||
|
tcl-cmd-lappend
|
||||||
|
(fn
|
||||||
|
(interp args)
|
||||||
|
(let
|
||||||
|
((name (first args)) (items (rest args)))
|
||||||
|
(let
|
||||||
|
((cur (let ((v (frame-lookup (get interp :frame) name))) (if (nil? v) "" v))))
|
||||||
|
(let
|
||||||
|
((new-val (if (equal? cur "") (join " " items) (str cur " " (join " " items)))))
|
||||||
|
(assoc (tcl-var-set interp name new-val) :result new-val))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
tcl-cmd-eval
|
||||||
|
(fn (interp args) (tcl-eval-string interp (join " " args))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
tcl-while-loop
|
||||||
|
(fn
|
||||||
|
(interp cond-str body)
|
||||||
|
(let
|
||||||
|
((er (tcl-expr-eval interp cond-str)))
|
||||||
|
(if
|
||||||
|
(tcl-false? (get er :result))
|
||||||
|
(get er :interp)
|
||||||
|
(let
|
||||||
|
((body-result (tcl-eval-string (get er :interp) body)))
|
||||||
|
(let
|
||||||
|
((code (get body-result :code)))
|
||||||
|
(cond
|
||||||
|
((= code 3) (assoc body-result :code 0))
|
||||||
|
((= code 2) body-result)
|
||||||
|
((= code 1) body-result)
|
||||||
|
(else
|
||||||
|
(tcl-while-loop
|
||||||
|
(assoc body-result :code 0)
|
||||||
|
cond-str
|
||||||
|
body)))))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
tcl-cmd-while
|
||||||
|
(fn
|
||||||
|
(interp args)
|
||||||
|
(tcl-while-loop interp (first args) (nth args 1))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
tcl-cmd-if
|
||||||
|
(fn
|
||||||
|
(interp args)
|
||||||
|
(let
|
||||||
|
((er (tcl-expr-eval interp (first args))))
|
||||||
|
(let
|
||||||
|
((cond-true (tcl-true? (get er :result)))
|
||||||
|
(new-interp (get er :interp))
|
||||||
|
(rest-args (rest args)))
|
||||||
|
(let
|
||||||
|
((adj (if (and (> (len rest-args) 0) (equal? (first rest-args) "then")) (rest rest-args) rest-args)))
|
||||||
|
(let
|
||||||
|
((then-body (first adj)) (rest2 (rest adj)))
|
||||||
|
(if
|
||||||
|
cond-true
|
||||||
|
(tcl-eval-string new-interp then-body)
|
||||||
|
(cond
|
||||||
|
((= 0 (len rest2)) new-interp)
|
||||||
|
((equal? (first rest2) "else")
|
||||||
|
(if
|
||||||
|
(> (len rest2) 1)
|
||||||
|
(tcl-eval-string new-interp (nth rest2 1))
|
||||||
|
new-interp))
|
||||||
|
((equal? (first rest2) "elseif")
|
||||||
|
(tcl-cmd-if new-interp (rest rest2)))
|
||||||
|
(else new-interp)))))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
tcl-for-loop
|
||||||
|
(fn
|
||||||
|
(interp cond-str step body)
|
||||||
|
(let
|
||||||
|
((er (tcl-expr-eval interp cond-str)))
|
||||||
|
(if
|
||||||
|
(tcl-false? (get er :result))
|
||||||
|
(get er :interp)
|
||||||
|
(let
|
||||||
|
((body-result (tcl-eval-string (get er :interp) body)))
|
||||||
|
(let
|
||||||
|
((code (get body-result :code)))
|
||||||
|
(cond
|
||||||
|
((= code 3) (assoc body-result :code 0))
|
||||||
|
((= code 2) body-result)
|
||||||
|
((= code 1) body-result)
|
||||||
|
(else
|
||||||
|
(let
|
||||||
|
((step-result (tcl-eval-string (assoc body-result :code 0) step)))
|
||||||
|
(tcl-for-loop
|
||||||
|
(assoc step-result :code 0)
|
||||||
|
cond-str
|
||||||
|
step
|
||||||
|
body))))))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
tcl-cmd-for
|
||||||
|
(fn
|
||||||
|
(interp args)
|
||||||
|
(let
|
||||||
|
((init-body (first args))
|
||||||
|
(cond-str (nth args 1))
|
||||||
|
(step (nth args 2))
|
||||||
|
(body (nth args 3)))
|
||||||
|
(let
|
||||||
|
((init-result (tcl-eval-string interp init-body)))
|
||||||
|
(tcl-for-loop init-result cond-str step body)))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
tcl-foreach-loop
|
||||||
|
(fn
|
||||||
|
(interp var-name items body)
|
||||||
|
(if
|
||||||
|
(= 0 (len items))
|
||||||
|
interp
|
||||||
|
(let
|
||||||
|
((body-result (tcl-eval-string (tcl-var-set interp var-name (first items)) body)))
|
||||||
|
(let
|
||||||
|
((code (get body-result :code)))
|
||||||
|
(cond
|
||||||
|
((= code 3) (assoc body-result :code 0))
|
||||||
|
((= code 2) body-result)
|
||||||
|
((= code 1) body-result)
|
||||||
|
(else
|
||||||
|
(tcl-foreach-loop
|
||||||
|
(assoc body-result :code 0)
|
||||||
|
var-name
|
||||||
|
(rest items)
|
||||||
|
body))))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
tcl-cmd-foreach
|
||||||
|
(fn
|
||||||
|
(interp args)
|
||||||
|
(let
|
||||||
|
((var-name (first args))
|
||||||
|
(list-str (nth args 1))
|
||||||
|
(body (nth args 2)))
|
||||||
|
(tcl-foreach-loop interp var-name (tcl-list-split list-str) body))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
tcl-cmd-switch
|
||||||
|
(fn
|
||||||
|
(interp args)
|
||||||
|
(let
|
||||||
|
((str-val (first args)) (body (nth args 1)))
|
||||||
|
(let
|
||||||
|
((pairs (tcl-list-split body)))
|
||||||
|
(define
|
||||||
|
try-pairs
|
||||||
|
(fn
|
||||||
|
(ps)
|
||||||
|
(if
|
||||||
|
(= 0 (len ps))
|
||||||
|
interp
|
||||||
|
(let
|
||||||
|
((pat (first ps)) (bdy (nth ps 1)))
|
||||||
|
(if
|
||||||
|
(or (equal? pat str-val) (equal? pat "default"))
|
||||||
|
(if
|
||||||
|
(equal? bdy "-")
|
||||||
|
(try-pairs (rest (rest ps)))
|
||||||
|
(tcl-eval-string interp bdy))
|
||||||
|
(try-pairs (rest (rest ps))))))))
|
||||||
|
(try-pairs pairs)))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
tcl-cmd-expr
|
||||||
|
(fn
|
||||||
|
(interp args)
|
||||||
|
(let
|
||||||
|
((s (join " " args)))
|
||||||
|
(let
|
||||||
|
((er (tcl-expr-eval interp s)))
|
||||||
|
(assoc (get er :interp) :result (get er :result))))))
|
||||||
|
|
||||||
|
(define tcl-cmd-gets (fn (interp args) (assoc interp :result "")))
|
||||||
|
|
||||||
|
(define
|
||||||
|
tcl-cmd-subst
|
||||||
|
(fn (interp args) (assoc interp :result (last args))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
tcl-cmd-format
|
||||||
|
(fn (interp args) (assoc interp :result (join "" args))))
|
||||||
|
|
||||||
|
(define tcl-cmd-scan (fn (interp args) (assoc interp :result "0")))
|
||||||
|
|
||||||
|
(define
|
||||||
|
make-default-tcl-interp
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(let
|
||||||
|
((i (make-tcl-interp)))
|
||||||
|
(let
|
||||||
|
((i (tcl-register i "set" tcl-cmd-set)))
|
||||||
|
(let
|
||||||
|
((i (tcl-register i "puts" tcl-cmd-puts)))
|
||||||
|
(let
|
||||||
|
((i (tcl-register i "incr" tcl-cmd-incr)))
|
||||||
|
(let
|
||||||
|
((i (tcl-register i "append" tcl-cmd-append)))
|
||||||
|
(let
|
||||||
|
((i (tcl-register i "unset" tcl-cmd-unset)))
|
||||||
|
(let
|
||||||
|
((i (tcl-register i "lappend" tcl-cmd-lappend)))
|
||||||
|
(let
|
||||||
|
((i (tcl-register i "eval" tcl-cmd-eval)))
|
||||||
|
(let
|
||||||
|
((i (tcl-register i "if" tcl-cmd-if)))
|
||||||
|
(let
|
||||||
|
((i (tcl-register i "while" tcl-cmd-while)))
|
||||||
|
(let
|
||||||
|
((i (tcl-register i "for" tcl-cmd-for)))
|
||||||
|
(let
|
||||||
|
((i (tcl-register i "foreach" tcl-cmd-foreach)))
|
||||||
|
(let
|
||||||
|
((i (tcl-register i "switch" tcl-cmd-switch)))
|
||||||
|
(let
|
||||||
|
((i (tcl-register i "break" tcl-cmd-break)))
|
||||||
|
(let
|
||||||
|
((i (tcl-register i "continue" tcl-cmd-continue)))
|
||||||
|
(let
|
||||||
|
((i (tcl-register i "return" tcl-cmd-return)))
|
||||||
|
(let
|
||||||
|
((i (tcl-register i "error" tcl-cmd-error)))
|
||||||
|
(let
|
||||||
|
((i (tcl-register i "expr" tcl-cmd-expr)))
|
||||||
|
(let
|
||||||
|
((i (tcl-register i "gets" tcl-cmd-gets)))
|
||||||
|
(let
|
||||||
|
((i (tcl-register i "subst" tcl-cmd-subst)))
|
||||||
|
(let
|
||||||
|
((i (tcl-register i "format" tcl-cmd-format)))
|
||||||
|
(tcl-register
|
||||||
|
i
|
||||||
|
"scan"
|
||||||
|
tcl-cmd-scan))))))))))))))))))))))))
|
||||||
81
lib/tcl/test.sh
Executable file
81
lib/tcl/test.sh
Executable file
@@ -0,0 +1,81 @@
|
|||||||
|
#!/usr/bin/env bash
|
||||||
|
# Tcl-on-SX test runner — epoch protocol to sx_server.exe
|
||||||
|
set -uo pipefail
|
||||||
|
cd "$(git rev-parse --show-toplevel)"
|
||||||
|
|
||||||
|
SX_SERVER="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}"
|
||||||
|
if [ ! -x "$SX_SERVER" ]; then
|
||||||
|
SX_SERVER="/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe"
|
||||||
|
fi
|
||||||
|
if [ ! -x "$SX_SERVER" ]; then echo "ERROR: sx_server.exe not found"; exit 1; fi
|
||||||
|
|
||||||
|
VERBOSE="${1:-}"
|
||||||
|
TMPFILE=$(mktemp)
|
||||||
|
HELPER=$(mktemp --suffix=.sx)
|
||||||
|
trap "rm -f $TMPFILE $HELPER" EXIT
|
||||||
|
|
||||||
|
# Helper file: run both test suites and format a parseable summary string
|
||||||
|
cat > "$HELPER" << 'HELPER_EOF'
|
||||||
|
(define __pr (tcl-run-parse-tests))
|
||||||
|
(define __er (tcl-run-eval-tests))
|
||||||
|
(define tcl-test-summary
|
||||||
|
(str "PARSE:" (get __pr "passed") ":" (get __pr "failed")
|
||||||
|
" EVAL:" (get __er "passed") ":" (get __er "failed")))
|
||||||
|
HELPER_EOF
|
||||||
|
|
||||||
|
cat > "$TMPFILE" << EPOCHS
|
||||||
|
(epoch 1)
|
||||||
|
(load "lib/tcl/tokenizer.sx")
|
||||||
|
(epoch 2)
|
||||||
|
(load "lib/tcl/parser.sx")
|
||||||
|
(epoch 3)
|
||||||
|
(load "lib/tcl/tests/parse.sx")
|
||||||
|
(epoch 4)
|
||||||
|
(load "lib/tcl/runtime.sx")
|
||||||
|
(epoch 5)
|
||||||
|
(load "lib/tcl/tests/eval.sx")
|
||||||
|
(epoch 6)
|
||||||
|
(load "$HELPER")
|
||||||
|
(epoch 7)
|
||||||
|
(eval "tcl-test-summary")
|
||||||
|
EPOCHS
|
||||||
|
|
||||||
|
OUTPUT=$(timeout 30 "$SX_SERVER" < "$TMPFILE" 2>&1)
|
||||||
|
[ "$VERBOSE" = "-v" ] && echo "$OUTPUT"
|
||||||
|
|
||||||
|
# Extract summary line from epoch 7 output
|
||||||
|
SUMMARY=$(echo "$OUTPUT" | grep -A1 "^(ok-len 7 " | tail -1 | tr -d '"')
|
||||||
|
|
||||||
|
if [ -z "$SUMMARY" ]; then
|
||||||
|
echo "ERROR: no summary from test run"
|
||||||
|
echo "$OUTPUT" | tail -20
|
||||||
|
exit 1
|
||||||
|
fi
|
||||||
|
|
||||||
|
# Parse PARSE:N:M EVAL:N:M
|
||||||
|
PARSE_PART=$(echo "$SUMMARY" | grep -o 'PARSE:[0-9]*:[0-9]*')
|
||||||
|
EVAL_PART=$(echo "$SUMMARY" | grep -o 'EVAL:[0-9]*:[0-9]*')
|
||||||
|
|
||||||
|
PARSE_PASSED=$(echo "$PARSE_PART" | cut -d: -f2)
|
||||||
|
PARSE_FAILED=$(echo "$PARSE_PART" | cut -d: -f3)
|
||||||
|
EVAL_PASSED=$(echo "$EVAL_PART" | cut -d: -f2)
|
||||||
|
EVAL_FAILED=$(echo "$EVAL_PART" | cut -d: -f3)
|
||||||
|
|
||||||
|
PARSE_PASSED=${PARSE_PASSED:-0}; PARSE_FAILED=${PARSE_FAILED:-1}
|
||||||
|
EVAL_PASSED=${EVAL_PASSED:-0}; EVAL_FAILED=${EVAL_FAILED:-1}
|
||||||
|
|
||||||
|
TOTAL_PASSED=$((PARSE_PASSED + EVAL_PASSED))
|
||||||
|
TOTAL_FAILED=$((PARSE_FAILED + EVAL_FAILED))
|
||||||
|
TOTAL=$((TOTAL_PASSED + TOTAL_FAILED))
|
||||||
|
|
||||||
|
if [ "$TOTAL_FAILED" = "0" ]; then
|
||||||
|
echo "ok $TOTAL_PASSED/$TOTAL tcl tests passed (parse: $PARSE_PASSED, eval: $EVAL_PASSED)"
|
||||||
|
exit 0
|
||||||
|
else
|
||||||
|
echo "FAIL $TOTAL_PASSED/$TOTAL passed, $TOTAL_FAILED failed (parse: $PARSE_PASSED/$((PARSE_PASSED+PARSE_FAILED)), eval: $EVAL_PASSED/$((EVAL_PASSED+EVAL_FAILED)))"
|
||||||
|
if [ -z "$VERBOSE" ]; then
|
||||||
|
echo "--- output ---"
|
||||||
|
echo "$OUTPUT" | tail -20
|
||||||
|
fi
|
||||||
|
exit 1
|
||||||
|
fi
|
||||||
194
lib/tcl/tests/eval.sx
Normal file
194
lib/tcl/tests/eval.sx
Normal file
@@ -0,0 +1,194 @@
|
|||||||
|
; Tcl-on-SX eval tests
|
||||||
|
(define tcl-eval-pass 0)
|
||||||
|
(define tcl-eval-fail 0)
|
||||||
|
(define tcl-eval-failures (list))
|
||||||
|
|
||||||
|
(define
|
||||||
|
tcl-eval-assert
|
||||||
|
(fn
|
||||||
|
(label expected actual)
|
||||||
|
(if
|
||||||
|
(equal? expected actual)
|
||||||
|
(set! tcl-eval-pass (+ tcl-eval-pass 1))
|
||||||
|
(begin
|
||||||
|
(set! tcl-eval-fail (+ tcl-eval-fail 1))
|
||||||
|
(append!
|
||||||
|
tcl-eval-failures
|
||||||
|
(str label ": expected=" (str expected) " got=" (str actual)))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
tcl-run-eval-tests
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(set! tcl-eval-pass 0)
|
||||||
|
(set! tcl-eval-fail 0)
|
||||||
|
(set! tcl-eval-failures (list))
|
||||||
|
(define interp (fn () (make-default-tcl-interp)))
|
||||||
|
(define run (fn (src) (tcl-eval-string (interp) src)))
|
||||||
|
(define
|
||||||
|
ok
|
||||||
|
(fn (label actual expected) (tcl-eval-assert label expected actual)))
|
||||||
|
(define
|
||||||
|
ok?
|
||||||
|
(fn (label condition) (tcl-eval-assert label true condition)))
|
||||||
|
(tcl-eval-assert "set-result" "hello" (get (run "set x hello") :result))
|
||||||
|
(tcl-eval-assert
|
||||||
|
"set-stored"
|
||||||
|
"hello"
|
||||||
|
(tcl-var-get (run "set x hello") "x"))
|
||||||
|
(tcl-eval-assert
|
||||||
|
"var-sub"
|
||||||
|
"hello"
|
||||||
|
(tcl-var-get (run "set x hello\nset y $x") "y"))
|
||||||
|
(tcl-eval-assert
|
||||||
|
"puts"
|
||||||
|
"world\n"
|
||||||
|
(get (run "set x world\nputs $x") :output))
|
||||||
|
(tcl-eval-assert
|
||||||
|
"puts-nonewline"
|
||||||
|
"hi"
|
||||||
|
(get (run "puts -nonewline hi") :output))
|
||||||
|
(tcl-eval-assert "incr" "6" (tcl-var-get (run "set x 5\nincr x") "x"))
|
||||||
|
(tcl-eval-assert
|
||||||
|
"incr-delta"
|
||||||
|
"8"
|
||||||
|
(tcl-var-get (run "set x 5\nincr x 3") "x"))
|
||||||
|
(tcl-eval-assert
|
||||||
|
"incr-neg"
|
||||||
|
"7"
|
||||||
|
(tcl-var-get (run "set x 10\nincr x -3") "x"))
|
||||||
|
(tcl-eval-assert
|
||||||
|
"append"
|
||||||
|
"foobar"
|
||||||
|
(tcl-var-get (run "set x foo\nappend x bar") "x"))
|
||||||
|
(tcl-eval-assert
|
||||||
|
"append-new"
|
||||||
|
"hello"
|
||||||
|
(tcl-var-get (run "append x hello") "x"))
|
||||||
|
(tcl-eval-assert
|
||||||
|
"cmdsub-result"
|
||||||
|
"6"
|
||||||
|
(get (run "set x 5\nset y [incr x]") :result))
|
||||||
|
(tcl-eval-assert
|
||||||
|
"cmdsub-y"
|
||||||
|
"6"
|
||||||
|
(tcl-var-get (run "set x 5\nset y [incr x]") "y"))
|
||||||
|
(tcl-eval-assert
|
||||||
|
"cmdsub-x"
|
||||||
|
"6"
|
||||||
|
(tcl-var-get (run "set x 5\nset y [incr x]") "x"))
|
||||||
|
(tcl-eval-assert
|
||||||
|
"multi-cmd"
|
||||||
|
"second"
|
||||||
|
(get (run "set x first\nset x second") :result))
|
||||||
|
(tcl-eval-assert "semi-x" "1" (tcl-var-get (run "set x 1; set y 2") "x"))
|
||||||
|
(tcl-eval-assert "semi-y" "2" (tcl-var-get (run "set x 1; set y 2") "y"))
|
||||||
|
(tcl-eval-assert
|
||||||
|
"braced-nosub"
|
||||||
|
"$x"
|
||||||
|
(tcl-var-get (run "set x 42\nset y {$x}") "y"))
|
||||||
|
(tcl-eval-assert
|
||||||
|
"concat-word"
|
||||||
|
"foobar"
|
||||||
|
(tcl-var-get (run "set x foo\nset y ${x}bar") "y"))
|
||||||
|
(tcl-eval-assert
|
||||||
|
"set-get"
|
||||||
|
"world"
|
||||||
|
(get (run "set x world\nset x") :result))
|
||||||
|
(tcl-eval-assert
|
||||||
|
"puts-channel"
|
||||||
|
"hello\n"
|
||||||
|
(get (run "puts stdout hello") :output))
|
||||||
|
(ok "if-true" (get (run "set x 0\nif {1} {set x 1}") :result) "1")
|
||||||
|
(ok "if-false" (get (run "set x 0\nif {0} {set x 1}") :result) "0")
|
||||||
|
(ok
|
||||||
|
"if-else-t"
|
||||||
|
(tcl-var-get (run "if {1} {set x yes} else {set x no}") "x")
|
||||||
|
"yes")
|
||||||
|
(ok
|
||||||
|
"if-else-f"
|
||||||
|
(tcl-var-get (run "if {0} {set x yes} else {set x no}") "x")
|
||||||
|
"no")
|
||||||
|
(ok
|
||||||
|
"if-cmp"
|
||||||
|
(tcl-var-get
|
||||||
|
(run "set x 5\nif {$x > 3} {set r big} else {set r small}")
|
||||||
|
"r")
|
||||||
|
"big")
|
||||||
|
(ok
|
||||||
|
"while"
|
||||||
|
(tcl-var-get
|
||||||
|
(run "set i 0\nset s 0\nwhile {$i < 5} {incr i\nincr s $i}")
|
||||||
|
"s")
|
||||||
|
"15")
|
||||||
|
(ok
|
||||||
|
"while-break"
|
||||||
|
(tcl-var-get
|
||||||
|
(run "set i 0\nwhile {1} {incr i\nif {$i == 3} {break}}")
|
||||||
|
"i")
|
||||||
|
"3")
|
||||||
|
(ok
|
||||||
|
"for"
|
||||||
|
(tcl-var-get
|
||||||
|
(run "set s 0\nfor {set i 1} {$i <= 5} {incr i} {incr s $i}")
|
||||||
|
"s")
|
||||||
|
"15")
|
||||||
|
(ok
|
||||||
|
"foreach"
|
||||||
|
(tcl-var-get (run "set s 0\nforeach x {1 2 3 4 5} {incr s $x}") "s")
|
||||||
|
"15")
|
||||||
|
(ok
|
||||||
|
"foreach-list"
|
||||||
|
(get (run "set acc \"\"\nforeach w {hello world} {append acc $w}") :result)
|
||||||
|
"helloworld")
|
||||||
|
(ok
|
||||||
|
"lappend"
|
||||||
|
(tcl-var-get (run "lappend lst a\nlappend lst b\nlappend lst c") "lst")
|
||||||
|
"a b c")
|
||||||
|
(ok?
|
||||||
|
"unset-gone"
|
||||||
|
(let
|
||||||
|
((i (run "set x 42\nunset x")))
|
||||||
|
(let
|
||||||
|
((frame (get i :frame)))
|
||||||
|
(nil? (get (get frame :locals) "x")))))
|
||||||
|
(ok "eval" (tcl-var-get (run "eval {set x hello}") "x") "hello")
|
||||||
|
(ok "expr-add" (get (run "expr {3 + 4}") :result) "7")
|
||||||
|
(ok "expr-cmp" (get (run "expr {5 > 3}") :result) "1")
|
||||||
|
(ok
|
||||||
|
"break-stops"
|
||||||
|
(tcl-var-get (run "set x 0\nwhile {1} {set x 1\nbreak\nset x 99}") "x")
|
||||||
|
"1")
|
||||||
|
(ok
|
||||||
|
"continue"
|
||||||
|
(tcl-var-get
|
||||||
|
(run
|
||||||
|
"set s 0\nfor {set i 1} {$i <= 5} {incr i} {if {$i == 3} {continue}\nincr s $i}")
|
||||||
|
"s")
|
||||||
|
"12")
|
||||||
|
(ok
|
||||||
|
"switch"
|
||||||
|
(tcl-var-get
|
||||||
|
(run "set x foo\nswitch $x {{foo} {set r yes} {bar} {set r no}}")
|
||||||
|
"r")
|
||||||
|
"yes")
|
||||||
|
(ok
|
||||||
|
"switch-default"
|
||||||
|
(tcl-var-get
|
||||||
|
(run "set x baz\nswitch $x {{foo} {set r yes} default {set r other}}")
|
||||||
|
"r")
|
||||||
|
"other")
|
||||||
|
(ok
|
||||||
|
"nested-if"
|
||||||
|
(tcl-var-get
|
||||||
|
(run
|
||||||
|
"set x 5\nif {$x > 10} {set r big} elseif {$x > 3} {set r mid} else {set r small}")
|
||||||
|
"r")
|
||||||
|
"mid")
|
||||||
|
(dict
|
||||||
|
"passed"
|
||||||
|
tcl-eval-pass
|
||||||
|
"failed"
|
||||||
|
tcl-eval-fail
|
||||||
|
"failures"
|
||||||
|
tcl-eval-failures)))
|
||||||
186
lib/tcl/tests/parse.sx
Normal file
186
lib/tcl/tests/parse.sx
Normal file
@@ -0,0 +1,186 @@
|
|||||||
|
(define tcl-parse-pass 0)
|
||||||
|
(define tcl-parse-fail 0)
|
||||||
|
(define tcl-parse-failures (list))
|
||||||
|
|
||||||
|
(define tcl-assert
|
||||||
|
(fn (label expected actual)
|
||||||
|
(if (= expected actual)
|
||||||
|
(set! tcl-parse-pass (+ tcl-parse-pass 1))
|
||||||
|
(begin
|
||||||
|
(set! tcl-parse-fail (+ tcl-parse-fail 1))
|
||||||
|
(append! tcl-parse-failures
|
||||||
|
(str label ": expected=" (str expected) " got=" (str actual)))))))
|
||||||
|
|
||||||
|
(define tcl-first-cmd
|
||||||
|
(fn (src) (nth (tcl-tokenize src) 0)))
|
||||||
|
|
||||||
|
(define tcl-cmd-words
|
||||||
|
(fn (src) (get (tcl-first-cmd src) :words)))
|
||||||
|
|
||||||
|
(define tcl-word
|
||||||
|
(fn (src wi) (nth (tcl-cmd-words src) wi)))
|
||||||
|
|
||||||
|
(define tcl-parts
|
||||||
|
(fn (src wi) (get (tcl-word src wi) :parts)))
|
||||||
|
|
||||||
|
(define tcl-part
|
||||||
|
(fn (src wi pi) (nth (tcl-parts src wi) pi)))
|
||||||
|
|
||||||
|
(define tcl-run-parse-tests
|
||||||
|
(fn ()
|
||||||
|
(set! tcl-parse-pass 0)
|
||||||
|
(set! tcl-parse-fail 0)
|
||||||
|
(set! tcl-parse-failures (list))
|
||||||
|
|
||||||
|
; empty / whitespace-only
|
||||||
|
(tcl-assert "empty" 0 (len (tcl-tokenize "")))
|
||||||
|
(tcl-assert "ws-only" 0 (len (tcl-tokenize " ")))
|
||||||
|
(tcl-assert "nl-only" 0 (len (tcl-tokenize "\n\n")))
|
||||||
|
|
||||||
|
; single command word count
|
||||||
|
(tcl-assert "1word" 1 (len (tcl-cmd-words "set")))
|
||||||
|
(tcl-assert "3words" 3 (len (tcl-cmd-words "set x 1")))
|
||||||
|
(tcl-assert "4words" 4 (len (tcl-cmd-words "set a b c")))
|
||||||
|
|
||||||
|
; word type — bare word is compound
|
||||||
|
(tcl-assert "bare-type" "compound" (get (tcl-word "set x 1" 0) :type))
|
||||||
|
(tcl-assert "bare-quoted" false (get (tcl-word "set x 1" 0) :quoted))
|
||||||
|
(tcl-assert "bare-part-type" "text" (get (tcl-part "set x 1" 0 0) :type))
|
||||||
|
(tcl-assert "bare-part-val" "set" (get (tcl-part "set x 1" 0 0) :value))
|
||||||
|
(tcl-assert "bare-part2-val" "x" (get (tcl-part "set x 1" 1 0) :value))
|
||||||
|
(tcl-assert "bare-part3-val" "1" (get (tcl-part "set x 1" 2 0) :value))
|
||||||
|
|
||||||
|
; multiple commands
|
||||||
|
(tcl-assert "semi-sep" 2 (len (tcl-tokenize "set x 1; set y 2")))
|
||||||
|
(tcl-assert "nl-sep" 2 (len (tcl-tokenize "set x 1\nset y 2")))
|
||||||
|
(tcl-assert "multi-nl" 3 (len (tcl-tokenize "a\nb\nc")))
|
||||||
|
|
||||||
|
; comments
|
||||||
|
(tcl-assert "comment-only" 0 (len (tcl-tokenize "# comment")))
|
||||||
|
(tcl-assert "comment-nl" 0 (len (tcl-tokenize "# comment\n")))
|
||||||
|
(tcl-assert "comment-then-cmd" 1 (len (tcl-tokenize "# comment\nset x 1")))
|
||||||
|
(tcl-assert "semi-then-comment" 1 (len (tcl-tokenize "set x 1; # comment")))
|
||||||
|
|
||||||
|
; brace-quoted words
|
||||||
|
(tcl-assert "brace-type" "braced" (get (tcl-word "{hello}" 0) :type))
|
||||||
|
(tcl-assert "brace-value" "hello" (get (tcl-word "{hello}" 0) :value))
|
||||||
|
(tcl-assert "brace-spaces" "hello world" (get (tcl-word "{hello world}" 0) :value))
|
||||||
|
(tcl-assert "brace-nested" "a {b} c" (get (tcl-word "{a {b} c}" 0) :value))
|
||||||
|
(tcl-assert "brace-no-var-sub" "hello $x" (get (tcl-word "{hello $x}" 0) :value))
|
||||||
|
(tcl-assert "brace-no-cmd-sub" "[expr 1]" (get (tcl-word "{[expr 1]}" 0) :value))
|
||||||
|
|
||||||
|
; double-quoted words
|
||||||
|
(tcl-assert "dq-type" "compound" (get (tcl-word "\"hello\"" 0) :type))
|
||||||
|
(tcl-assert "dq-quoted" true (get (tcl-word "\"hello\"" 0) :quoted))
|
||||||
|
(tcl-assert "dq-literal" "hello" (get (tcl-part "\"hello\"" 0 0) :value))
|
||||||
|
|
||||||
|
; variable substitution in bare word
|
||||||
|
(tcl-assert "var-type" "var" (get (tcl-part "$x" 0 0) :type))
|
||||||
|
(tcl-assert "var-name" "x" (get (tcl-part "$x" 0 0) :name))
|
||||||
|
(tcl-assert "var-long" "long_name" (get (tcl-part "$long_name" 0 0) :name))
|
||||||
|
|
||||||
|
; ${name} form
|
||||||
|
(tcl-assert "var-brace-type" "var" (get (tcl-part "${x}" 0 0) :type))
|
||||||
|
(tcl-assert "var-brace-name" "x" (get (tcl-part "${x}" 0 0) :name))
|
||||||
|
|
||||||
|
; array variable substitution
|
||||||
|
(tcl-assert "arr-type" "var-arr" (get (tcl-part "$arr(key)" 0 0) :type))
|
||||||
|
(tcl-assert "arr-name" "arr" (get (tcl-part "$arr(key)" 0 0) :name))
|
||||||
|
(tcl-assert "arr-key-len" 1 (len (get (tcl-part "$arr(key)" 0 0) :key)))
|
||||||
|
(tcl-assert "arr-key-text" "key"
|
||||||
|
(get (nth (get (tcl-part "$arr(key)" 0 0) :key) 0) :value))
|
||||||
|
|
||||||
|
; command substitution
|
||||||
|
(tcl-assert "cmd-type" "cmd" (get (tcl-part "[expr 1+1]" 0 0) :type))
|
||||||
|
(tcl-assert "cmd-src" "expr 1+1" (get (tcl-part "[expr 1+1]" 0 0) :src))
|
||||||
|
|
||||||
|
; nested command substitution
|
||||||
|
(tcl-assert "cmd-nested-src" "expr [string length x]"
|
||||||
|
(get (tcl-part "[expr [string length x]]" 0 0) :src))
|
||||||
|
|
||||||
|
; backslash substitution in double-quoted word
|
||||||
|
(let ((ps (tcl-parts "\"a\\nb\"" 0)))
|
||||||
|
(begin
|
||||||
|
(tcl-assert "bs-n-part0" "a" (get (nth ps 0) :value))
|
||||||
|
(tcl-assert "bs-n-part1" "\n" (get (nth ps 1) :value))
|
||||||
|
(tcl-assert "bs-n-part2" "b" (get (nth ps 2) :value))))
|
||||||
|
|
||||||
|
(let ((ps (tcl-parts "\"a\\tb\"" 0)))
|
||||||
|
(tcl-assert "bs-t-part1" "\t" (get (nth ps 1) :value)))
|
||||||
|
|
||||||
|
(let ((ps (tcl-parts "\"a\\\\b\"" 0)))
|
||||||
|
(tcl-assert "bs-bs-part1" "\\" (get (nth ps 1) :value)))
|
||||||
|
|
||||||
|
; mixed word: text + var + text in double-quoted
|
||||||
|
(let ((ps (tcl-parts "\"hello $name!\"" 0)))
|
||||||
|
(begin
|
||||||
|
(tcl-assert "mixed-text0" "hello " (get (nth ps 0) :value))
|
||||||
|
(tcl-assert "mixed-var1-type" "var" (get (nth ps 1) :type))
|
||||||
|
(tcl-assert "mixed-var1-name" "name" (get (nth ps 1) :name))
|
||||||
|
(tcl-assert "mixed-text2" "!" (get (nth ps 2) :value))))
|
||||||
|
|
||||||
|
; {*} expansion
|
||||||
|
(tcl-assert "expand-type" "expand" (get (tcl-word "{*}$list" 0) :type))
|
||||||
|
|
||||||
|
; line continuation between words
|
||||||
|
(tcl-assert "cont-words" 3 (len (tcl-cmd-words "set x \\\n 1")))
|
||||||
|
|
||||||
|
; continuation — third command word is correct
|
||||||
|
(tcl-assert "cont-word2-val" "1"
|
||||||
|
(get (tcl-part "set x \\\n 1" 2 0) :value))
|
||||||
|
|
||||||
|
|
||||||
|
; --- parser helpers ---
|
||||||
|
; tcl-parse is an alias for tcl-tokenize
|
||||||
|
(tcl-assert "parse-cmd-count" 1 (len (tcl-parse "set x 1")))
|
||||||
|
(tcl-assert "parse-2cmds" 2 (len (tcl-parse "set x 1; set y 2")))
|
||||||
|
|
||||||
|
; tcl-cmd-len
|
||||||
|
(tcl-assert "cmd-len-3" 3 (tcl-cmd-len (nth (tcl-parse "set x 1") 0)))
|
||||||
|
(tcl-assert "cmd-len-1" 1 (tcl-cmd-len (nth (tcl-parse "puts") 0)))
|
||||||
|
|
||||||
|
; tcl-word-simple? on braced word
|
||||||
|
(tcl-assert "simple-braced" true
|
||||||
|
(tcl-word-simple? (nth (get (nth (tcl-parse "{hello}") 0) :words) 0)))
|
||||||
|
|
||||||
|
; tcl-word-simple? on bare word with no subs
|
||||||
|
(tcl-assert "simple-bare" true
|
||||||
|
(tcl-word-simple? (nth (get (nth (tcl-parse "hello") 0) :words) 0)))
|
||||||
|
|
||||||
|
; tcl-word-simple? on word containing a var sub — false
|
||||||
|
(tcl-assert "simple-var-false" false
|
||||||
|
(tcl-word-simple? (nth (get (nth (tcl-parse "$x") 0) :words) 0)))
|
||||||
|
|
||||||
|
; tcl-word-simple? on word containing a cmd sub — false
|
||||||
|
(tcl-assert "simple-cmd-false" false
|
||||||
|
(tcl-word-simple? (nth (get (nth (tcl-parse "[expr 1]") 0) :words) 0)))
|
||||||
|
|
||||||
|
; tcl-word-literal on braced word
|
||||||
|
(tcl-assert "lit-braced" "hello world"
|
||||||
|
(tcl-word-literal (nth (get (nth (tcl-parse "{hello world}") 0) :words) 0)))
|
||||||
|
|
||||||
|
; tcl-word-literal on bare word
|
||||||
|
(tcl-assert "lit-bare" "hello"
|
||||||
|
(tcl-word-literal (nth (get (nth (tcl-parse "hello") 0) :words) 0)))
|
||||||
|
|
||||||
|
; tcl-word-literal on word with var sub returns nil
|
||||||
|
(tcl-assert "lit-var-nil" nil
|
||||||
|
(tcl-word-literal (nth (get (nth (tcl-parse "$x") 0) :words) 0)))
|
||||||
|
|
||||||
|
; tcl-nth-literal
|
||||||
|
(tcl-assert "nth-lit-0" "set"
|
||||||
|
(tcl-nth-literal (nth (tcl-parse "set x 1") 0) 0))
|
||||||
|
(tcl-assert "nth-lit-1" "x"
|
||||||
|
(tcl-nth-literal (nth (tcl-parse "set x 1") 0) 1))
|
||||||
|
(tcl-assert "nth-lit-2" "1"
|
||||||
|
(tcl-nth-literal (nth (tcl-parse "set x 1") 0) 2))
|
||||||
|
|
||||||
|
; tcl-nth-literal returns nil when word has subs
|
||||||
|
(tcl-assert "nth-lit-nil" nil
|
||||||
|
(tcl-nth-literal (nth (tcl-parse "set x $y") 0) 2))
|
||||||
|
|
||||||
|
|
||||||
|
(dict
|
||||||
|
"passed" tcl-parse-pass
|
||||||
|
"failed" tcl-parse-fail
|
||||||
|
"failures" tcl-parse-failures)))
|
||||||
308
lib/tcl/tokenizer.sx
Normal file
308
lib/tcl/tokenizer.sx
Normal file
@@ -0,0 +1,308 @@
|
|||||||
|
(define tcl-ws? (fn (c) (or (= c " ") (= c "\t") (= c "\r"))))
|
||||||
|
|
||||||
|
(define tcl-alpha?
|
||||||
|
(fn (c)
|
||||||
|
(and
|
||||||
|
(not (= c nil))
|
||||||
|
(or (and (>= c "a") (<= c "z")) (and (>= c "A") (<= c "Z"))))))
|
||||||
|
|
||||||
|
(define tcl-digit?
|
||||||
|
(fn (c) (and (not (= c nil)) (>= c "0") (<= c "9"))))
|
||||||
|
|
||||||
|
(define tcl-ident-start?
|
||||||
|
(fn (c) (or (tcl-alpha? c) (= c "_"))))
|
||||||
|
|
||||||
|
(define tcl-ident-char?
|
||||||
|
(fn (c) (or (tcl-ident-start? c) (tcl-digit? c))))
|
||||||
|
|
||||||
|
(define tcl-tokenize
|
||||||
|
(fn (src)
|
||||||
|
(let ((pos 0) (src-len (len src)) (commands (list)))
|
||||||
|
|
||||||
|
(define char-at
|
||||||
|
(fn (off)
|
||||||
|
(if (< (+ pos off) src-len) (nth src (+ pos off)) nil)))
|
||||||
|
|
||||||
|
(define cur (fn () (char-at 0)))
|
||||||
|
|
||||||
|
(define advance! (fn (n) (set! pos (+ pos n))))
|
||||||
|
|
||||||
|
(define skip-ws!
|
||||||
|
(fn ()
|
||||||
|
(when (tcl-ws? (cur))
|
||||||
|
(begin (advance! 1) (skip-ws!)))))
|
||||||
|
|
||||||
|
(define skip-to-eol!
|
||||||
|
(fn ()
|
||||||
|
(when (and (< pos src-len) (not (= (cur) "\n")))
|
||||||
|
(begin (advance! 1) (skip-to-eol!)))))
|
||||||
|
|
||||||
|
(define skip-brace-content!
|
||||||
|
(fn (d)
|
||||||
|
(when (and (< pos src-len) (> d 0))
|
||||||
|
(cond
|
||||||
|
((= (cur) "{") (begin (advance! 1) (skip-brace-content! (+ d 1))))
|
||||||
|
((= (cur) "}") (begin (advance! 1) (skip-brace-content! (- d 1))))
|
||||||
|
(else (begin (advance! 1) (skip-brace-content! d)))))))
|
||||||
|
|
||||||
|
(define skip-dquote-content!
|
||||||
|
(fn ()
|
||||||
|
(when (and (< pos src-len) (not (= (cur) "\"")))
|
||||||
|
(begin
|
||||||
|
(when (= (cur) "\\") (advance! 1))
|
||||||
|
(when (< pos src-len) (advance! 1))
|
||||||
|
(skip-dquote-content!)))))
|
||||||
|
|
||||||
|
(define parse-bs
|
||||||
|
(fn ()
|
||||||
|
(advance! 1)
|
||||||
|
(let ((c (cur)))
|
||||||
|
(cond
|
||||||
|
((= c nil) "\\")
|
||||||
|
((= c "n") (begin (advance! 1) "\n"))
|
||||||
|
((= c "t") (begin (advance! 1) "\t"))
|
||||||
|
((= c "r") (begin (advance! 1) "\r"))
|
||||||
|
((= c "\\") (begin (advance! 1) "\\"))
|
||||||
|
((= c "[") (begin (advance! 1) "["))
|
||||||
|
((= c "]") (begin (advance! 1) "]"))
|
||||||
|
((= c "{") (begin (advance! 1) "{"))
|
||||||
|
((= c "}") (begin (advance! 1) "}"))
|
||||||
|
((= c "$") (begin (advance! 1) "$"))
|
||||||
|
((= c ";") (begin (advance! 1) ";"))
|
||||||
|
((= c "\"") (begin (advance! 1) "\""))
|
||||||
|
((= c "'") (begin (advance! 1) "'"))
|
||||||
|
((= c " ") (begin (advance! 1) " "))
|
||||||
|
((= c "\n")
|
||||||
|
(begin
|
||||||
|
(advance! 1)
|
||||||
|
(skip-ws!)
|
||||||
|
" "))
|
||||||
|
(else (begin (advance! 1) (str "\\" c)))))))
|
||||||
|
|
||||||
|
(define parse-cmd-sub
|
||||||
|
(fn ()
|
||||||
|
(advance! 1)
|
||||||
|
(let ((start pos) (depth 1))
|
||||||
|
(define scan!
|
||||||
|
(fn ()
|
||||||
|
(when (and (< pos src-len) (> depth 0))
|
||||||
|
(cond
|
||||||
|
((= (cur) "[")
|
||||||
|
(begin (set! depth (+ depth 1)) (advance! 1) (scan!)))
|
||||||
|
((= (cur) "]")
|
||||||
|
(begin
|
||||||
|
(set! depth (- depth 1))
|
||||||
|
(when (> depth 0) (advance! 1))
|
||||||
|
(scan!)))
|
||||||
|
((= (cur) "{")
|
||||||
|
(begin (advance! 1) (skip-brace-content! 1) (scan!)))
|
||||||
|
((= (cur) "\"")
|
||||||
|
(begin
|
||||||
|
(advance! 1)
|
||||||
|
(skip-dquote-content!)
|
||||||
|
(when (= (cur) "\"") (advance! 1))
|
||||||
|
(scan!)))
|
||||||
|
((= (cur) "\\")
|
||||||
|
(begin (advance! 1) (when (< pos src-len) (advance! 1)) (scan!)))
|
||||||
|
(else (begin (advance! 1) (scan!)))))))
|
||||||
|
(scan!)
|
||||||
|
(let ((src-text (slice src start pos)))
|
||||||
|
(begin
|
||||||
|
(when (= (cur) "]") (advance! 1))
|
||||||
|
{:type "cmd" :src src-text})))))
|
||||||
|
|
||||||
|
(define scan-name!
|
||||||
|
(fn ()
|
||||||
|
(when (and (< pos src-len) (not (= (cur) "}")))
|
||||||
|
(begin (advance! 1) (scan-name!)))))
|
||||||
|
|
||||||
|
(define scan-ns-name!
|
||||||
|
(fn ()
|
||||||
|
(cond
|
||||||
|
((tcl-ident-char? (cur))
|
||||||
|
(begin (advance! 1) (scan-ns-name!)))
|
||||||
|
((and (= (cur) ":") (= (char-at 1) ":"))
|
||||||
|
(begin (advance! 2) (scan-ns-name!)))
|
||||||
|
(else nil))))
|
||||||
|
|
||||||
|
(define scan-klit!
|
||||||
|
(fn ()
|
||||||
|
(when (and (< pos src-len)
|
||||||
|
(not (= (cur) ")"))
|
||||||
|
(not (= (cur) "$"))
|
||||||
|
(not (= (cur) "["))
|
||||||
|
(not (= (cur) "\\")))
|
||||||
|
(begin (advance! 1) (scan-klit!)))))
|
||||||
|
|
||||||
|
(define scan-key!
|
||||||
|
(fn (kp)
|
||||||
|
(when (and (< pos src-len) (not (= (cur) ")")))
|
||||||
|
(cond
|
||||||
|
((= (cur) "$")
|
||||||
|
(begin (append! kp (parse-var-sub)) (scan-key! kp)))
|
||||||
|
((= (cur) "[")
|
||||||
|
(begin (append! kp (parse-cmd-sub)) (scan-key! kp)))
|
||||||
|
((= (cur) "\\")
|
||||||
|
(begin
|
||||||
|
(append! kp {:type "text" :value (parse-bs)})
|
||||||
|
(scan-key! kp)))
|
||||||
|
(else
|
||||||
|
(let ((kstart pos))
|
||||||
|
(begin
|
||||||
|
(scan-klit!)
|
||||||
|
(append! kp {:type "text" :value (slice src kstart pos)})
|
||||||
|
(scan-key! kp))))))))
|
||||||
|
|
||||||
|
(define parse-var-sub
|
||||||
|
(fn ()
|
||||||
|
(advance! 1)
|
||||||
|
(cond
|
||||||
|
((= (cur) "{")
|
||||||
|
(begin
|
||||||
|
(advance! 1)
|
||||||
|
(let ((start pos))
|
||||||
|
(begin
|
||||||
|
(scan-name!)
|
||||||
|
(let ((name (slice src start pos)))
|
||||||
|
(begin
|
||||||
|
(when (= (cur) "}") (advance! 1))
|
||||||
|
{:type "var" :name name}))))))
|
||||||
|
((tcl-ident-start? (cur))
|
||||||
|
(let ((start pos))
|
||||||
|
(begin
|
||||||
|
(scan-ns-name!)
|
||||||
|
(let ((name (slice src start pos)))
|
||||||
|
(if (= (cur) "(")
|
||||||
|
(begin
|
||||||
|
(advance! 1)
|
||||||
|
(let ((key-parts (list)))
|
||||||
|
(begin
|
||||||
|
(scan-key! key-parts)
|
||||||
|
(when (= (cur) ")") (advance! 1))
|
||||||
|
{:type "var-arr" :name name :key key-parts})))
|
||||||
|
{:type "var" :name name})))))
|
||||||
|
(else {:type "text" :value "$"}))))
|
||||||
|
|
||||||
|
(define scan-lit!
|
||||||
|
(fn (stop?)
|
||||||
|
(when (and (< pos src-len)
|
||||||
|
(not (stop? (cur)))
|
||||||
|
(not (= (cur) "$"))
|
||||||
|
(not (= (cur) "["))
|
||||||
|
(not (= (cur) "\\")))
|
||||||
|
(begin (advance! 1) (scan-lit! stop?)))))
|
||||||
|
|
||||||
|
(define parse-word-parts!
|
||||||
|
(fn (parts stop?)
|
||||||
|
(when (and (< pos src-len) (not (stop? (cur))))
|
||||||
|
(cond
|
||||||
|
((= (cur) "$")
|
||||||
|
(begin (append! parts (parse-var-sub)) (parse-word-parts! parts stop?)))
|
||||||
|
((= (cur) "[")
|
||||||
|
(begin (append! parts (parse-cmd-sub)) (parse-word-parts! parts stop?)))
|
||||||
|
((= (cur) "\\")
|
||||||
|
(begin
|
||||||
|
(append! parts {:type "text" :value (parse-bs)})
|
||||||
|
(parse-word-parts! parts stop?)))
|
||||||
|
(else
|
||||||
|
(let ((start pos))
|
||||||
|
(begin
|
||||||
|
(scan-lit! stop?)
|
||||||
|
(when (> pos start)
|
||||||
|
(append! parts {:type "text" :value (slice src start pos)}))
|
||||||
|
(parse-word-parts! parts stop?))))))))
|
||||||
|
|
||||||
|
(define parse-brace-word
|
||||||
|
(fn ()
|
||||||
|
(advance! 1)
|
||||||
|
(let ((depth 1) (start pos))
|
||||||
|
(define scan!
|
||||||
|
(fn ()
|
||||||
|
(when (and (< pos src-len) (> depth 0))
|
||||||
|
(cond
|
||||||
|
((= (cur) "{")
|
||||||
|
(begin (set! depth (+ depth 1)) (advance! 1) (scan!)))
|
||||||
|
((= (cur) "}")
|
||||||
|
(begin (set! depth (- depth 1)) (when (> depth 0) (advance! 1)) (scan!)))
|
||||||
|
(else (begin (advance! 1) (scan!)))))))
|
||||||
|
(scan!)
|
||||||
|
(let ((value (slice src start pos)))
|
||||||
|
(begin
|
||||||
|
(when (= (cur) "}") (advance! 1))
|
||||||
|
{:type "braced" :value value})))))
|
||||||
|
|
||||||
|
(define parse-dquote-word
|
||||||
|
(fn ()
|
||||||
|
(advance! 1)
|
||||||
|
(let ((parts (list)))
|
||||||
|
(begin
|
||||||
|
(parse-word-parts! parts (fn (c) (or (= c "\"") (= c nil))))
|
||||||
|
(when (= (cur) "\"") (advance! 1))
|
||||||
|
{:type "compound" :parts parts :quoted true}))))
|
||||||
|
|
||||||
|
(define parse-bare-word
|
||||||
|
(fn ()
|
||||||
|
(let ((parts (list)))
|
||||||
|
(begin
|
||||||
|
(parse-word-parts!
|
||||||
|
parts
|
||||||
|
(fn (c) (or (tcl-ws? c) (= c "\n") (= c ";") (= c nil))))
|
||||||
|
{:type "compound" :parts parts :quoted false}))))
|
||||||
|
|
||||||
|
(define parse-word-no-expand
|
||||||
|
(fn ()
|
||||||
|
(cond
|
||||||
|
((= (cur) "{") (parse-brace-word))
|
||||||
|
((= (cur) "\"") (parse-dquote-word))
|
||||||
|
(else (parse-bare-word)))))
|
||||||
|
|
||||||
|
(define parse-word
|
||||||
|
(fn ()
|
||||||
|
(cond
|
||||||
|
((and (= (cur) "{") (= (char-at 1) "*") (= (char-at 2) "}"))
|
||||||
|
(begin
|
||||||
|
(advance! 3)
|
||||||
|
{:type "expand" :word (parse-word-no-expand)}))
|
||||||
|
((= (cur) "{") (parse-brace-word))
|
||||||
|
((= (cur) "\"") (parse-dquote-word))
|
||||||
|
(else (parse-bare-word)))))
|
||||||
|
|
||||||
|
(define parse-words!
|
||||||
|
(fn (words)
|
||||||
|
(skip-ws!)
|
||||||
|
(cond
|
||||||
|
((or (= (cur) nil) (= (cur) "\n") (= (cur) ";")) nil)
|
||||||
|
((and (= (cur) "\\") (= (char-at 1) "\n"))
|
||||||
|
(begin (advance! 2) (skip-ws!) (parse-words! words)))
|
||||||
|
(else
|
||||||
|
(begin
|
||||||
|
(append! words (parse-word))
|
||||||
|
(parse-words! words))))))
|
||||||
|
|
||||||
|
(define skip-seps!
|
||||||
|
(fn ()
|
||||||
|
(when (< pos src-len)
|
||||||
|
(cond
|
||||||
|
((or (tcl-ws? (cur)) (= (cur) "\n") (= (cur) ";"))
|
||||||
|
(begin (advance! 1) (skip-seps!)))
|
||||||
|
((and (= (cur) "\\") (= (char-at 1) "\n"))
|
||||||
|
(begin (advance! 2) (skip-seps!)))
|
||||||
|
(else nil)))))
|
||||||
|
|
||||||
|
(define parse-all!
|
||||||
|
(fn ()
|
||||||
|
(skip-seps!)
|
||||||
|
(when (< pos src-len)
|
||||||
|
(cond
|
||||||
|
((= (cur) "#")
|
||||||
|
(begin (skip-to-eol!) (parse-all!)))
|
||||||
|
(else
|
||||||
|
(let ((words (list)))
|
||||||
|
(begin
|
||||||
|
(parse-words! words)
|
||||||
|
(when (> (len words) 0)
|
||||||
|
(append! commands {:type "command" :words words}))
|
||||||
|
(parse-all!))))))))
|
||||||
|
|
||||||
|
(parse-all!)
|
||||||
|
commands)))
|
||||||
@@ -50,20 +50,20 @@ Core mapping:
|
|||||||
## Roadmap
|
## Roadmap
|
||||||
|
|
||||||
### Phase 1 — reader + parser
|
### 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 `#| … |#`
|
- [ ] 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
|
- [ ] 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
|
- [ ] 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`
|
- [ ] Unit tests in `lib/common-lisp/tests/read.sx`
|
||||||
|
|
||||||
### Phase 2 — sequential eval + special forms
|
### 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
|
- [ ] `block` + `return-from` via captured continuation
|
||||||
- [ ] `tagbody` + `go` via per-tag continuations
|
- [ ] `tagbody` + `go` via per-tag continuations
|
||||||
- [ ] `unwind-protect` cleanup frame
|
- [ ] `unwind-protect` cleanup frame
|
||||||
- [ ] `multiple-value-bind`, `multiple-value-call`, `multiple-value-prog1`, `values`, `nth-value`
|
- [ ] `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
|
- [ ] 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)
|
### 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`
|
- [ ] `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._
|
_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.
|
- _(none yet)_
|
||||||
- 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.
|
|
||||||
|
|
||||||
## Blockers
|
## Blockers
|
||||||
|
|
||||||
|
|||||||
@@ -50,7 +50,7 @@ Core mapping:
|
|||||||
## Roadmap
|
## Roadmap
|
||||||
|
|
||||||
### Phase 1 — tokenizer + parser (the Dodekalogue)
|
### Phase 1 — tokenizer + parser (the Dodekalogue)
|
||||||
- [ ] Tokenizer applying the 12 rules:
|
- [x] Tokenizer applying the 12 rules:
|
||||||
1. Commands separated by `;` or newlines
|
1. Commands separated by `;` or newlines
|
||||||
2. Words separated by whitespace within a command
|
2. Words separated by whitespace within a command
|
||||||
3. Double-quoted words: `\` escapes + `[…]` + `${…}` + `$var` substitution
|
3. Double-quoted words: `\` escapes + `[…]` + `${…}` + `$var` substitution
|
||||||
@@ -63,12 +63,12 @@ Core mapping:
|
|||||||
10. Order of substitution is left-to-right, single-pass
|
10. Order of substitution is left-to-right, single-pass
|
||||||
11. Substitutions don't recurse — substituted text is not re-parsed
|
11. Substitutions don't recurse — substituted text is not re-parsed
|
||||||
12. The result of any substitution is the value, not a new script
|
12. The result of any substitution is the value, not a new script
|
||||||
- [ ] Parser: script = list of commands; command = list of words; word = literal string + list of substitutions
|
- [x] Parser: script = list of commands; command = list of words; word = literal string + list of substitutions
|
||||||
- [ ] Unit tests in `lib/tcl/tests/parse.sx`
|
- [x] Unit tests in `lib/tcl/tests/parse.sx`
|
||||||
|
|
||||||
### Phase 2 — sequential eval + core commands
|
### Phase 2 — sequential eval + core commands
|
||||||
- [ ] `tcl-eval-script`: walk command list, dispatch each first-word into command table
|
- [x] `tcl-eval-script`: walk command list, dispatch each first-word into command table
|
||||||
- [ ] Core commands: `set`, `unset`, `incr`, `append`, `lappend`, `puts`, `gets`, `expr`, `if`, `while`, `for`, `foreach`, `switch`, `break`, `continue`, `return`, `error`, `eval`, `subst`, `format`, `scan`
|
- [x] Core commands: `set`, `unset`, `incr`, `append`, `lappend`, `puts`, `gets`, `expr`, `if`, `while`, `for`, `foreach`, `switch`, `break`, `continue`, `return`, `error`, `eval`, `subst`, `format`, `scan`
|
||||||
- [ ] `expr` is its own mini-language — operator precedence, function calls (`sin`, `sqrt`, `pow`, `abs`, `int`, `double`), variable substitution, command substitution
|
- [ ] `expr` is its own mini-language — operator precedence, function calls (`sin`, `sqrt`, `pow`, `abs`, `int`, `double`), variable substitution, command substitution
|
||||||
- [ ] String commands: `string length`, `string index`, `string range`, `string compare`, `string match`, `string toupper`, `string tolower`, `string trim`, `string map`, `string repeat`, `string first`, `string last`, `string is`, `string cat`
|
- [ ] String commands: `string length`, `string index`, `string range`, `string compare`, `string match`, `string toupper`, `string tolower`, `string trim`, `string map`, `string repeat`, `string first`, `string last`, `string is`, `string cat`
|
||||||
- [ ] List commands: `list`, `lindex`, `lrange`, `llength`, `lreverse`, `lsearch`, `lsort`, `lsort -integer/-real/-dictionary`, `lreplace`, `linsert`, `concat`, `split`, `join`
|
- [ ] List commands: `list`, `lindex`, `lrange`, `llength`, `lreverse`, `lsearch`, `lsort`, `lsort -integer/-real/-dictionary`, `lreplace`, `linsert`, `concat`, `split`, `join`
|
||||||
@@ -120,7 +120,10 @@ Core mapping:
|
|||||||
|
|
||||||
_Newest first._
|
_Newest first._
|
||||||
|
|
||||||
- _(none yet)_
|
- 2026-04-26: Phase 2 core commands — if/while/for/foreach/switch/break/continue/return/error/unset/lappend/eval/expr + :code control flow, 107 tests green (67 parse + 40 eval)
|
||||||
|
- 2026-04-26: Phase 2 eval engine — `lib/tcl/runtime.sx`, tcl-eval-script + set/puts/incr/append, 87 tests green (67 parse + 20 eval)
|
||||||
|
- 2026-04-25: Phase 1 parser — `lib/tcl/parser.sx`, word-simple?/word-literal helpers, 67 tests green, commit 6ee05259
|
||||||
|
- 2026-04-25: Phase 1 tokenizer (Dodekalogue) — `lib/tcl/tokenizer.sx`, 52 tests green, commit 666e29d5
|
||||||
|
|
||||||
## Blockers
|
## Blockers
|
||||||
|
|
||||||
|
|||||||
Reference in New Issue
Block a user