diff --git a/lib/guest/reflective/quoting.sx b/lib/guest/reflective/quoting.sx new file mode 100644 index 00000000..c6c7ad35 --- /dev/null +++ b/lib/guest/reflective/quoting.sx @@ -0,0 +1,77 @@ +;; lib/guest/reflective/quoting.sx — quasiquote walker. +;; +;; Extracted from Kernel's `knl-quasi-walk` and Scheme's `scm-quasi-walk`, +;; which differ only in: +;; - the unquote keyword name (Kernel: "$unquote" / "$unquote-splicing"; +;; Scheme: "unquote" / "unquote-splicing") +;; - the host evaluator function (`kernel-eval` vs `scheme-eval`) +;; +;; Algorithm is identical. Adapter cfg parameterises the two +;; language-specific knobs. +;; +;; Adapter cfg keys +;; ---------------- +;; :unquote-name — string, name of the unquote keyword +;; :unquote-splicing-name — string, name of the splice keyword +;; :eval — fn (form env) → value +;; +;; Public API +;; (refl-quasi-walk-with CFG FORM ENV) +;; Top-level walker. Returns FORM with unquotes evaluated in ENV. +;; +;; (refl-quasi-walk-list-with CFG FORMS ENV) +;; Walks a list of forms, splicing unquote-splicing results inline. +;; +;; (refl-quasi-list-concat XS YS) +;; Pure-SX list append (no host append/append! needed). + +(define + refl-quasi-list-concat + (fn + (xs ys) + (cond + ((or (nil? xs) (= (length xs) 0)) ys) + (:else (cons (first xs) (refl-quasi-list-concat (rest xs) ys)))))) + +(define + refl-quasi-walk-with + (fn + (cfg form env) + (cond + ((not (list? form)) form) + ((= (length form) 0) form) + ((and (string? (first form)) (= (first form) (get cfg :unquote-name))) + (cond + ((not (= (length form) 2)) + (error + (str (get cfg :unquote-name) ": expects exactly 1 argument"))) + (:else ((get cfg :eval) (nth form 1) env)))) + (:else (refl-quasi-walk-list-with cfg form env))))) + +(define + refl-quasi-walk-list-with + (fn + (cfg forms env) + (cond + ((or (nil? forms) (= (length forms) 0)) (list)) + (:else + (let + ((head (first forms))) + (cond + ((and (list? head) (= (length head) 2) (string? (first head)) (= (first head) (get cfg :unquote-splicing-name))) + (let + ((spliced ((get cfg :eval) (nth head 1) env))) + (cond + ((not (list? spliced)) + (error + (str + (get cfg :unquote-splicing-name) + ": value must be a list"))) + (:else + (refl-quasi-list-concat + spliced + (refl-quasi-walk-list-with cfg (rest forms) env)))))) + (:else + (cons + (refl-quasi-walk-with cfg head env) + (refl-quasi-walk-list-with cfg (rest forms) env))))))))) diff --git a/lib/kernel/runtime.sx b/lib/kernel/runtime.sx index 77bff089..b8d48998 100644 --- a/lib/kernel/runtime.sx +++ b/lib/kernel/runtime.sx @@ -194,48 +194,18 @@ ((not (= (length args) 1)) (error "$quote: expects 1 argument")) (:else (first args)))))) -;; Quasiquote: walks the template, evaluating `$unquote` forms in the -;; dynamic env and splicing `$unquote-splicing` list results. +;; Kernel-side adapter for lib/guest/reflective/quoting.sx. +;; Kernel uses $unquote / $unquote-splicing (dollar-prefixed) and the +;; host-level kernel-eval as the evaluator. The walker algorithm +;; itself is shared with Scheme via the kit. +(define knl-quasi-cfg + {:unquote-name "$unquote" + :unquote-splicing-name "$unquote-splicing" + :eval (fn (form env) (kernel-eval form env))}) + (define knl-quasi-walk (fn (form dyn-env) - (cond - ((not (list? form)) form) - ((= (length form) 0) form) - ((and (string? (first form)) (= (first form) "$unquote")) - (cond - ((not (= (length form) 2)) - (error "$unquote: expects exactly 1 argument")) - (:else (kernel-eval (nth form 1) dyn-env)))) - (:else (knl-quasi-walk-list form dyn-env))))) - -(define knl-quasi-walk-list - (fn (forms dyn-env) - (cond - ((or (nil? forms) (= (length forms) 0)) (list)) - (:else - (let ((head (first forms))) - (cond - ((and (list? head) - (= (length head) 2) - (string? (first head)) - (= (first head) "$unquote-splicing")) - (let ((spliced (kernel-eval (nth head 1) dyn-env))) - (cond - ((not (list? spliced)) - (error "$unquote-splicing: value must be a list")) - (:else - (knl-list-concat - spliced - (knl-quasi-walk-list (rest forms) dyn-env)))))) - (:else - (cons (knl-quasi-walk head dyn-env) - (knl-quasi-walk-list (rest forms) dyn-env))))))))) - -(define knl-list-concat - (fn (xs ys) - (cond - ((or (nil? xs) (= (length xs) 0)) ys) - (:else (cons (first xs) (knl-list-concat (rest xs) ys)))))) + (refl-quasi-walk-with knl-quasi-cfg form dyn-env))) ;; $cond — multi-clause branch. ;; ($cond (TEST1 EXPR1 ...) (TEST2 EXPR2 ...) ...) diff --git a/lib/scheme/eval.sx b/lib/scheme/eval.sx index 5af0c24d..e5504016 100644 --- a/lib/scheme/eval.sx +++ b/lib/scheme/eval.sx @@ -346,46 +346,18 @@ ;; structure is the second-consumer candidate for ;; lib/guest/reflective/quoting.sx. +;; Scheme-side adapter for lib/guest/reflective/quoting.sx. Scheme +;; uses the bare unquote / unquote-splicing keywords and scheme-eval +;; as the host evaluator. Walker algorithm shared with Kernel via +;; the kit. +(define scm-quasi-cfg + {:unquote-name "unquote" + :unquote-splicing-name "unquote-splicing" + :eval (fn (form env) (scheme-eval form env))}) + (define scm-quasi-walk (fn (form env) - (cond - ((not (list? form)) form) - ((= (length form) 0) form) - ((and (string? (first form)) (= (first form) "unquote")) - (cond - ((not (= (length form) 2)) - (error "unquote: expects exactly 1 argument")) - (:else (scheme-eval (nth form 1) env)))) - (:else (scm-quasi-walk-list form env))))) - -(define scm-quasi-walk-list - (fn (forms env) - (cond - ((or (nil? forms) (= (length forms) 0)) (list)) - (:else - (let ((head (first forms))) - (cond - ((and (list? head) - (= (length head) 2) - (string? (first head)) - (= (first head) "unquote-splicing")) - (let ((spliced (scheme-eval (nth head 1) env))) - (cond - ((not (list? spliced)) - (error "unquote-splicing: value must be a list")) - (:else - (scm-list-concat - spliced - (scm-quasi-walk-list (rest forms) env)))))) - (:else - (cons (scm-quasi-walk head env) - (scm-quasi-walk-list (rest forms) env))))))))) - -(define scm-list-concat - (fn (xs ys) - (cond - ((or (nil? xs) (= (length xs) 0)) ys) - (:else (cons (first xs) (scm-list-concat (rest xs) ys)))))) + (refl-quasi-walk-with scm-quasi-cfg form env))) (scheme-define-op! "quasiquote" (fn (args env) @@ -614,7 +586,7 @@ ((and (list? form) (>= (length form) 1) (string? (first form)) (= (first form) "export")) (scm-collect-exports (rest forms) - (scm-list-concat acc (rest form)))) + (refl-quasi-list-concat acc (rest form)))) (:else (scm-collect-exports (rest forms) acc)))))))) (define scm-run-library-body diff --git a/lib/scheme/test.sh b/lib/scheme/test.sh index 130116d5..bd509fbe 100755 --- a/lib/scheme/test.sh +++ b/lib/scheme/test.sh @@ -41,6 +41,7 @@ emit_eval () { echo "(epoch $EPOCH)"; echo "(eval \"$1\")"; EPOCH=$((EPOCH+1)); { emit_load "lib/guest/lex.sx" emit_load "lib/guest/reflective/env.sx" + emit_load "lib/guest/reflective/quoting.sx" emit_load "lib/scheme/parser.sx" emit_load "lib/scheme/eval.sx" emit_load "lib/scheme/runtime.sx"