Phase 4d complete: Developer Experience (5 libraries, 220 tests passing)
ober
caf9041a52e2d2dbe51ea6f73973ee1585dba326
--- a/Makefile +++ b/Makefile @@ -160,6 +160,14 @@ test-phase4c: @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-deadlock.ss @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-concur-util.ss +test-phase4d: + @echo "--- Phase 4d: Developer Experience tests ---" + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-timetravel.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-flamegraph.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-proptest.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-staging2.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-match-syntax.ss + test-all: test test-features test-wrappers clean: --- a/docs/implement.md +++ b/docs/implement.md @@ -1160,51 +1160,51 @@ Every build artifact is identified by the hash of its inputs. Same inputs → sa ### Phase 4d: Developer Experience -| # | Item | Track | Est. LOC | Priority | -|---|------|-------|----------|----------| -| 19 | Time-travel debugger | 6.1 | 400 | Medium | -| 20 | Flame graph profiler | 6.3 | 800 | High | -| 21 | Property-based testing | 6.4 | 1,700 | High | -| 22 | Multi-stage programming | 4.1 | 500 | Medium | -| 23 | Syntax-level match | 4.2 | 350 | Medium | -| 24 | Compile-time contracts | 4.3 | 250 | Low | -| **Subtotal** | | | **~4,000** | | +| # | Item | Track | Est. LOC | Priority | +|--------------|-------------------------|-------|------------|----------| +| 19 | Time-travel debugger | 6.1 | 400 | Medium | +| 20 | Flame graph profiler | 6.3 | 800 | High | +| 21 | Property-based testing | 6.4 | 1,700 | High | +| 22 | Multi-stage programming | 4.1 | 500 | Medium | +| 23 | Syntax-level match | 4.2 | 350 | Medium | +| 24 | Compile-time contracts | 4.3 | 250 | Low | +| **Subtotal** | | | **~4,000** | | ### Phase 4e: Data and Distribution -| # | Item | Track | Est. LOC | Priority | -|---|------|-------|----------|----------| -| 25 | Dataframes | 7.2 | 700 | Medium | -| 26 | Stream windowing | 7.3 | 500 | Medium | -| 27 | Distributed actors | 8.1 | 800 | High | -| 28 | WASI support | 8.2 | 400 | Medium | -| 29 | Continuation serialization | 1.3 | 250 | Low | -| **Subtotal** | | | **~2,650** | | +| # | Item | Track | Est. LOC | Priority | +|--------------|----------------------------|-------|------------|----------| +| 25 | Dataframes | 7.2 | 700 | Medium | +| 26 | Stream windowing | 7.3 | 500 | Medium | +| 27 | Distributed actors | 8.1 | 800 | High | +| 28 | WASI support | 8.2 | 400 | Medium | +| 29 | Continuation serialization | 1.3 | 250 | Low | +| **Subtotal** | | | **~2,650** | | ### Phase 4f: Toolchain and Interop -| # | Item | Track | Est. LOC | Priority | -|---|------|-------|----------|----------| -| 30 | LSP 2.0 | 8.3 | 1,600 | High | -| 31 | Python interop | 8.4 | 600 | Medium | -| 32 | File watching + incremental build | 10.1 | 400 | High | -| 33 | Cross-compilation pipeline | 10.2 | 400 | Medium | -| 34 | Reproducible builds | 10.3 | 350 | Medium | -| **Subtotal** | | | **~3,350** | | +| # | Item | Track | Est. LOC | Priority | +|--------------|-----------------------------------|-------|------------|----------| +| 30 | LSP 2.0 | 8.3 | 1,600 | High | +| 31 | Python interop | 8.4 | 600 | Medium | +| 32 | File watching + incremental build | 10.1 | 400 | High | +| 33 | Cross-compilation pipeline | 10.2 | 400 | Medium | +| 34 | Reproducible builds | 10.3 | 350 | Medium | +| **Subtotal** | | | **~3,350** | | --- ## Total Estimated Code -| Phase | LOC | New Modules | New Tests | -|-------|-----|-------------|-----------| -| 4a: Core Runtime | 4,600 | ~10 | ~200 | -| 4b: Type System | 3,800 | ~8 | ~180 | -| 4c: Systems | 2,800 | ~8 | ~150 | -| 4d: Developer Experience | 4,000 | ~10 | ~200 | -| 4e: Data & Distribution | 2,650 | ~7 | ~150 | -| 4f: Toolchain & Interop | 3,350 | ~8 | ~150 | -| **Total Phase 4** | **~21,200** | **~51** | **~1,030** | +| Phase | LOC | New Modules | New Tests | +|--------------------------|-------------|-------------|------------| +| 4a: Core Runtime | 4,600 | ~10 | ~200 | +| 4b: Type System | 3,800 | ~8 | ~180 | +| 4c: Systems | 2,800 | ~8 | ~150 | +| 4d: Developer Experience | 4,000 | ~10 | ~200 | +| 4e: Data & Distribution | 2,650 | ~7 | ~150 | +| 4f: Toolchain & Interop | 3,350 | ~8 | ~150 | +| **Total Phase 4** | **~21,200** | **~51** | **~1,030** | Combined with existing ~52,000 lines across 138+ modules, Jerboa would be ~73,000 lines across ~190 modules with ~2,550 tests. Still dramatically more compact than Racket (~700K), Guile (~300K), or Gerbil+Gambit (~80K). new file mode 100644 --- /dev/null +++ b/lib/std/debug/flamegraph.sls @@ -0,0 +1,352 @@ +#!chezscheme +;;; (std debug flamegraph) — Flame Graph Profiler +;;; +;;; Manual instrumentation profiler (enter/exit) that builds call-stack +;;; sample data and can emit folded flame graph text for flamegraph.pl. + +(library (std debug flamegraph) + (export + ;; Profiler control + make-profiler + profiler? + profiler-start! + profiler-stop! + profiler-reset! + profiler-running? + ;; Data collection (manual instrumentation) + profiler-enter! + profiler-exit! + profile-fn + with-profile + ;; Results + profiler-samples + profiler-flat-stats + profiler-tree + profiler-hotspots + profiler-total-samples + ;; Output + profiler->flamegraph-text + profiler->alist + display-profile + ;; Timing (wall-clock based) + profiler-timing-enter! + profiler-timing-exit! + profile-fn/timed + with-profile/timed + profiler-timing-stats + ;; Convenience + profile-thunk + top-k-hotspots) + + (import (chezscheme)) + + ;; ========== Wall-clock time in milliseconds ========== + + (define (now-ms) + (let ([t (current-time 'time-utc)]) + (+ (* (time-second t) 1000.0) + (/ (time-nanosecond t) 1000000.0)))) + + ;; ========== Profiler record ========== + ;; - call-stack: mutable list (current head = top of stack) + ;; - samples: hashtable from stack-key -> count + ;; - timing-stack: list of (fn-name . enter-ms) pairs + ;; - timing-data: hashtable fn-name -> (calls total-ms) + ;; - running?: flag + + (define-record-type %profiler + (fields + (mutable call-stack) ;; list of fn-name symbols/strings + (mutable samples-ht) ;; hashtable: stack-key -> count + (mutable timing-stack) ;; list of (fn-name . enter-ms) + (mutable timing-ht) ;; hashtable: fn-name -> (calls . total-ms) + (mutable running?)) + (protocol + (lambda (new) + (lambda () + (new '() + (make-hashtable equal-hash equal?) + '() + (make-hashtable equal-hash equal?) + #f))))) + + + ;; Per-profiler mutex table + (define *profiler-mutex-table* (make-eq-hashtable)) + + (define (profiler-mutex prof) + (let ([m (hashtable-ref *profiler-mutex-table* prof #f)]) + (or m + (let ([new-m (make-mutex)]) + (hashtable-set! *profiler-mutex-table* prof new-m) + new-m)))) + + (define (make-profiler) + (let ([p (make-%profiler)]) + (profiler-mutex p) + p)) + + (define (profiler? x) (%profiler? x)) + (define (profiler-running? prof) (%profiler-running? prof)) + + (define (profiler-start! prof . opts) + ;; opts: #:interval-ms N (accepted but ignored — we use manual instrumentation) + (with-mutex (profiler-mutex prof) + (%profiler-running?-set! prof #t))) + + (define (profiler-stop! prof) + (with-mutex (profiler-mutex prof) + (%profiler-running?-set! prof #f))) + + (define (profiler-reset! prof) + (with-mutex (profiler-mutex prof) + (%profiler-call-stack-set! prof '()) + (%profiler-samples-ht-set! prof (make-hashtable equal-hash equal?)) + (%profiler-timing-stack-set! prof '()) + (%profiler-timing-ht-set! prof (make-hashtable equal-hash equal?)) + (%profiler-running?-set! prof #f))) + + ;; ========== Stack key ========== + ;; A stack is represented as a list of fn-names (current call first). + ;; The key for the hashtable is the list itself (equal? comparison). + + (define (record-stack-sample! prof stack) + (when (%profiler-running? prof) + (let* ([ht (%profiler-samples-ht prof)] + [cnt (hashtable-ref ht stack 0)]) + (hashtable-set! ht stack (+ cnt 1))))) + + ;; ========== Enter / Exit ========== + + (define (profiler-enter! prof fn-name) + (with-mutex (profiler-mutex prof) + (when (%profiler-running? prof) + (let ([new-stack (cons fn-name (%profiler-call-stack prof))]) + (%profiler-call-stack-set! prof new-stack) + (record-stack-sample! prof new-stack))))) + + (define (profiler-exit! prof fn-name) + (with-mutex (profiler-mutex prof) + (when (%profiler-running? prof) + (let ([stack (%profiler-call-stack prof)]) + (unless (null? stack) + (%profiler-call-stack-set! prof (cdr stack))))))) + + ;; ========== Wrappers ========== + + (define (profile-fn prof fn) + (let ([name (or (procedure? fn) fn)]) + (lambda args + (profiler-enter! prof fn) + (let ([result (apply fn args)]) + (profiler-exit! prof fn) + result)))) + + (define-syntax with-profile + (syntax-rules () + [(_ prof name body ...) + (dynamic-wind + (lambda () (profiler-enter! prof 'name)) + (lambda () body ...) + (lambda () (profiler-exit! prof 'name)))])) + + ;; ========== Results ========== + + (define (profiler-samples prof) + ;; Returns list of (stack . count) pairs + (with-mutex (profiler-mutex prof) + (let-values ([(keys vals) (hashtable-entries (%profiler-samples-ht prof))]) + (map cons (vector->list keys) (vector->list vals))))) + + (define (profiler-total-samples prof) + (apply + (map cdr (profiler-samples prof)))) + + (define (profiler-flat-stats prof) + ;; alist of fn-name -> total-samples (counts all stacks fn appears in) + (let ([samples (profiler-samples prof)] + [ht (make-hashtable equal-hash equal?)]) + (for-each + (lambda (pair) + (let ([stack (car pair)] + [count (cdr pair)]) + (for-each + (lambda (fn) + (hashtable-set! ht fn (+ (hashtable-ref ht fn 0) count))) + stack))) + samples) + (let-values ([(keys vals) (hashtable-entries ht)]) + (map cons (vector->list keys) (vector->list vals))))) + + (define (profiler-hotspots prof) + ;; All functions sorted by sample count descending + (list-sort (lambda (a b) (> (cdr a) (cdr b))) + (profiler-flat-stats prof))) + + (define (top-k-hotspots prof k) + (let ([hs (profiler-hotspots prof)]) + (take-at-most hs k))) + + ;; take-at-most: return up to n elements from list + (define (take-at-most lst n) + (if (or (null? lst) (= n 0)) + '() + (cons (car lst) (take-at-most (cdr lst) (- n 1))))) + + ;; ========== Tree ========== + ;; Returns nested alist: (fn-name count . children-alist) + ;; children-alist entries: same structure + + (define (profiler-tree prof) + ;; Build tree from samples. Stack is stored newest-first (top of call stack first), + ;; so reverse each stack to get root->leaf order. + (let ([samples (profiler-samples prof)]) + (build-tree samples))) + + (define (build-tree samples) + ;; Each sample's stack is (top ... bottom). Reverse to get call path root->leaf. + ;; We build a trie of (fn . (count . children-map)) + (let ([root (list '*root* 0 '())]) + (for-each + (lambda (pair) + (let ([path (reverse (car pair))] + [count (cdr pair)]) + (insert-path! root path count))) + samples) + (cddr root))) ;; return children of root + + (define (insert-path! node path count) + ;; node is (name total-count . children-list) + ;; children-list is list of (name total-count . children-list) + (unless (null? path) + (let* ([fn (car path)] + [rest (cdr path)] + [children (%node-children node)] + [child (assoc fn children)]) + (if child + (begin + (%node-add-count! child count) + (insert-path! child rest count)) + (let ([new-child (list fn count '())]) + (%node-set-children! node (cons new-child children)) + (insert-path! new-child rest count)))))) + + (define (%node-children n) (cddr n)) + (define (%node-add-count! n c) (set-car! (cdr n) (+ (cadr n) c))) + (define (%node-set-children! n ch) (set-cdr! (cdr n) (list ch))) + + ;; ========== Output ========== + + (define (profiler->flamegraph-text prof . port-opt) + ;; Folded format: "fn1;fn2;fn3 count" per line (root;...;leaf count) + ;; Stack stored top-first, so reverse for root->leaf order. + (let* ([out (open-output-string)] + [samples (profiler-samples prof)]) + (for-each + (lambda (pair) + (let ([stack (reverse (car pair))] + [count (cdr pair)]) + (let loop ([s stack] [first? #t]) + (unless (null? s) + (unless first? (display ";" out)) + (display (car s) out) + (loop (cdr s) #f))) + (fprintf out " ~a~%" count))) + (list-sort (lambda (a b) + (string<? (stack->string (car a)) + (stack->string (car b)))) + samples)) + (let ([s (get-output-string out)]) + (when (pair? port-opt) (display s (car port-opt))) + s))) + + (define (stack->string stack) + (apply string-append + (map (lambda (fn) (if (symbol? fn) (symbol->string fn) (format "~a" fn))) + stack))) + + (define (profiler->alist prof) + (profiler-samples prof)) + + (define (display-profile prof . port-opt) + (let* ([port (if (pair? port-opt) (car port-opt) (current-output-port))] + [hotspots (profiler-hotspots prof)] + [total (profiler-total-samples prof)]) + (fprintf port "~%Profile Results~%") + (fprintf port "~a~%" (make-string 50 #\-)) + (fprintf port "~30a ~8a ~6a~%" "Function" "Samples" "%") + (fprintf port "~a~%" (make-string 50 #\-)) + (for-each + (lambda (pair) + (let* ([fn (car pair)] + [cnt (cdr pair)] + [pct (if (> total 0) (* 100.0 (/ cnt total)) 0.0)]) + (fprintf port "~30a ~8a ~5,1f%~%" fn cnt pct))) + hotspots) + (fprintf port "~a~%" (make-string 50 #\-)) + (fprintf port "Total samples: ~a~%~%" total))) + + ;; ========== Timing ========== + + (define (profiler-timing-enter! prof fn-name) + (with-mutex (profiler-mutex prof) + (%profiler-timing-stack-set! prof + (cons (cons fn-name (now-ms)) + (%profiler-timing-stack prof))))) + + (define (profiler-timing-exit! prof fn-name) + (with-mutex (profiler-mutex prof) + (let ([tstack (%profiler-timing-stack prof)]) + (unless (null? tstack) + (let* ([entry (car tstack)] + [name (car entry)] + [start (cdr entry)] + [elapsed (- (now-ms) start)] + [ht (%profiler-timing-ht prof)] + [old (hashtable-ref ht name #f)]) + (%profiler-timing-stack-set! prof (cdr tstack)) + (if old + (hashtable-set! ht name + (cons (+ (car old) 1) (+ (cdr old) elapsed))) + (hashtable-set! ht name (cons 1 elapsed)))))))) + + (define (profile-fn/timed prof fn) + (lambda args + (profiler-timing-enter! prof fn) + (let ([result (apply fn args)]) + (profiler-timing-exit! prof fn) + result))) + + (define-syntax with-profile/timed + (syntax-rules () + [(_ prof name body ...) + (dynamic-wind + (lambda () (profiler-timing-enter! prof 'name)) + (lambda () body ...) + (lambda () (profiler-timing-exit! prof 'name)))])) + + (define (profiler-timing-stats prof) + ;; Returns alist of fn-name -> (calls total-ms avg-ms) + (with-mutex (profiler-mutex prof) + (let-values ([(keys vals) (hashtable-entries (%profiler-timing-ht prof))]) + (map (lambda (fn entry) + (let ([calls (car entry)] + [total (cdr entry)]) + (list fn calls total + (if (> calls 0) (/ total calls) 0.0)))) + (vector->list keys) + (vector->list vals))))) + + ;; ========== Convenience ========== + + (define (profile-thunk thunk) + ;; Run thunk with a fresh profiler, return profiler stats + (let ([prof (make-profiler)]) + (profiler-start! prof) + (thunk) + (profiler-stop! prof) + (list + 'samples (profiler-samples prof) + 'flat-stats (profiler-flat-stats prof) + 'total (profiler-total-samples prof)))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/debug/timetravel.sls @@ -0,0 +1,248 @@ +#!chezscheme +;;; (std debug timetravel) — Time-Travel Debugger with Replay +;;; +;;; Records program events (calls, returns, state changes, snapshots) +;;; in a mutex-protected recorder so execution can be replayed and inspected. + +(library (std debug timetravel) + (export + ;; Recording + make-recorder + recorder? + recorder-start! + recorder-stop! + recorder-events + recorder-event-count + recorder-reset! + ;; Event logging + record-event! + record-call! + record-return! + record-state! + ;; Replay + replay-events + replay-to-step + ;; Event structure + make-event + event? + event-tag + event-data + event-timestamp + event-step + ;; Instrumentation macro + with-recording + trace-fn + ;; Inspection + events-between + events-by-tag + event-diff + ;; Snapshot/restore + record-snapshot! + find-snapshot + snapshots-for) + + (import (chezscheme)) + + ;; ========== Event ========== + ;; Immutable record: tag, data, timestamp (real-time ms), step (monotonic counter) + + (define-record-type %event + (fields tag data timestamp step) + (protocol + (lambda (new) + (lambda (tag data timestamp step) + (new tag data timestamp step))))) + + (define (make-event tag data timestamp step) + (make-%event tag data timestamp step)) + + (define (event? x) (%event? x)) + (define (event-tag e) (%event-tag e)) + (define (event-data e) (%event-data e)) + (define (event-timestamp e) (%event-timestamp e)) + (define (event-step e) (%event-step e)) + + ;; ========== Current wall-clock time in milliseconds ========== + + (define (now-ms) + (let ([t (current-time 'time-utc)]) + (+ (* (time-second t) 1000) + (quotient (time-nanosecond t) 1000000)))) + + ;; ========== Recorder ========== + ;; Wraps a mutex-protected list of events (newest-first) + step counter + running? flag + + (define-record-type %recorder + (fields + (mutable events-rev) ;; events in reverse order (newest first) + (mutable step-counter) ;; monotonic step counter + (mutable running?)) ;; #t while recording + (protocol + (lambda (new) + (lambda () + (new '() 0 #f))))) + + (define *recorder-mutex-table* (make-eq-hashtable)) + + (define (recorder-mutex rec) + (let ([m (hashtable-ref *recorder-mutex-table* rec #f)]) + (or m + (let ([new-m (make-mutex)]) + (hashtable-set! *recorder-mutex-table* rec new-m) + new-m)))) + + (define (make-recorder) + (let ([r (make-%recorder)]) + ;; Pre-allocate mutex + (recorder-mutex r) + r)) + + (define (recorder? x) (%recorder? x)) + + (define (recorder-start! rec) + (with-mutex (recorder-mutex rec) + (%recorder-running?-set! rec #t))) + + (define (recorder-stop! rec) + (with-mutex (recorder-mutex rec) + (%recorder-running?-set! rec #f))) + + (define (recorder-reset! rec) + (with-mutex (recorder-mutex rec) + (%recorder-events-rev-set! rec '()) + (%recorder-step-counter-set! rec 0) + (%recorder-running?-set! rec #f))) + + ;; Returns events in replay order (oldest first) + (define (recorder-events rec) + (with-mutex (recorder-mutex rec) + (reverse (%recorder-events-rev rec)))) + + (define (recorder-event-count rec) + (with-mutex (recorder-mutex rec) + (length (%recorder-events-rev rec)))) + + ;; ========== Event Logging ========== + + (define (record-event! rec tag data) + (with-mutex (recorder-mutex rec) + (when (%recorder-running? rec) + (let* ([step (+ (%recorder-step-counter rec) 1)] + [ts (now-ms)] + [ev (make-%event tag data ts step)]) + (%recorder-step-counter-set! rec step) + (%recorder-events-rev-set! rec + (cons ev (%recorder-events-rev rec))))))) + + (define (record-call! rec fn-name args) + (record-event! rec 'call (list fn-name args))) + + (define (record-return! rec fn-name result) + (record-event! rec 'return (list fn-name result))) + + (define (record-state! rec label value) + (record-event! rec 'state (list label value))) + + (define (record-snapshot! rec label value) + (record-event! rec 'snapshot (list label value))) + + ;; ========== Replay ========== + + (define (replay-events events handler-proc) + (for-each handler-proc events)) + + ;; Replay up to step n; return state value from the last record-state! event seen + (define (replay-to-step events n) + (let loop ([evs events] [last-state #f]) + (cond + [(null? evs) last-state] + [else + (let ([ev (car evs)]) + (if (> (%event-step ev) n) + last-state + (let ([new-state + (if (eq? (%event-tag ev) 'state) + (cadr (%event-data ev)) + last-state)]) + (loop (cdr evs) new-state))))]))) + + ;; ========== Instrumentation ========== + + ;; (with-recording rec body ...) macro — starts before body, stops after (dynamic-wind) + (define-syntax with-recording + (syntax-rules () + [(_ rec body ...) + (dynamic-wind + (lambda () (recorder-start! rec)) + (lambda () body ...) + (lambda () (recorder-stop! rec)))])) + + ;; trace-fn — wraps fn to auto-record calls and returns + (define (trace-fn rec fn) + (lambda args + (record-call! rec fn args) + (let ([result (apply fn args)]) + (record-return! rec fn result) + result))) + + ;; ========== Inspection ========== + + (define (events-between events t1 t2) + (filter (lambda (ev) + (and (>= (%event-timestamp ev) t1) + (<= (%event-timestamp ev) t2))) + events)) + + (define (events-by-tag events tag) + (filter (lambda (ev) (equal? (%event-tag ev) tag)) events)) + + ;; Returns a description of the difference between two events + (define (event-diff e1 e2) + (let ([same-tag? (equal? (event-tag e1) (event-tag e2))] + [same-data? (equal? (event-data e1) (event-data e2))] + [step-diff (- (event-step e2) (event-step e1))]) + (cond + [(and same-tag? same-data?) + (list 'identical 'step-delta step-diff)] + [same-tag? + (list 'same-tag (event-tag e1) 'data-changed + (list 'from (event-data e1) 'to (event-data e2)))] + [else + (list 'tag-changed + (list 'from (event-tag e1) 'to (event-tag e2)) + 'data-changed + (list 'from (event-data e1) 'to (event-data e2)))]))) + + ;; ========== Snapshot helpers ========== + + (define (find-snapshot events label) + ;; Most recent snapshot with matching label (events are in replay order = oldest first) + ;; We scan all and keep the last match + (let loop ([evs events] [result #f]) + (if (null? evs) + result + (let ([ev (car evs)]) + (loop (cdr evs) + (if (and (eq? (event-tag ev) 'snapshot) + (equal? (car (event-data ev)) label)) + (cadr (event-data ev)) + result)))))) + + (define (snapshots-for events label) + ;; All snapshots with matching label, in replay order + (filter-map + (lambda (ev) + (and (eq? (event-tag ev) 'snapshot) + (equal? (car (event-data ev)) label) + (cadr (event-data ev)))) + events)) + + ;; filter-map helper + (define (filter-map f lst) + (let loop ([lst lst] [acc '()]) + (if (null? lst) + (reverse acc) + (let ([v (f (car lst))]) + (loop (cdr lst) (if v (cons v acc) acc)))))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/match-syntax.sls @@ -0,0 +1,432 @@ +#!chezscheme +;;; (std match-syntax) — Syntax-Level Pattern Matching +;;; +;;; Pattern matching on syntax objects (ASTs) represented as plain Scheme data. +;;; Designed for macro writers who want to analyze and transform code structurally. +;;; Works with plain lists/symbols (code-as-data), not Chez syntax objects. + +(library (std match-syntax) + (export + ;; Core matching + match-pattern + syntax-match + syntax-match* + ;; AST predicates + stx-identifier? + stx-literal? + stx-list? + stx-pair? + stx-null? + stx-application? + stx-lambda? + stx-if? + stx-let? + stx-define? + stx-begin? + stx-quote? + ;; Destructuring + stx-app-fn + stx-app-args + stx-lambda-formals + stx-lambda-body + stx-if-test + stx-if-then + stx-if-else + stx-let-bindings + stx-let-body + stx-define-name + stx-define-value + stx-begin-exprs + stx-identifier-symbol + ;; Code walking + walk-syntax + fold-syntax + free-identifiers + ;; Building syntax + build-let + build-lambda + build-if + build-begin + build-app) + + (import (chezscheme)) + + ;; ========== AST Predicates ========== + ;; + ;; All predicates work on plain Scheme data (lists/symbols/etc.) + + ;; Is this a symbol (identifier)? + (define (stx-identifier? stx) + (symbol? stx)) + + ;; Is this a literal (number, string, boolean, char)? + (define (stx-literal? stx) + (or (number? stx) + (string? stx) + (boolean? stx) + (char? stx))) + + ;; Is this a proper list? + (define (stx-list? stx) + (and (list? stx) (not (null? stx)))) + + ;; Is this a pair (but may be improper)? + (define (stx-pair? stx) + (pair? stx)) + + ;; Is this null / empty list? + (define (stx-null? stx) + (null? stx)) + + ;; Is this an application (non-empty list, not a special form)? + (define (stx-application? stx) + (and (pair? stx) + (not (memq (car stx) '(quote lambda if let let* letrec letrec* + define begin and or cond case do + syntax-rules define-syntax let-syntax + letrec-syntax))))) + + (define (stx-lambda? stx) + (and (pair? stx) (eq? (car stx) 'lambda))) + + (define (stx-if? stx) + (and (pair? stx) (eq? (car stx) 'if) + (>= (length stx) 3))) + + (define (stx-let? stx) + (and (pair? stx) (eq? (car stx) 'let) + (pair? (cdr stx)) + ;; named let has symbol after 'let; skip that case for basic stx-let? + (list? (cadr stx)))) + + (define (stx-define? stx) + (and (pair? stx) (eq? (car stx) 'define) + (>= (length stx) 2))) + + (define (stx-begin? stx) + (and (pair? stx) (eq? (car stx) 'begin))) + + (define (stx-quote? stx) + (and (pair? stx) (eq? (car stx) 'quote) + (= (length stx) 2))) + + ;; ========== Destructuring Accessors ========== + + (define (stx-app-fn stx) + (car stx)) + + (define (stx-app-args stx) + (cdr stx)) + + (define (stx-lambda-formals stx) + (cadr stx)) + + (define (stx-lambda-body stx) + (cddr stx)) + + (define (stx-if-test stx) + (cadr stx)) + + (define (stx-if-then stx) + (caddr stx)) + + (define (stx-if-else stx) + (if (= (length stx) 4) + (cadddr stx) + #f)) + + (define (stx-let-bindings stx) + (cadr stx)) + + (define (stx-let-body stx) + (cddr stx)) + + ;; (define name val) -> name; (define (name args...) body...) -> name + (define (stx-define-name stx) + (let ([second (cadr stx)]) + (if (pair? second) + (car second) ;; (define (name args) body) form + second))) ;; (define name val) form + + ;; (define name val) -> val; (define (name args) body) -> (lambda (args) body...) + (define (stx-define-value stx) + (let ([second (cadr stx)]) + (if (pair? second) + ;; Function shorthand form + (cons 'lambda (cons (cdr second) (cddr stx))) + ;; Simple form + (if (= (length stx) 3) + (caddr stx) + #f)))) + + (define (stx-begin-exprs stx) + (cdr stx)) + + (define (stx-identifier-symbol stx) + (if (symbol? stx) + stx + (error 'stx-identifier-symbol "not an identifier" stx))) + + ;; ========== Pattern Matching Core ========== + ;; + ;; Pattern language: + ;; _ — wildcard (matches anything) + ;; (quote datum) — matches exactly datum (via equal?) + ;; (? pred) — matches if (pred stx) is true + ;; (? pred var) — matches and binds to var + ;; (list pat ...) — matches a proper list with matching elements + ;; (pair pat1 pat2) — matches a pair (car/cdr) + ;; (app fn-pat arg-pat ...) — like (list ...) but for applications + ;; sym — binds stx to sym in env (variable pattern) + ;; + ;; Returns: either an alist of bindings, or #f on failure. + + (define (match-pattern pat stx) + ;; Returns #f on failure, or an alist of (sym . val) bindings + (cond + ;; Wildcard + [(and (symbol? pat) (eq? pat '_)) + '()] + ;; Variable binding (symbol not starting with special prefixes) + [(symbol? pat) + (list (cons pat stx))] + ;; Quoted literal + [(and (pair? pat) (eq? (car pat) 'quote)) + (if (equal? stx (cadr pat)) + '() + #f)] + ;; Predicate pattern (? pred) or (? pred var) + ;; pred may be a procedure or a symbol to look up in (chezscheme) + [(and (pair? pat) (eq? (car pat) '?)) + (let* ([raw-pred (cadr pat)] + [pred (if (procedure? raw-pred) + raw-pred + (eval raw-pred (environment '(chezscheme))))] + [maybe-var (if (= (length pat) 3) (caddr pat) #f)]) + (if (pred stx) + (if maybe-var (list (cons maybe-var stx)) '()) + #f))] + ;; List pattern: (list pat ...) + [(and (pair? pat) (eq? (car pat) 'list)) + (let ([pats (cdr pat)]) + (if (and (list? stx) (= (length stx) (length pats))) + (match-list pats stx) + #f))] + ;; Pair pattern: (pair pat1 pat2) + [(and (pair? pat) (eq? (car pat) 'pair)) + (if (pair? stx) + (let ([b1 (match-pattern (cadr pat) (car stx))]) + (if b1 + (let ([b2 (match-pattern (caddr pat) (cdr stx))]) + (if b2 (append b1 b2) #f)) + #f)) + #f)] + ;; Application pattern: (app fn-pat arg-pat ...) + [(and (pair? pat) (eq? (car pat) 'app)) + (let ([pats (cdr pat)]) + (if (and (list? stx) (= (length stx) (length pats))) + (match-list pats stx) + #f))] + ;; Fallback: pair patterns treated as list patterns for convenience + [(pair? pat) + (if (and (pair? stx) (= (length stx) (length pat))) + (match-list pat stx) + #f)] + ;; Literal numbers/strings/booleans in pattern position + [(or (number? pat) (string? pat) (boolean? pat) (char? pat)) + (if (equal? pat stx) '() #f)] + [else #f])) + + (define (match-list pats stxs) + ;; Match each pattern against corresponding stx; accumulate bindings + (let loop ([ps pats] [ss stxs] [bindings '()]) + (cond + [(and (null? ps) (null? ss)) bindings] + [(or (null? ps) (null? ss)) #f] + [else + (let ([b (match-pattern (car ps) (car ss))]) + (if b + (loop (cdr ps) (cdr ss) (append bindings b)) + #f))]))) + + ;; Apply bindings to a template expression + (define (instantiate-template template bindings) + (cond + [(symbol? template) + (let ([b (assq template bindings)]) + (if b (cdr b) template))] + [(not (pair? template)) template] + [else + (map (lambda (t) (instantiate-template t bindings)) template)])) + + ;; (syntax-match stx clause ...) -> result of first matching clause, or #f + ;; Each clause: (pattern result-expr) or (pattern => proc) + ;; Pattern variables are bound in result-expr. + (define-syntax syntax-match + (lambda (stx) + ;; Local helper: extract pattern variable names from a datum pattern. + ;; Defined inside the transformer to be available at expand time. + (define (extract-vars pat) + (cond + [(and (symbol? pat) (not (eq? pat '_))) (list pat)] + [(not (pair? pat)) '()] + [(eq? (car pat) 'quote) '()] + [(eq? (car pat) '?) + (if (= (length pat) 3) (list (caddr pat)) '())] + [(memq (car pat) '(list pair app)) + (apply append (map extract-vars (cdr pat)))] + [else + (apply append (map extract-vars pat))])) + (syntax-case stx (=>) + [(_ expr) + #'#f] + [(_ expr (pat => proc) rest ...) + #'(let ([__sm-stx expr]) + (let ([__sm-b (match-pattern 'pat __sm-stx)]) + (if __sm-b + (proc __sm-b) + (syntax-match __sm-stx rest ...))))] + [(_ expr (pat body ...) rest ...) + (let* ([pat-datum (syntax->datum #'pat)]