ref: 205e4194e533d0e8687b81ea2d2a2b1f25c7aa35
dir: /tests/example-common.zuo/
#lang zuo/datum ;; This is an early version of the macro expander, preserved here ;; as a large-ish example that's useful to check how long expansion takes. (let* ([caar (lambda (p) (car (car p)))] [cadr (lambda (p) (car (cdr p)))] [cdar (lambda (p) (cdr (car p)))] [cddr (lambda (p) (cdr (cdr p)))] [map (lambda (f vs) (letrec ([map (lambda (vs) (if (null? vs) '() (cons (f (car vs)) (map (cdr vs)))))]) (map vs)))] [map2 (lambda (f vs v2s) (letrec ([map (lambda (vs v2s) (if (null? vs) '() (cons (f (car vs) (car v2s)) (map (cdr vs) (cdr v2s)))))]) (map vs v2s)))] [foldl (lambda (f init vs) (letrec ([fold (lambda (vs accum) (if (null? vs) accum (fold (cdr vs) (f (car vs) accum))))]) (fold vs init)))] [ormap (lambda (f vs) (letrec ([ormap (lambda (vs) (if (null? vs) #f (or (f (car vs)) (ormap (cdr vs)))))]) (ormap vs)))] [make-scope (lambda (name) (string->uninterned-symbol name))] [set-add (lambda (ht v) (hash-set ht v #t))] [set-remove hash-remove] [set-flip (lambda (ht v) (let ([ht2 (hash-remove ht v)]) (if (eq? ht ht2) (hash-set ht v #t) ht2)))] [scope-set=? (lambda (sc1 sc2) (and (hash-keys-subset? sc1 sc2) (hash-keys-subset? sc2 sc1)))] [empty-prop (hash)] [prop-add (lambda (prop s) (hash-set prop s 'add))] [prop-remove (lambda (prop s) (hash-set prop s 'remove))] [prop-flip (lambda (prop s) (let ([v (hash-ref prop s #f)]) (cond [(not v) (hash-set prop s 'flip)] [(eq? v 'flip) (hash-remove prop s)] [(eq? v 'add) (hash-set prop s 'remove)] [else (hash-set prop s 'add)])))] [syntax-tag (string->uninterned-symbol "syntax")] [identifier (lambda (id scopes) (opaque syntax-tag (cons id scopes)))] [lazy-prop-pair (lambda (vec) (opaque syntax-tag vec))] [syntax? (lambda (v) (and (opaque-ref syntax-tag v #f) #t))] [identifier? (lambda (v) (symbol? (car (opaque-ref syntax-tag v '(#f . #f)))))] [lazy-prop-pair? (lambda (v) (pair? (car (opaque-ref syntax-tag v '(#f . #f)))))] [identifier-e (lambda (v) (car (opaque-ref syntax-tag v #f)))] [identifier-scopes (lambda (v) (cdr (opaque-ref syntax-tag v #f)))] [syntax-raw-content (lambda (v) (opaque-ref syntax-tag v #f))] ; returns # for non-syntaz [datum->syntax (letrec ([datum->syntax (lambda (ctx v) (cond [(syntax? v) v] [(symbol? v) (identifier v (identifier-scopes ctx))] [(pair? v) (cons (datum->syntax ctx (car v)) (datum->syntax ctx (cdr v)))] [else v]))]) datum->syntax)] [syntax->datum (letrec ([syntax->datum (lambda (s) (cond [(identifier? s) (identifier-e s)] [(lazy-prop-pair? s) (syntax->datum (car (syntax-raw-content s)))] [(pair? s) (cons (syntax->datum (car s)) (syntax->datum (cdr s)))] [else s]))]) syntax->datum)] [adjust-scope (lambda (s scope op prop-op) (cond [(pair? s) (lazy-prop-pair (cons s (prop-op empty-prop scope)))] [else (let* ([c (syntax-raw-content s)]) (if c (let ([a (car c)]) (if (symbol? a) (identifier a (op (cdr c) scope)) (lazy-prop-pair (cons (car c) (prop-op (cdr c) scope))))) s))]))] [add-scope (lambda (s scope) (adjust-scope s scope set-add prop-add))] [remove-scope (lambda (s scope) (adjust-scope s scope set-remove prop-remove))] [flip-scope (lambda (s scope) (adjust-scope s scope set-flip prop-flip))] [apply-prop (lambda (prop s) (cond [(= 0 (hash-count prop)) s] [else (let* ([c (syntax-raw-content s)]) (cond [(and c (pair? (car c)) (= 0 (hash-count prop))) (lazy-prop-pair (cons (car c) prop))] [(pair? s) (lazy-prop-pair (cons s prop))] [else (foldl (lambda (scope s) (let ([op (hash-ref prop scope #f)]) (cond [(eq? op 'add) (add-scope s scope)] [(eq? op 'remove) (remove-scope s scope)] [else (flip-scope s scope)]))) s (hash-keys prop))]))]))] [syntax-e (lambda (s) (let ([c (syntax-raw-content s)]) (if c (let ([a (car c)]) (if (symbol? a) a (let ([prop (cdr c)]) (cons (apply-prop prop (car a)) (apply-prop prop (cdr a)))))) s)))] [stx-pair? (lambda (p) (or (pair? p) (lazy-prop-pair? p)))] [stx-car (lambda (p) (if (pair? p) (car p) (let ([c (syntax-raw-content p)]) (if (and c (pair? (car c))) (apply-prop (cdr c) (car (car c))) (error "stx-car: not a syntax pair" p)))))] [stx-cdr (lambda (p) (if (pair? p) (cdr p) (let ([c (syntax-raw-content p)]) (if (and c (pair? (car c))) (apply-prop (cdr c) (cdr (car c))) (error "stx-cdr: not a syntax pair" p)))))] [stx-list? (letrec ([stx-list? (lambda (p) (cond [(null? p) #t] [(pair? p) (stx-list? (cdr p))] [else (let ([c (syntax-raw-content p)]) (and c (let ([pr (car c)]) (and (pair? pr) (stx-list? (cdr pr))))))]))]) stx-list?)] [stx->list (letrec ([stx->list (lambda (p) (cond [(null? p) '()] [(pair? p) (let ([r (stx->list (cdr p))]) (and r (cons (car p) r)))] [else (let ([c (syntax-raw-content p)]) (and c (let* ([a (car c)]) (and (pair? a) (let* ([prop (cdr c)] [r (stx->list (apply-prop prop (cdr a)))]) (and r (cons (apply-prop prop (car a)) r)))))))]))]) stx->list)] [stx-length (letrec ([stx-length (lambda (p) (cond [(null? p) 0] [(pair? p) (+ 1 (stx-length (cdr p)))] [else (let ([c (syntax-raw-content p)]) (if c (let ([a (car c)]) (if (pair? a) (+ 1 (stx-length (cdr a))) 0)) 0))]))]) stx-length)] [stx-caar (lambda (p) (stx-car (stx-car p)))] [stx-cadr (lambda (p) (stx-car (stx-cdr p)))] [stx-cdar (lambda (p) (stx-cdr (stx-car p)))] [stx-cddr (lambda (p) (stx-cdr (stx-cdr p)))] [add-binding* (lambda (binds id binding) (let* ([sym (identifier-e id)] [sc (identifier-scopes id)] [sym-binds (hash-ref binds sym (hash))] [k-scope (car (hash-keys sc))] ; relying on deterministic order [sc+bs (hash-ref sym-binds k-scope '())] [sym-binds (hash-set sym-binds k-scope (cons (cons sc binding) sc+bs))]) (hash-set binds sym sym-binds)))] [find-all-matching-bindings (lambda (binds id) (let* ([sym (identifier-e id)] [id-sc (identifier-scopes id)] [sym-binds (hash-ref binds sym #f)]) (if (not sym-binds) '() (foldl (lambda (scope lst) (foldl (lambda (sc+b lst) (let* ([sc (car sc+b)]) (if (hash-keys-subset? sc id-sc) (cons sc+b lst) lst))) lst (hash-ref sym-binds scope '()))) '() (hash-keys sym-binds)))))] [check-unambiguous (lambda (id max-sc+b candidate-sc+bs) (map (lambda (sc+b) (unless (hash-keys-subset? (car sc+b) (car max-sc+b)) (error "ambiguous" (identifier-e id)))) candidate-sc+bs))] [resolve* (lambda (binds id) (let* ([candidate-sc+bs (find-all-matching-bindings binds id)]) (cond [(pair? candidate-sc+bs) (let* ([max-sc+binding (foldl (lambda (sc+b max-sc+b) (if (> (hash-count (car max-sc+b)) (hash-count (car sc+b))) max-sc+b sc+b)) (car candidate-sc+bs) (cdr candidate-sc+bs))]) (check-unambiguous id max-sc+binding candidate-sc+bs) (cdr max-sc+binding))] [else #f])))] [make-state (lambda (binds nominals) (cons binds (cons (hash) nominals)))] [state-binds car] [state-merged cadr] [state-nominals cddr] [state-set-binds (lambda (state binds) (cons binds (cdr state)))] [state-set-merged (lambda (state merged) (cons (car state) (cons merged (cddr state))))] [state-set-nominals (lambda (state nominals) (cons (car state) (cons (cadr state) nominals)))] [merge-binds (lambda (state key m-binds) (let* ([merged (state-merged state)]) (cond [(hash-ref merged key #f) ;; already merged state] [else (let* ([merged (hash-set merged key #t)] [binds (state-binds state)] [new-binds ;; merge bindings from `m-binds` to `binds`: (foldl (lambda (sym binds) (let* ([sym-ht (hash-ref binds sym (hash))] [m-sym-ht (hash-ref m-binds sym #f)] [new-sym-ht (foldl (lambda (s sym-ht) (hash-set sym-ht s (append (hash-ref m-sym-ht s '()) (hash-ref sym-ht s '())))) sym-ht (hash-keys m-sym-ht))]) (hash-set binds sym new-sym-ht))) binds (hash-keys m-binds))]) (state-set-binds (state-set-merged state merged) new-binds))])))] [mod-path=? (lambda (a b) (if (or (symbol? a) (symbol? b)) (eq? a b) (string=? a b)))] [call-with-nominal (lambda (state mod-path default-ids k) (let* ([mod-path (if (identifier? mod-path) (identifier-e mod-path) mod-path)] [fronted (letrec ([assoc-to-front (lambda (l) (cond [(null? l) (list (cons mod-path default-ids))] [(mod-path=? mod-path (caar l)) l] [else (let ([new-l (assoc-to-front (cdr l))]) (cons (car new-l) (cons (car l) (cdr new-l))))]))]) (assoc-to-front (state-nominals state)))]) (k (cdar fronted) (lambda (new-sym+bs) (let* ([new-noms (cons (cons (caar fronted) new-sym+bs) (cdr fronted))]) (state-set-nominals state new-noms))))))] [record-nominal (lambda (state mod-path sym bind) (call-with-nominal state mod-path '() (lambda (sym+binds install) (install (cons (cons sym bind) sym+binds)))))] [lookup-nominal (lambda (state mod-path) (call-with-nominal state mod-path #f (lambda (sym+binds install) sym+binds)))] [initial-nominals (lambda (binds mod-path) ;; in case `all-from-out` is used on the initial import, ;; add all the current ids in `binds` as nominally imported (let* ([sym+bs (foldl (lambda (sym sym+bs) (let* ([sym-ht (hash-ref binds sym #f)]) (foldl (lambda (scope sym+bs) (let ([sc+bs (hash-ref sym-ht scope #f)]) (foldl (lambda (sc+b sym+bs) (cons (cons sym (cdr sc+b)) sym+bs)) sym+bs sc+bs))) sym+bs (hash-keys sym-ht)))) '() (hash-keys binds))]) (list (cons mod-path sym+bs))))] [bound-identifier=? (lambda (id1 id2) (unless (identifier? id1) (error "bound-identifier?: not an identifier" id1)) (unless (identifier? id2) (error "bound-identifier?: not an identifier" id2)) (and (eq? (identifier-e id1) (identifier-e id2)) (scope-set=? (identifier-scopes id1) (identifier-scopes id2))))] [id-sym-eq? (lambda (id sym) (and (identifier? id) (eq? (identifier-e id) sym)))] ;; simple transparent structs [make-maker (lambda (tag) (lambda (v) (cons tag v)))] [make-? (lambda (tag) (lambda (v) (and (pair? v) (eq? tag (car v)))))] [make-?? (lambda (tag1 tag2) (lambda (v) (and (pair? v) (or (eq? tag1 (car v)) (eq? tag2 (car v))))))] [any-ref cdr] ; not bothering to check a tag [make-core-form (make-maker 'core-form)] [core-form? (make-? 'core-form)] [form-id any-ref] [make-local (make-maker 'local)] [local? (make-? 'local)] [local-id any-ref] [make-defined (make-maker 'defined)] [defined? (make-? 'defined)] [make-local-variable (make-maker 'local-variable)] [variable? (make-?? 'local-variable 'defined)] [variable-var any-ref] [make-macro (make-maker 'macro)] [macro-proc+key+ctx+binds any-ref] [make-defined-macro (make-maker 'defined-macro)] [defined-macro? (make-? 'defined-macro)] [defined-macro-proc any-ref] [macro? (make-?? 'macro 'defined-macro)] [make-literal (make-maker 'literal)] [literal? (make-? 'literal)] [literal-val any-ref] [make-initial-import (make-maker 'initial)] [initial-import? (make-? 'initial)] [initial-import-bind any-ref] [make-specific (make-maker 'specific)] [specific? (make-? 'specific)] [specific-label (lambda (s) (cdr (any-ref s)))] [unwrap-specific (lambda (v) (if (specific? v) (car (any-ref v)) v))] [as-specific (lambda (v) (make-specific (cons v (string->uninterned-symbol "u"))))] [specific=? (lambda (a b) (if (specific? a) (if (specific? b) (eq? (specific-label a) (specific-label b)) #f) (eq? a b)))] [add-binding (lambda (state id binding) (state-set-binds state (add-binding* (state-binds state) id binding)))] [resolve (lambda (state id) (let* ([bind (resolve* (state-binds state) id)] [bind (unwrap-specific bind)]) (if (initial-import? bind) (initial-import-bind bind) bind)))] [free-id=? (lambda (state id1 id2) (let* ([bind1 (resolve* (state-binds state) id1)] [bind2 (resolve* (state-binds state) id2)]) (or (specific=? bind1 bind2) (and (not bind1) (not bind2) (eq? (identifier-e id1) (identifier-e id2))))))] [core-sc (hash 'core #t)] [make-core-initial-bind (lambda (bind) (hash 'core (list (cons core-sc (as-specific (make-initial-import bind))))))] [kernel-binds (let* ([ht (kernel-env)]) (foldl (lambda (sym binds) (cond [(or (eq? sym 'eval) (eq? sym 'dynamic-require)) ;; skip things related to the `zuo/kernel` evaluator binds] [else (hash-set binds sym (make-core-initial-bind (hash-ref ht sym #f)))])) (hash) (hash-keys ht)))] [top-form-binds (foldl (lambda (sym binds) (hash-set binds sym (make-core-initial-bind (make-core-form sym)))) kernel-binds '(lambda let letrec quote if begin define define-syntax require provide quote-syntax))] [top-binds (let* ([binds top-form-binds] [add (lambda (binds name val) (hash-set binds name (make-core-initial-bind val)))] [binds (add binds 'identifier? identifier?)] [binds (add binds 'stx-pair? stx-pair?)] [binds (add binds 'stx-car stx-car)] [binds (add binds 'stx-cdr stx-cdr)] [binds (add binds 'stx-list? stx-list?)] [binds (add binds 'stx->list stx->list)] [binds (add binds 'stx-length stx-length)] [binds (add binds 'syntax-e syntax-e)] [binds (add binds 'syntax->datum syntax->datum)] [binds (add binds 'datum->syntax datum->syntax)] [binds (add binds 'bound-identifier=? bound-identifier=?)]) binds)] [export-bind (lambda (bind mod-scope ctx binds) ;; convert a local binding into one suitable to import (let* ([label (and (specific? bind) (specific-label bind))] [bind (unwrap-specific bind)] [bind (if (initial-import? bind) (initial-import-bind bind) bind)] [bind (cond [(defined? bind) (make-local-variable (variable-var bind))] [(defined-macro? bind) (make-macro (list (defined-macro-proc bind) mod-scope ctx binds))] [else bind])]) (if label (make-specific (cons bind label)) bind)))] [initial-import-bind (lambda (bind) (let* ([label (and (specific? bind) (specific-label bind))] [bind (unwrap-specific bind)] [bind (make-initial-import bind)]) (if label (make-specific (cons bind label)) bind)))] [gensym (lambda (sym) (string->uninterned-symbol (symbol->string sym)))] [maybe-begin (lambda (d) (if (null? (stx-cdr d)) (stx-car d) (cons (identifier 'begin core-sc) d)))] [name-lambda (lambda (form id) (if (and (pair? form) (eq? (car form) 'lambda)) ;; `zuo/kernel` recognizes this pattern to name the form `(lambda ,(cadr form) ,(symbol->string (identifier-e id)) ,(cadr (cdr form))) form))] [syntax-error (lambda (msg s) (error (~a msg ": " (~s (syntax->datum s)))))] [bad-syntax (lambda (s) (syntax-error "bad syntax" s))] [duplicate-identifier (lambda (id s) (error "duplicate identifier:" (identifier-e id) (syntax->datum s)))] [procedure-arity-mask (lambda (p) -1)] [apply-macro (lambda (m s ctx state k) (let* ([apply-macro (lambda (proc ctx state) (let* ([new-scope (make-scope "macro")] [s (add-scope s new-scope)] [s (if (= 4 (bitwise-and (procedure-arity-mask proc) 4)) (proc s (lambda (a b) (free-id=? state a b))) (proc s))] [s (datum->syntax ctx s)] [s (flip-scope s new-scope)]) (k s state)))]) (cond [(defined-macro? m) (apply-macro (defined-macro-proc m) ctx state)] [else (let* ([proc+key+ctx+binds (macro-proc+key+ctx+binds m)] [proc (car proc+key+ctx+binds)] [key (cadr proc+key+ctx+binds)] [ctx (cadr (cdr proc+key+ctx+binds))] [m-binds (cadr (cddr proc+key+ctx+binds))]) (apply-macro proc ctx (merge-binds state key m-binds)))])))] [expand-define (lambda (s state k) (unless (and (stx-list? s) (= 3 (stx-length s)) (identifier? (stx-cadr s))) (bad-syntax s)) (let* ([id (stx-cadr s)] [id-bind (resolve state id)]) (when (or (defined? id-bind) (defined-macro? id-bind)) (syntax-error "duplicate definition" id)) (let* ([sym (identifier-e id)] [def-id (gensym sym)] [var (variable sym)] [new-state (add-binding state id (as-specific (make-defined var)))] [new-s `(,variable-set! ,var (,name-lambda ,(stx-cadr (stx-cdr s)) ,id))]) (k new-s new-state))))] [expand-define-syntax (lambda (s state parse) (unless (and (stx-list? s) (= 3 (stx-length s)) (identifier? (stx-cadr s))) (bad-syntax s)) (let* ([id (stx-cadr s)] [id-bind (resolve state id)]) (when (or (defined? id-bind) (defined-macro? id-bind)) (syntax-error "duplicate definition" id)) (let* ([e (parse (stx-cadr (stx-cdr s)) state)] [proc ('eval (name-lambda e id))]) (add-binding state id (as-specific (make-defined-macro proc))))))] [expand-provide (lambda (s state provides mod-path) (unless (stx-list? s) (bad-syntax s)) (foldl (lambda (p provides) (let* ([add-provide (lambda (provides id as-sym) (let* ([old-id (hash-ref provides as-sym #f)]) (when (and old-id (not (free-id=? state old-id id))) (syntax-error "already provided as different binding" as-sym)) (hash-set provides as-sym id)))] [bad-provide-form (lambda () (syntax-error "bad provide clause" p))]) (cond [(identifier? p) (add-provide provides p (identifier-e p))] [(stx-pair? p) (unless (stx-list? p) (bad-provide-form)) (let ([form (stx-car p)]) (cond [(id-sym-eq? form 'rename-out) (foldl (lambda (rn provides) (unless (and (stx-list? rn) (= 2 (stx-length rn)) (identifier? (stx-car rn)) (identifier? (stx-cadr rn))) (bad-provide-form)) (add-provide provides (stx-car rn) (identifier-e (stx-cadr rn)))) provides (stx->list (stx-cdr p)))] [(id-sym-eq? form 'all-from-out) (foldl (lambda (req-path provides) (let* ([prov-sc (identifier-scopes (stx-car s))] [sym+binds (lookup-nominal state req-path)]) (unless sym+binds (syntax-error "module not required" req-path)) (foldl (lambda (sym+bind provides) (let* ([sym (car sym+bind)] [id (identifier sym prov-sc)] [bind (resolve* (state-binds state) id)]) (cond [(not (specific=? bind (cdr sym+bind))) ;; shadowed by definition or other import provides] [else (add-provide provides id sym)]))) provides sym+binds))) provides (stx->list (stx-cdr p)))] [else (bad-provide-form)]))] [else (bad-provide-form)]))) provides (stx->list (stx-cdr s))))] [expand-require (lambda (s state mod-path) (let* ([check-renames ;; syntax check on renaming clauses `ns` (lambda (r ns id-ok?) (map (lambda (n) (unless (or (and id-ok? (identifier? n)) (and (stx-list? n) (= 2 (stx-length n)) (identifier? (stx-car n)) (identifier? (stx-cadr n)))) (bad-syntax r))) (stx->list ns)))] [make-rename-filter ;; used to apply `ns` renaming clauses to an imported identifier (lambda (ns only?) (lambda (sym) (letrec ([loop (lambda (ns) (cond [(null? ns) (if only? #f sym)] [(id-sym-eq? (stx-car ns) sym) sym] [(and (stx-pair? (stx-car ns)) (id-sym-eq? (stx-caar ns) sym)) (syntax-e (stx-cadr (stx-car ns)))] [else (loop (stx-cdr ns))]))]) (loop ns))))] [make-provides-checker ;; used to check whether set of provided is consistent with `ns` (lambda (ns) (lambda (provides) (map (lambda (n) (let ([id (if (pair? n) (car n) n)]) (unless (hash-ref provides (identifier-e id) #f) (syntax-error "identifier is not in required set" id)))) (stx->list ns))))]) ;; parse each `require` clause `r: (foldl (lambda (r state) (let* ([req-sc (identifier-scopes (stx-car s))] [req-path+filter+check (cond [(string? r) (list r (lambda (sym) sym) void)] [(identifier? r) (list (identifier-e r) (lambda (sym) sym) void)] [(stx-pair? r) (unless (and (stx-list? r) (stx-pair? (stx-cdr r))) (bad-syntax r)) (let* ([ns (stx-cddr r)]) (cond [(id-sym-eq? (stx-car r) 'only-in) (check-renames r ns #t) (list (stx-cadr r) (make-rename-filter ns #t) (make-provides-checker ns))] [(id-sym-eq? (stx-car r) 'rename-in) (check-renames r ns #f) (list (stx-cadr r) (make-rename-filter ns #f) (make-provides-checker ns))] [else (bad-syntax r)]))] [else (bad-syntax r)])] [req-path (car req-path+filter+check)] [filter (cadr req-path+filter+check)] [check (cadr (cdr req-path+filter+check))] [in-mod-path (if (string? req-path) (module-path-join req-path (car (split-path mod-path))) (syntax->datum req-path))] [mod ('dynamic-require in-mod-path)] [provides (hash-ref mod 'macromod-provides #f)]) (unless provides (syntax-error "not a compatible module" r)) (check provides) ;; add each provided binding (except as filtered) (foldl (lambda (sym state) (let* ([as-sym (filter sym)]) (cond [(not as-sym) state] [else ;; check whether it's bound already (let* ([as-id (identifier as-sym req-sc)] [current-bind (resolve* (state-binds state) as-id)] [req-bind (hash-ref provides sym #f)] [add-binding/record-nominal (lambda () (let* ([state (add-binding state as-id req-bind)]) (record-nominal state req-path as-sym req-bind)))]) (cond [(not current-bind) ;; not already bound, so import is ok (add-binding/record-nominal)] [(initial-import? (unwrap-specific current-bind)) ;; `require` can shadow an initial import (add-binding/record-nominal)] [(specific=? current-bind req-bind) ;; re-import of same variable or primitive, also ok state] [(or (defined? current-bind) (defined-macro? current-bind)) ;; definition shadows import state] [else (syntax-error "identifier is already imported" as-id)]))]))) state (hash-keys provides)))) state (stx->list (stx-cdr s)))))] [expand-top-sequence ;; expand top-level forms and gather imports and definitions (lambda (es state mod-path ctx parse) (letrec ([expand-top (lambda (es accum state provides) (cond [(null? es) (list (reverse accum) state provides)] [else (let* ([s (stx-car es)]) (cond [(stx-pair? s) (let* ([rator (stx-car s)] [bind (and (identifier? rator) (resolve state rator))]) (cond [(macro? bind) (apply-macro bind s ctx state (lambda (new-s new-state) (expand-top (cons new-s (cdr es)) accum new-state provides)))] [(core-form? bind) (let ([bind (form-id bind)]) (cond [(eq? bind 'begin) (unless (stx-list? s) (bad-syntax s)) (expand-top (append (stx->list (stx-cdr s)) (cdr es)) accum state provides)] [(eq? bind 'define) (expand-define s state (lambda (new-s new-state) (expand-top (cdr es) (cons new-s accum) new-state provides)))] [(eq? bind 'define-syntax) (let ([new-state (expand-define-syntax s state parse)]) (expand-top (cdr es) accum new-state provides))] [(eq? bind 'provide) (let ([new-provides (expand-provide s state provides mod-path)]) (expand-top (cdr es) accum state new-provides))] [(eq? bind 'require) (let ([new-state (expand-require s state mod-path)]) (expand-top (cdr es) accum new-state provides))] [else (expand-top (cdr es) (cons s accum) state provides)]))] [else (expand-top (cdr es) (cons s accum) state provides)]))] [else (expand-top (cdr es) (cons s accum) state provides)]))]))]) (expand-top es '() state (hash))))] [parse-lambda (lambda (s state parse) (unless (>= (stx-length s) 3) (bad-syntax s)) (let* ([formals (stx-cadr s)] [new-formals (letrec ([reformal (lambda (f seen) (cond [(null? f) '()] [(identifier? f) (when (ormap (lambda (sn) (bound-identifier=? f sn)) seen) (duplicate-identifier f s)) (gensym (syntax-e f))] [(stx-pair? f) (let* ([a (stx-car f)]) (unless (identifier? a) (bad-syntax s)) (cons (reformal a seen) (reformal (stx-cdr f) (cons a seen))))] [else (bad-syntax s)]))]) (reformal formals '()))] [new-scope (make-scope "lambda")] [state (letrec ([add-formals (lambda (state formals new-formals) (cond [(identifier? formals) (let* ([id (add-scope formals new-scope)]) (add-binding state id (make-local new-formals)))] [(pair? new-formals) (add-formals (add-formals state (stx-cdr formals) (cdr new-formals)) (stx-car formals) (car new-formals))] [else state]))]) (add-formals state formals new-formals))]) `(lambda ,new-formals ,(parse (maybe-begin (add-scope (stx-cddr s) new-scope)) state))))] [nest-bindings (lambda (new-cls body) (letrec ([nest-bindings (lambda (new-cls) (if (null? new-cls) body `(let (,(car new-cls)) ,(nest-bindings (cdr new-cls)))))]) (nest-bindings (reverse new-cls))))] [parse-let (lambda (s state parse) (unless (>= (stx-length s) 3) (bad-syntax s)) (let* ([cls (stx-cadr s)] [orig-state state] [new-scope (make-scope "let")]) (unless (stx-list? cls) (bad-syntax s)) (letrec ([parse-clauses (lambda (cls new-cls state seen) (cond [(null? cls) (nest-bindings (reverse new-cls) (parse (maybe-begin (add-scope (stx-cddr s) new-scope)) state))] [else (let* ([cl (stx-car cls)]) (unless (and (stx-list? cl) (= 2 (stx-length cl))) (bad-syntax s)) (let* ([id (stx-car cl)]) (unless (identifier? id) (bad-syntax s)) (when (ormap (lambda (sn) (bound-identifier=? id sn)) seen) (duplicate-identifier id s)) (let* ([new-id (gensym (identifier-e id))]) (parse-clauses (stx-cdr cls) (cons (list new-id (name-lambda (parse (stx-cadr cl) orig-state) id)) new-cls) (add-binding state (add-scope id new-scope) (make-local new-id)) (cons id seen)))))]))]) (parse-clauses cls '() state '()))))] [parse-letrec (lambda (s state parse) (unless (>= (stx-length s) 3) (bad-syntax s)) (let* ([cls (stx-cadr s)] [orig-state state] [new-scope (make-scope "letrec")]) (unless (stx-list? cls) (bad-syntax s)) ;; use mutable variables to tie knots (letrec ([bind-all (lambda (x-cls new-ids state seen) (cond [(null? x-cls) (nest-bindings (map (lambda (new-id) `[,new-id (,variable ',new-id)]) new-ids) `(begin (begin . ,(map2 (lambda (cl new-id) `(,variable-set! ,(car new-ids) ,(name-lambda (let ([rhs (stx-cadr (stx-car cls))]) (parse (add-scope rhs new-scope) state)) (stx-caar cls)))) (stx->list cls) (reverse new-ids))) ,(parse (maybe-begin (add-scope (stx-cddr s) new-scope)) state)))] [else (let* ([cl (stx-car x-cls)]) (unless (and (stx-list? cl) (= 2 (stx-length cl))) (bad-syntax s)) (let* ([id (stx-car cl)]) (unless (identifier? id) (bad-syntax s)) (when (ormap (lambda (sn) (bound-identifier=? id sn)) seen) (duplicate-identifier id s)) (let ([new-id (gensym (identifier-e id))]) (bind-all (stx-cdr x-cls) (cons new-id new-ids) (add-binding state (add-scope id new-scope) (make-local-variable new-id)) (cons id seen)))))]))]) (bind-all cls '() state '()))))] [make-parse (lambda (ctx) (letrec ([parse (lambda (s state) (cond [(stx-pair? s) (let* ([rator (stx-car s)] [bind (and (identifier? rator) (resolve state rator))]) (cond [(macro? bind) (apply-macro bind s ctx state (lambda (new-s new-state) (parse new-s new-state)))] [(core-form? bind) (unless (stx-list? s) (bad-syntax s)) (let ([bind (form-id bind)]) (cond [(eq? bind 'lambda) (parse-lambda s state parse)] [(eq? bind 'let) (parse-let s state parse)] [(eq? bind 'letrec) (parse-letrec s state parse)] [(eq? bind 'quote) (unless (= 2 (stx-length s)) (bad-syntax s)) `(quote ,(syntax->datum (stx-cadr s)))] [(eq? bind 'quote-syntax) (unless (= 2 (stx-length s)) (bad-syntax s)) `(quote ,(stx-cadr s))] [(eq? bind 'if) (unless (= 4 (stx-length s)) (bad-syntax s)) `(if ,(parse (stx-cadr s) state) ,(parse (stx-cadr (stx-cdr s)) state) ,(parse (stx-cadr (stx-cddr s)) state))] [(eq? bind 'begin) (unless (stx-pair? (stx-cdr s)) (bad-syntax s)) (let ([es (map (lambda (e) (parse e state)) (stx->list (stx-cdr s)))]) (if (null? (cdr es)) (car es) (cons 'begin es)))] [else (map (lambda (e) (parse e state)) (stx->list s))]))] [(eq? rator name-lambda) ; form created by `define` to propagate name (name-lambda (parse (stx-cadr s) state) (stx-cadr (stx-cdr s)))] [else (map (lambda (e) (parse e state)) (stx->list s))]))] [(identifier? s) (let* ([bind (resolve state s)]) (cond [(core-form? bind) (bad-syntax s)] [(local? bind) (local-id bind)] [(variable? bind) `(,variable-ref ,(variable-var bind))] [(literal? bind) (literal-val bind)] [(macro? bind) (apply-macro bind s ctx state (lambda (new-s new-state) (parse new-s state)))] [(not bind) (syntax-error "unbound identifier" s)] [else bind]))] [(null? s) (bad-syntax s)] [else s]))]) parse))] [make-read-and-eval (lambda (make-initial-state) (lambda (str start mod-path) (let* ([es (string-read (substring str start (string-length str)))] [mod-scope (make-scope "module")] [ctx (identifier 'module (set-add core-sc mod-scope))] [es (map (lambda (e) (datum->syntax ctx e)) es)] [parse (make-parse ctx)] [initial-state (make-initial-state ctx)] [es+state+provides (expand-top-sequence es initial-state mod-path ctx parse)] [es (car es+state+provides)] [state (cadr es+state+provides)] [binds (state-binds state)] [provides (cadr (cdr es+state+provides))] [outs (foldl (lambda (as-sym outs) (let* ([id (hash-ref provides as-sym #f)] [bind (resolve* (state-binds state) id)]) (unless bind (syntax-error "provided identifier not bound" id)) (hash-set outs as-sym (export-bind bind mod-scope ctx binds)))) (hash) (hash-keys provides))] [print-result (lambda (v) (unless (eq? v (void)) (alert (~v v))))] [add-print (lambda (s) `(,print-result ,s))]) ('eval (cons 'begin (cons '(void) (map (lambda (e) (add-print (parse e state))) es)))) (hash 'macromod-provides outs))))]) (eq? 'done (hash ;; makes `#lang zuo/private/macromod work: 'read-and-eval (make-read-and-eval (lambda (ctx) (make-state top-binds (initial-nominals top-binds 'zuo/private/macromod)))) ;; makes `(require zuo/private/macromod)` work: 'macromod-provides (foldl (lambda (sym provides) (hash-set provides sym (hash-ref top-binds sym #f))) (hash) (hash-keys top-binds)) ;; for making a new `#lang` with some initial imports: 'make-read-and-eval-with-initial-imports-from (lambda (mod-path) (let* ([mod ('dynamic-require mod-path)] [provides (hash-ref mod 'macromod-provides #f)]) (unless provides (syntax-error "not a compatible module for initial imports" mod-path)) (make-read-and-eval (lambda (ctx) (let* ([binds (foldl (lambda (sym binds) (let* ([id (datum->syntax ctx sym)] [bind (initial-import-bind (hash-ref provides sym #f))]) (add-binding* binds id bind))) (hash) (hash-keys provides))]) (make-state binds (initial-nominals binds mod-path))))))))))