diff --git a/lib/scheme/eval.sx b/lib/scheme/eval.sx index dfb92c88..3b41b002 100644 --- a/lib/scheme/eval.sx +++ b/lib/scheme/eval.sx @@ -334,6 +334,140 @@ (scheme-define-op! "or" (fn (args env) (scm-or-step args env))) +;; ── syntax-rules / define-syntax (Phase 6a — no ellipsis yet) ──── +;; +;; Macros are tagged values: +;; {:scm-tag :macro :literals (LIT...) :rules ((PAT TMPL)...) :env E} +;; +;; The pattern matcher binds pattern variables to matched sub-forms; +;; the template instantiator substitutes those bindings back. No +;; hygiene yet — introduced symbols can shadow caller bindings. +;; Hygiene lands in a follow-up (Phase 6c — second consumer for +;; lib/guest/reflective/hygiene.sx). + +(define scheme-macro? + (fn (v) (and (dict? v) (= (get v :scm-tag) :macro)))) + +;; Pattern matching: returns a bindings dict or :scm-no-match. +;; The first PATTERN element is the macro keyword and is skipped. +(define scm-match + (fn (pat form literals) + (scm-match-step pat form literals {}))) + +(define scm-match-step + (fn (pat form literals bindings) + (cond + ;; pat is `_` (any) — match anything, no binding + ((and (string? pat) (= pat "_")) + bindings) + ;; pat is a literal symbol from the literals list + ((and (string? pat) (scm-is-literal? pat literals)) + (cond + ((and (string? form) (= form pat)) bindings) + (:else :scm-no-match))) + ;; pat is a pattern variable — bind + ((string? pat) + (cond + ((dict-has? bindings pat) :scm-no-match) ;; non-linear + (:else (assoc bindings pat form)))) + ;; pat is a list — match list-of-same-length + ((list? pat) + (cond + ((not (list? form)) :scm-no-match) + ((not (= (length pat) (length form))) :scm-no-match) + (:else (scm-match-list pat form literals bindings)))) + ;; literal value: must equal + (:else + (cond ((= pat form) bindings) (:else :scm-no-match)))))) + +(define scm-match-list + (fn (pats forms literals bindings) + (cond + ((or (nil? pats) (= (length pats) 0)) bindings) + (:else + (let ((sub (scm-match-step (first pats) (first forms) + literals bindings))) + (cond + ((= sub :scm-no-match) :scm-no-match) + (:else + (scm-match-list (rest pats) (rest forms) + literals sub)))))))) + +(define scm-is-literal? + (fn (name literals) + (cond + ((or (nil? literals) (= (length literals) 0)) false) + ((= (first literals) name) true) + (:else (scm-is-literal? name (rest literals)))))) + +;; Template instantiation: walk the template, substituting pattern +;; variables with their bindings; leave non-pattern-vars alone. +(define scm-instantiate + (fn (tmpl bindings) + (cond + ((and (string? tmpl) (dict-has? bindings tmpl)) + (get bindings tmpl)) + ((list? tmpl) + (cond + ((= (length tmpl) 0) tmpl) + (:else (map (fn (t) (scm-instantiate t bindings)) tmpl)))) + (:else tmpl)))) + +;; Try each rule against the form; return the instantiated template +;; or :scm-no-match if no rule matches. +(define scm-expand + (fn (macro-val form) + (scm-expand-rules + (get macro-val :rules) + form + (get macro-val :literals)))) + +(define scm-expand-rules + (fn (rules form literals) + (cond + ((or (nil? rules) (= (length rules) 0)) + (error (str "macro: no matching rule for: " form))) + (:else + (let ((rule (first rules))) + (let ((bindings (scm-match (first rule) form literals))) + (cond + ((= bindings :scm-no-match) + (scm-expand-rules (rest rules) form literals)) + (:else + (scm-instantiate (nth rule 1) bindings))))))))) + +;; (syntax-rules (LITERALS...) (PAT TMPL) ...) → macro value +(scheme-define-op! "syntax-rules" + (fn (args env) + (cond + ((< (length args) 1) + (error "syntax-rules: expects (literals) (pat tmpl)...")) + ((not (list? (first args))) + (error "syntax-rules: first arg must be the literals list")) + (:else + {:scm-tag :macro + :literals (first args) + :rules (rest args) + :env env})))) + +;; (define-syntax NAME SYNTAX-RULES-FORM) +(scheme-define-op! "define-syntax" + (fn (args env) + (cond + ((not (= (length args) 2)) + (error "define-syntax: expects (name syntax-rules-form)")) + ((not (string? (first args))) + (error "define-syntax: name must be a symbol")) + (:else + (let ((macro-val (scheme-eval (nth args 1) env))) + (cond + ((not (scheme-macro? macro-val)) + (error "define-syntax: value must be a macro")) + (:else + (begin + (scheme-env-bind! env (first args) macro-val) + macro-val)))))))) + ;; ── guard (R7RS exception clause-dispatch syntactic form) ──────── ;; (guard (var (test1 body1) (test2 body2) ... [else body]) body...) ;; @@ -437,6 +571,12 @@ (cond ((and (string? head) (scheme-syntactic-op? head)) ((get scheme-syntactic-ops head) rest-args env)) + ;; Macro dispatch: head looks up to a macro value. + ((and (string? head) + (scheme-env-has? env head) + (scheme-macro? (scheme-env-lookup env head))) + (scheme-eval (scm-expand (scheme-env-lookup env head) expr) + env)) (:else (let ((proc (scheme-eval head env)) diff --git a/lib/scheme/tests/macros.sx b/lib/scheme/tests/macros.sx new file mode 100644 index 00000000..992de7ee --- /dev/null +++ b/lib/scheme/tests/macros.sx @@ -0,0 +1,105 @@ +;; lib/scheme/tests/macros.sx — define-syntax + syntax-rules. + +(define scm-mac-pass 0) +(define scm-mac-fail 0) +(define scm-mac-fails (list)) + +(define + scm-mac-test + (fn + (name actual expected) + (if + (= actual expected) + (set! scm-mac-pass (+ scm-mac-pass 1)) + (begin + (set! scm-mac-fail (+ scm-mac-fail 1)) + (append! scm-mac-fails {:name name :actual actual :expected expected}))))) + +(define + scm-mac + (fn + (src) + (scheme-eval-program (scheme-parse-all src) (scheme-standard-env)))) + +;; ── Basic syntax-rules ────────────────────────────────────────── + +(scm-mac-test + "my-if true" + (scm-mac + "(define-syntax my-if (syntax-rules () ((_ c t e) (cond (c t) (else e)))))\n (my-if #t 'yes 'no)") + "yes") +(scm-mac-test + "my-if false" + (scm-mac + "(define-syntax my-if (syntax-rules () ((_ c t e) (cond (c t) (else e)))))\n (my-if #f 'yes 'no)") + "no") +(scm-mac-test + "double" + (scm-mac + "(define-syntax double (syntax-rules () ((_ x) (+ x x))))\n (double 21)") + 42) +(scm-mac-test + "nested macro use" + (scm-mac + "(define-syntax double (syntax-rules () ((_ x) (+ x x))))\n (double (double 5))") + 20) + +;; ── Macro with multiple rules ─────────────────────────────────── + +(scm-mac-test + "multi-rule: matches first" + (scm-mac + "(define-syntax twin (syntax-rules () ((_ a) a) ((_ a b) (+ a b))))\n (twin 7)") + 7) +(scm-mac-test + "multi-rule: matches second" + (scm-mac + "(define-syntax twin (syntax-rules () ((_ a) a) ((_ a b) (+ a b))))\n (twin 3 4)") + 7) + +;; ── Macros wrapping control flow ──────────────────────────────── + +(scm-mac-test + "swap idiom" + (scm-mac + "(define-syntax swap! (syntax-rules () ((_ a b) (let ((tmp a)) (set! a b) (set! b tmp)))))\n (define x 1) (define y 2)\n (swap! x y)\n (list x y)") + (list 2 1)) + +;; ── Macros that expand to expressions, not values ────────────── + +(scm-mac-test + "my-unless: true → empty" + (scm-mac + "(define-syntax my-unless (syntax-rules () ((_ c body) (if c 'skipped body))))\n (my-unless #t 99)") + "skipped") +(scm-mac-test + "my-unless: false → body" + (scm-mac + "(define-syntax my-unless (syntax-rules () ((_ c body) (if c 'skipped body))))\n (my-unless #f 99)") + 99) + +;; ── Macro with literal keyword ───────────────────────────────── + +(scm-mac-test + "literal: => recognised" + (scm-mac + "(define-syntax tag-arrow (syntax-rules (=>) ((_ a => b) (list 'arrow a b))))\n (tag-arrow 1 => 2)") + (list "arrow" 1 2)) + +;; ── Macro keyword passed through unevaluated ──────────────────── + +(scm-mac-test + "list expansion preserves arg order" + (scm-mac + "(define-syntax tuple (syntax-rules () ((_ a b c) (list a b c))))\n (tuple 1 2 3)") + (list 1 2 3)) + +;; ── Macros + lambdas ──────────────────────────────────────────── + +(scm-mac-test + "macro inside lambda" + (scm-mac + "(define-syntax sq (syntax-rules () ((_ x) (* x x))))\n (define (f n) (+ (sq n) 1))\n (f 5)") + 26) + +(define scm-mac-tests-run! (fn () {:total (+ scm-mac-pass scm-mac-fail) :passed scm-mac-pass :failed scm-mac-fail :fails scm-mac-fails}))