Step 7 complete: Metaprogramming and Staging (Steps 25-27)
ober
887523d0708aac4444cd12bb9e7b0cb70a2c2a75
--- a/Makefile +++ b/Makefile @@ -89,6 +89,7 @@ test-features: @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-stm.ss @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-ffi-bind.ss @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-match2.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-staging.ss test-all: test test-features test-wrappers new file mode 100644 --- /dev/null +++ b/lib/std/staging.sls @@ -0,0 +1,269 @@ +#!chezscheme +;;; (std staging) — Metaprogramming and Staging +;;; +;;; Step 25: Compile-Time Computation +;;; at-compile-time — evaluate expression at expand time, splice result as datum +;;; define/ct — define a compile-time constant +;;; +;;; Step 26: Code Generation DSL +;;; format-id — create a syntax identifier by string formatting +;;; struct-fields — introspect registered struct field names (runtime) +;;; derive-serializer — generate type-directed serializer at compile time +;;; derive-printer — generate pretty-printer at compile time +;;; quasigen — quasiquote-based code generation helper +;;; with-gensyms — bind fresh gensyms for macro hygiene +;;; +;;; Step 27: Syntax-Rules Extensions +;;; defrule/guard — syntax-rules with (where guard) clause filtering +;;; defrule/rec — recursive template transformer for tree rewriting +;;; syntax-walk — walk a syntax tree applying a transformer + +(library (std staging) + (export + ;; Step 25 + at-compile-time + define/ct + + ;; Step 26 + format-id + struct-fields + define-staging-type + derive-serializer + derive-printer + quasigen + with-gensyms + + ;; Step 27 + defrule/guard + defrule/rec + syntax-walk) + + (import (chezscheme)) + + ;; ========== Step 25: Compile-Time Computation ========== + + ;; (at-compile-time expr) + ;; Evaluates expr at macro-expansion time using eval. + ;; The result is spliced in as a quoted datum. + ;; + ;; Example: + ;; (define pi (at-compile-time (acos -1.0))) + ;; ;; expands to: (define pi 3.141592653589793) + (define-syntax at-compile-time + (lambda (stx) + (syntax-case stx () + [(_ expr) + (let* ([kw (car (syntax->list stx))] ;; identifier for datum->syntax context + [result (eval (syntax->datum #'expr) + (environment '(chezscheme)))]) + (datum->syntax kw (list 'quote result)))]))) + + ;; (define/ct name expr) + ;; Defines a constant whose value is computed at expand time. + ;; The runtime definition holds the pre-computed quoted value. + ;; + ;; Example: + ;; (define/ct max-ports 65535) + ;; (define/ct factor (* 6 7)) => defines factor as 42 + (define-syntax define/ct + (lambda (stx) + (syntax-case stx () + [(_ name expr) + (let* ([datum-expr (syntax->datum #'expr)] + [val (eval datum-expr (environment '(chezscheme)))] + [quoted-val (list 'quote val)]) + #`(define name #,(datum->syntax #'name quoted-val)))]))) + + ;; ========== Step 26: Code Generation DSL ========== + + ;; (format-id context-id fmt arg ...) + ;; Creates a new syntax identifier by formatting a string, using + ;; context-id for source location and lexical context. + ;; Each arg is converted: identifiers → their symbol string, others → format ~a. + ;; + ;; Example (use inside a macro transformer): + ;; (format-id #'point "~a-x" #'point) => #'point-x identifier + (define (format-id ctx fmt . args) + (let* ([str-args (map (lambda (a) + (if (identifier? a) + (symbol->string (syntax->datum a)) + (if (string? a) a (format "~a" a)))) + args)] + [name (string->symbol (apply format fmt str-args))]) + (datum->syntax ctx name))) + + ;; Runtime struct type registry: sym → (pred fields accessors) + (define *staging-struct-types* (make-eq-hashtable)) + + ;; (define-staging-type name pred (field ...) (acc ...)) + ;; Registers a struct type for runtime introspection via struct-fields. + (define-syntax define-staging-type + (syntax-rules () + [(_ type-name pred-fn (field ...) (acc ...)) + (hashtable-set! *staging-struct-types* 'type-name + (list pred-fn '(field ...) (list acc ...)))])) + + ;; (struct-fields name) + ;; Returns the list of field name symbols for a struct registered with + ;; define-staging-type. Returns '() if not registered. + (define (struct-fields name) + (let ([entry (hashtable-ref *staging-struct-types* name #f)]) + (if entry (cadr entry) '()))) + + ;; (derive-serializer struct-name (field ...) (acc ...)) + ;; Generates a serializer procedure at compile time. + ;; Fields and accessors are given explicitly to avoid phasing issues. + ;; + ;; Generated: (define (serialize-<name> obj port) ...) + ;; For each field f: writes (f . value) cons pair to port. + ;; + ;; Example: + ;; (derive-serializer point (x y) (point-x point-y)) + ;; (serialize-point (make-point 3 4) out-port) + ;; ;; writes (x . 3) then (y . 4) to out-port + (define-syntax derive-serializer + (lambda (stx) + (syntax-case stx () + [(_ struct-name (field ...) (acc ...)) + (let* ([name (syntax->datum #'struct-name)] + [fields (syntax->datum #'(field ...))] + [accs (syntax->datum #'(acc ...))] + [ser-id (datum->syntax #'struct-name + (string->symbol + (string-append "serialize-" (symbol->string name))))]) + (let ([field-writes + (map (lambda (f a) + (let ([f-stx (datum->syntax #'struct-name f)] + [a-stx (datum->syntax #'struct-name a)]) + #`(write (cons '#,f-stx (#,a-stx obj)) port))) + fields accs)]) + #`(define (#,ser-id obj port) + #,@field-writes)))]))) + + ;; (derive-printer struct-name (field ...) (acc ...)) + ;; Generates a pretty-printer that formats as "#<name field=val ...>". + ;; + ;; Example: + ;; (derive-printer point (x y) (point-x point-y)) + ;; (print-point (make-point 3 4)) => "#<point x=3 y=4>" + (define-syntax derive-printer + (lambda (stx) + (syntax-case stx () + [(_ struct-name (field ...) (acc ...)) + (let* ([name (syntax->datum #'struct-name)] + [fields (syntax->datum #'(field ...))] + [accs (syntax->datum #'(acc ...))] + [print-id (datum->syntax #'struct-name + (string->symbol + (string-append "print-" (symbol->string name))))] + [name-str (symbol->string name)]) + (let ([field-parts + (let loop ([fs fields] [as accs] [acc '()]) + (if (null? fs) + (reverse acc) + (let ([a-stx (datum->syntax #'struct-name (car as))] + [f-str (symbol->string (car fs))]) + (loop (cdr fs) (cdr as) + (cons #`(string-append " " #,f-str "=" (format "~a" (#,a-stx obj))) + acc)))))]) + #`(define (#,print-id obj) + (string-append "#<" #,name-str + #,@field-parts + ">"))))]))) + + ;; (quasigen ctx-id body ...) + ;; Returns a lambda that accepts a context identifier and generates + ;; syntax using the body expressions. Useful for parameterized code generators. + ;; + ;; Example: + ;; (define gen-adder + ;; (quasigen ctx + ;; #`(define (#,(format-id ctx "add-~a" ctx) a b) (+ a b)))) + ;; ;; Then: (gen-adder #'nums) => expands to (define (add-nums a b) (+ a b)) + (define-syntax quasigen + (syntax-rules () + [(_ ctx-id body ...) + (lambda (ctx-id) body ...)])) + + ;; (with-gensyms (id ...) body ...) + ;; Binds each id to a fresh generated syntax temp, for use in + ;; macro transformers to create hygienic temporaries. + ;; + ;; Example: + ;; (with-gensyms (tmp result) + ;; #`(let ([#,tmp (expensive)]) + ;; (let ([#,result (process #,tmp)]) + ;; #,result))) + (define-syntax with-gensyms + (syntax-rules () + [(_ (id ...) body ...) + (let ([id (car (generate-temporaries (list 'id)))] ...) + body ...)])) + + ;; ========== Step 27: Syntax-Rules Extensions ========== + + ;; (defrule/guard (name pat ...) (where guard-expr) template) + ;; (defrule/guard (name pat ...) template) + ;; + ;; Defines a macro with an optional compile-time guard. + ;; If guard-expr evaluates to #f at expand time, the rule doesn't apply. + ;; + ;; NOTE: guard-expr runs at compile time via eval; it cannot reference + ;; runtime bindings. It CAN reference pattern variables as syntax objects. + ;; + ;; Example: + ;; (defrule/guard (my-add a b) template) ;; simple, no guard + (define-syntax defrule/guard + (lambda (stx) + (syntax-case stx (where) + ;; With (where guard-expr) + [(_ (name . pats) (where guard-expr) template) + #'(define-syntax name + (lambda (s) + (syntax-case s () + [(_ . pats) + (eval (syntax->datum #'guard-expr) (environment '(chezscheme))) + #'template] + [_ (syntax-error s "invalid syntax or guard failed")])))] + ;; Without guard + [(_ (name . pats) template) + #'(define-syntax name + (syntax-rules () + [(_ . pats) template]))]))) + + ;; (defrule/rec name transformer-proc) + ;; Defines a macro that recursively rewrites its argument using transformer-proc. + ;; transformer-proc: stx → stx | #f + ;; - If it returns a syntax object, that replaces the node. + ;; - If it returns #f, the node is descended into (for list nodes). + ;; + ;; Usage: (name expr) → recursively-transformed-expr + (define-syntax defrule/rec + (syntax-rules () + [(_ name transformer-proc) + (define-syntax name + (lambda (stx) + (syntax-case stx () + [(_ expr) + (syntax-walk #'expr transformer-proc)])))])) + + ;; (syntax-walk stx proc) + ;; Walk a syntax tree depth-first, applying proc to each node. + ;; proc: stx → stx | #f + ;; Returns a new syntax tree with all proc-returning-non-#f nodes replaced. + (define (syntax-walk stx proc) + (let ([result (proc stx)]) + (if result + result + (let ([d (syntax->datum stx)]) + (cond + [(pair? d) + ;; datum->syntax needs an identifier for context; use first element + (let* ([parts (syntax->list stx)] + [walked (map (lambda (sub) (syntax-walk sub proc)) parts)] + [ctx-id (car parts)]) ;; first element as context identifier + (datum->syntax ctx-id + (map syntax->datum walked)))] + [else stx]))))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/tests/test-staging.ss @@ -0,0 +1,245 @@ +#!chezscheme +;;; Tests for (std staging) — Metaprogramming and Staging + +(import (chezscheme) (std staging)) + +(define pass 0) +(define fail 0) + +(define-syntax test + (syntax-rules () + [(_ name expr expected) + (guard (exn [#t (set! fail (+ fail 1)) + (printf "FAIL ~a: ~a~%" name + (if (message-condition? exn) (condition-message exn) exn))]) + (let ([got expr]) + (if (equal? got expected) + (begin (set! pass (+ pass 1)) (printf " ok ~a~%" name)) + (begin (set! fail (+ fail 1)) + (printf "FAIL ~a: got ~s expected ~s~%" name got expected)))))])) + +(printf "--- (std staging) tests ---~%") + +;;; ======== Step 25: at-compile-time ======== + +(printf "~%-- at-compile-time --~%") + +;; Simple compile-time arithmetic +(define ct-sum (at-compile-time (+ 1 2 3 4 5))) +(test "at-compile-time: arithmetic" + ct-sum + 15) + +;; Compile-time string manipulation +(define ct-greeting (at-compile-time (string-append "Hello" ", " "World"))) +(test "at-compile-time: string-append" + ct-greeting + "Hello, World") + +;; Compile-time list +(define ct-list (at-compile-time (list 1 2 3))) +(test "at-compile-time: list" + ct-list + '(1 2 3)) + +;; Compile-time pi approximation +(define ct-pi (at-compile-time (acos -1.0))) +(test "at-compile-time: acos" + (< 3.14 ct-pi 3.15) + #t) + +;;; ======== Step 25: define/ct ======== + +(printf "~%-- define/ct --~%") + +(define/ct max-count 100) +(test "define/ct: constant" + max-count + 100) + +(define/ct port-range (list 80 443 8080)) +(test "define/ct: list" + port-range + '(80 443 8080)) + +;;; ======== Step 26: format-id ======== + +(printf "~%-- format-id --~%") + +;; format-id creates a new identifier +(define-syntax make-getter + (lambda (stx) + (syntax-case stx () + [(_ name) + (let ([getter (format-id #'name "get-~a" #'name)]) + #`(define (#,getter x) x))]))) + +(make-getter value) +(test "format-id: generated getter" + (get-value 42) + 42) + +;; format-id with string arg +(define-syntax make-counter + (lambda (stx) + (syntax-case stx () + [(_ base) + (let ([counter-name (format-id #'base "~a-count" "total")]) + #`(define #,counter-name 0))]))) + +(make-counter foo) +(test "format-id: string arg" + total-count + 0) + +;;; ======== Step 26: struct-fields + derive-serializer ======== + +(printf "~%-- define-staging-type / derive-serializer --~%") + +;; Register a simple struct +(define-record-type (vec2 make-vec2 vec2?) + (fields (immutable x vec2-x) + (immutable y vec2-y))) + +(define-staging-type vec2 vec2? (x y) (vec2-x vec2-y)) + +(test "struct-fields: returns field names" + (struct-fields 'vec2) + '(x y)) + +(test "struct-fields: unknown returns empty" + (struct-fields 'nosuchthing) + '()) + +;; derive-serializer (fields/accessors given explicitly) +(derive-serializer vec2 (x y) (vec2-x vec2-y)) + +(test "derive-serializer: serializes to pairs" + (let ([out (open-output-string)]) + (serialize-vec2 (make-vec2 3 4) out) + (get-output-string out)) + "(x . 3)(y . 4)") + +;;; ======== Step 26: derive-printer ======== + +(printf "~%-- derive-printer --~%") + +(define-record-type (color make-color color?) + (fields (immutable r color-r) + (immutable g color-g) + (immutable b color-b))) + +(define-staging-type color color? (r g b) (color-r color-g color-b)) + +(derive-printer color (r g b) (color-r color-g color-b)) + +(test "derive-printer: formats as #<name field=val ...>" + (print-color (make-color 255 0 128)) + "#<color r=255 g=0 b=128>") + +;;; ======== Step 26: with-gensyms ======== + +(printf "~%-- with-gensyms --~%") + +(define-syntax swap! + (lambda (stx) + (syntax-case stx () + [(_ a b) + (with-gensyms (tmp) + #`(let ([#,tmp a]) + (set! a b) + (set! b #,tmp)))]))) + +(test "with-gensyms: swap" + (let ([x 1] [y 2]) + (swap! x y) + (list x y)) + '(2 1)) + +;;; ======== Step 26: quasigen ======== + +(printf "~%-- quasigen --~%") + +;; quasigen creates a code-generating lambda +(define gen-add + (quasigen ctx + #`(define (#,(format-id ctx "add-~a" ctx) a b) (+ a b)))) + +;; Apply the generator with a context identifier +(define-syntax make-adder + (lambda (stx) + (syntax-case stx () + [(_ name) + (gen-add #'name)]))) + +(make-adder nums) +(test "quasigen: generated adder" + (add-nums 3 4) + 7) + +;;; ======== Step 27: defrule/guard ======== + +(printf "~%-- defrule/guard --~%") + +;; defrule/guard without guard (same as defrule) +(defrule/guard (my-and a b) + (if a b #f)) + +(test "defrule/guard: no guard" + (my-and #t 42) + 42) + +(test "defrule/guard: no guard false" + (my-and #f 42) + #f) + +;;; ======== Step 27: syntax-walk ======== + +(printf "~%-- syntax-walk --~%") + +;; syntax-walk processes a tree +(test "syntax-walk: identity (no replacements)" + (let ([walked (syntax-walk #'(+ 1 2) (lambda (stx) #f))]) + (syntax->datum walked)) + '(+ 1 2)) + +(test "syntax-walk: returns #f on leaf without match" + (let ([walked (syntax-walk #'42 (lambda (stx) #f))]) + (syntax->datum walked)) + 42) + +;;; ======== Integration: compile-time table ======== + +(printf "~%-- integration: compile-time lookup table --~%") + +;; Build a lookup table at compile time using at-compile-time +(define/ct factorial-10 (let loop ([i 1] [acc 1]) + (if (> i 10) acc (loop (+ i 1) (* acc i))))) + +(test "compile-time factorial" + factorial-10 + 3628800) + +;; Macro that generates definitions via format-id + quasigen +(define-syntax define-pair-ops + (lambda (stx) + (syntax-case stx () + [(_ name a b) + (let ([fst-id (datum->syntax #'name + (string->symbol (string-append (symbol->string (syntax->datum #'name)) "-fst")))] + [snd-id (datum->syntax #'name + (string->symbol (string-append (symbol->string (syntax->datum #'name)) "-snd")))]) + #`(begin + (define (#,fst-id) a) + (define (#,snd-id) b)))]))) + +(define-pair-ops coords 10 20) + + +(test "macro code gen: pair ops" + (list (coords-fst) (coords-snd)) + '(10 20)) + +(printf "~%~a tests: ~a passed, ~a failed~%" + (+ pass fail) pass fail) +(when (> fail 0) (exit 1))