ref: be919211e93d5ca646050aa14aae987f4fb8d62e
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))))))))))