mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

psyntax: Avoid lambda in procedure definitions

Browse source 
* module/ice-9/psyntax.scm: Instead of e.g. (define foo (lambda (x)
  ...)), do (define (foo x) ...).  No functional change.
This commit is contained in:
Andy Wingo 2024-11-15 14:06:32 +01:00
parent 4f05d1709b
commit d30b39e4ea
1 changed files with 1522 additions and 1610 deletions
Download patch file Download diff file Expand all files Collapse all files

408
module/ice-9/psyntax.scm
View file

@ -153,25 +153,20 @@
val))
;; output constructors
(define build-void
(lambda (sourcev)
(make-void sourcev)))
(define (build-void sourcev)
(make-void sourcev))
(define build-call
(lambda (sourcev fun-exp arg-exps)
(make-call sourcev fun-exp arg-exps)))
(define (build-call sourcev fun-exp arg-exps)
(make-call sourcev fun-exp arg-exps))
(define build-conditional
(lambda (sourcev test-exp then-exp else-exp)
(make-conditional sourcev test-exp then-exp else-exp)))
(define (build-conditional sourcev test-exp then-exp else-exp)
(make-conditional sourcev test-exp then-exp else-exp))
(define build-lexical-reference
(lambda (type sourcev name var)
(make-lexical-ref sourcev name var)))
(define (build-lexical-reference type sourcev name var)
(make-lexical-ref sourcev name var))
(define build-lexical-assignment
(lambda (sourcev name var exp)
(make-lexical-set sourcev name var (maybe-name-value name exp))))
(define (build-lexical-assignment sourcev name var exp)
(make-lexical-set sourcev name var (maybe-name-value name exp)))
(define (analyze-variable mod var modref-cont bare-cont)
(if (not mod)
@ -188,44 +183,39 @@
(syntax-violation #f "primitive not in operator position" var))
(else (syntax-violation #f "bad module kind" var mod))))))
(define build-global-reference
(lambda (sourcev var mod)
(define (build-global-reference sourcev var mod)
(analyze-variable
mod var
(lambda (mod var public?)
(make-module-ref sourcev mod var public?))
(lambda (mod var)
(make-toplevel-ref sourcev mod var)))))
(make-toplevel-ref sourcev mod var))))
(define build-global-assignment
(lambda (sourcev var exp mod)
(define (build-global-assignment sourcev var exp mod)
(let ((exp (maybe-name-value var exp)))
(analyze-variable
mod var
(lambda (mod var public?)
(make-module-set sourcev mod var public? exp))
(lambda (mod var)
(make-toplevel-set sourcev mod var exp))))))
(make-toplevel-set sourcev mod var exp)))))
(define build-global-definition
(lambda (sourcev mod var exp)
(define (build-global-definition sourcev mod var exp)
(make-toplevel-define sourcev (and mod (cdr mod)) var
(maybe-name-value var exp))))
(maybe-name-value var exp)))
(define build-simple-lambda
(lambda (src req rest vars meta exp)
(define (build-simple-lambda src req rest vars meta exp)
(make-lambda src
meta
;; hah, a case in which kwargs would be nice.
(make-lambda-case
;; src req opt rest kw inits vars body else
src req #f rest #f '() vars exp #f))))
src req #f rest #f '() vars exp #f)))
(define build-case-lambda
(lambda (src meta body)
(make-lambda src meta body)))
(define (build-case-lambda src meta body)
(make-lambda src meta body))
(define build-lambda-case
(define (build-lambda-case src req opt rest kw inits vars body else-case)
;; req := (name ...)
;; opt := (name ...) | #f
;; rest := name | #f
@ -236,35 +226,29 @@
;; required, optional (positional), rest, keyword.
;; the body of a lambda: anything, already expanded
;; else: lambda-case | #f
(lambda (src req opt rest kw inits vars body else-case)
(make-lambda-case src req opt rest kw inits vars body else-case)))
(make-lambda-case src req opt rest kw inits vars body else-case))
(define build-primcall
(lambda (src name args)
(make-primcall src name args)))
(define (build-primcall src name args)
(make-primcall src name args))
(define build-primref
(lambda (src name)
(make-primitive-ref src name)))
(define (build-primref src name)
(make-primitive-ref src name))
(define (build-data src exp)
(make-const src exp))
(define build-sequence
(lambda (src exps)
(define (build-sequence src exps)
(if (null? (cdr exps))
(car exps)
(make-seq src (car exps) (build-sequence #f (cdr exps))))))
(make-seq src (car exps) (build-sequence #f (cdr exps)))))
(define build-let
(lambda (src ids vars val-exps body-exp)
(define (build-let src ids vars val-exps body-exp)
(let ((val-exps (map maybe-name-value ids val-exps)))
(if (null? vars)
body-exp
(make-let src ids vars val-exps body-exp)))))
(make-let src ids vars val-exps body-exp))))
(define build-named-let
(lambda (src ids vars val-exps body-exp)
(define (build-named-let src ids vars val-exps body-exp)
(let ((f (car vars))
(f-name (car ids))
(vars (cdr vars))
@ -274,15 +258,14 @@
src #f
(list f-name) (list f) (list (maybe-name-value f-name proc))
(build-call src (build-lexical-reference 'fun src f-name f)
(map maybe-name-value ids val-exps)))))))
(map maybe-name-value ids val-exps))))))
(define build-letrec
(lambda (src in-order? ids vars val-exps body-exp)
(define (build-letrec src in-order? ids vars val-exps body-exp)
(if (null? vars)
body-exp
(make-letrec src in-order? ids vars
(map maybe-name-value ids val-exps)
body-exp))))
body-exp)))
(define (gen-lexical id)
@ -307,14 +290,10 @@
(assq-ref props 'line)
(assq-ref props 'column)))))
(define source-annotation
(lambda (x)
;; Normally X is a syntax object. However, if it comes from a
;; read hash extension, X might be a plain sexp with source
;; properties.
(define (source-annotation x)
(if (syntax? x)
(syntax-sourcev x)
(datum-sourcev x))))
(datum-sourcev x)))
(define-syntax-rule (arg-check pred? e who)
(let ((x e))
@ -393,38 +372,34 @@
(define-syntax null-env (identifier-syntax '()))
(define extend-env
(lambda (labels bindings r)
(define (extend-env labels bindings r)
(if (null? labels)
r
(extend-env (cdr labels) (cdr bindings)
(cons (cons (car labels) (car bindings)) r)))))
(cons (cons (car labels) (car bindings)) r))))
(define extend-var-env
(define (extend-var-env labels vars r)
;; variant of extend-env that forms "lexical" binding
(lambda (labels vars r)
(if (null? labels)
r
(extend-var-env (cdr labels) (cdr vars)
(cons (cons (car labels) (make-binding 'lexical (car vars))) r)))))
(cons (cons (car labels) (make-binding 'lexical (car vars))) r))))
;; we use a "macros only" environment in expansion of local macro
;; definitions so that their definitions can use local macros without
;; attempting to use other lexical identifiers.
(define macros-only-env
(lambda (r)
(define (macros-only-env r)
(if (null? r)
'()
(let ((a (car r)))
(if (memq (cadr a) '(macro syntax-parameter ellipsis))
(cons a (macros-only-env (cdr r)))
(macros-only-env (cdr r)))))))
(macros-only-env (cdr r))))))
(define global-extend
(lambda (type sym val)
(define (global-extend type sym val)
(module-define! (current-module)
sym
(make-syntax-transformer sym type val))))
(make-syntax-transformer sym type val)))
;; Conceptually, identifiers are always syntax objects. Internally,
@ -432,17 +407,15 @@
;; efficiency and confusion), so that symbols are also considered
;; identifiers by id?. Externally, they are always wrapped.
(define nonsymbol-id?
(lambda (x)
(define (nonsymbol-id? x)
(and (syntax? x)
(symbol? (syntax-expression x)))))
(symbol? (syntax-expression x))))
(define id?
(lambda (x)
(define (id? x)
(cond
((symbol? x) #t)
((syntax? x) (symbol? (syntax-expression x)))
(else #f))))
(else #f)))
(define-syntax-rule (id-sym-name e)
(let ((x e))
@ -450,13 +423,12 @@
(syntax-expression x)
x)))
(define id-sym-name&marks
(lambda (x w)
(define (id-sym-name&marks x w)
(if (syntax? x)
(values
(syntax-expression x)
(join-marks (wrap-marks w) (wrap-marks (syntax-wrap x))))
(values x (wrap-marks w)))))
(values x (wrap-marks w))))
;; syntax object wraps
@ -516,10 +488,9 @@
(define-syntax the-anti-mark (identifier-syntax #f))
(define anti-mark
(lambda (w)
(define (anti-mark w)
(make-wrap (cons the-anti-mark (wrap-marks w))
(cons 'shift (wrap-subst w)))))
(cons 'shift (wrap-subst w))))
(define (new-mark)
(gen-unique))
@ -529,9 +500,8 @@
(define-syntax-rule (make-empty-ribcage)
(make-ribcage '() '() '()))
(define extend-ribcage!
(define (extend-ribcage! ribcage id label)
;; must receive ids with complete wraps
(lambda (ribcage id label)
(set-ribcage-symnames! ribcage
(cons (syntax-expression id)
(ribcage-symnames ribcage)))
@ -539,11 +509,10 @@
(cons (wrap-marks (syntax-wrap id))
(ribcage-marks ribcage)))
(set-ribcage-labels! ribcage
(cons label (ribcage-labels ribcage)))))
(cons label (ribcage-labels ribcage))))
;; make-binding-wrap creates vector-based ribcages
(define make-binding-wrap
(lambda (ids labels w)
(define (make-binding-wrap ids labels w)
(if (null? ids)
w
(make-wrap
@ -561,16 +530,14 @@
(vector-set! marksvec i marks)
(f (cdr ids) (1+ i))))))
(make-ribcage symnamevec marksvec labelvec))))
(wrap-subst w))))))
(wrap-subst w)))))
(define smart-append
(lambda (m1 m2)
(define (smart-append m1 m2)
(if (null? m2)
m1
(append m1 m2))))
(append m1 m2)))
(define join-wraps
(lambda (w1 w2)
(define (join-wraps w1 w2)
(let ((m1 (wrap-marks w1)) (s1 (wrap-subst w1)))
(if (null? m1)
(if (null? s1)
@ -580,21 +547,19 @@
(smart-append s1 (wrap-subst w2))))
(make-wrap
(smart-append m1 (wrap-marks w2))
(smart-append s1 (wrap-subst w2)))))))
(smart-append s1 (wrap-subst w2))))))
(define join-marks
(lambda (m1 m2)
(smart-append m1 m2)))
(define (join-marks m1 m2)
(smart-append m1 m2))
(define same-marks?
(lambda (x y)
(define (same-marks? x y)
(or (eq? x y)
(and (not (null? x))
(not (null? y))
(eq? (car x) (car y))
(same-marks? (cdr x) (cdr y))))))
(same-marks? (cdr x) (cdr y)))))
(define id-var-name
(define (id-var-name id w mod)
;; Syntax objects use wraps to associate names with marked
;; identifiers. This function returns the name corresponding to
;; the given identifier and wrap, or the original identifier if no
@ -619,7 +584,6 @@
;; case, this routine returns either a symbol, a syntax object, or
;; a string label.
;;
(lambda (id w mod)
(define-syntax-rule (first e)
;; Rely on Guile's multiple-values truncation.
e)
@ -677,7 +641,7 @@
(or new-id
(first (search id (wrap-subst w1) marks mod))
id))))))
(else (syntax-violation 'id-var-name "invalid id" id)))))
(else (syntax-violation 'id-var-name "invalid id" id))))
;; A helper procedure for syntax-locally-bound-identifiers, which
;; itself is a helper for transformer procedures.
@ -691,8 +655,7 @@
;; are anti-marked, so that rebuild-macro-output doesn't apply new
;; marks to them.
;;
(define locally-bound-identifiers
(lambda (w mod)
(define (locally-bound-identifiers w mod)
(define scan
(lambda (subst results)
(if (null? subst)
@ -726,7 +689,7 @@
(anti-mark (make-wrap (vector-ref marks i) subst))
mod)
results)))))))
(scan (wrap-subst w) '())))
(scan (wrap-subst w) '()))
;; Returns three values: binding type, binding value, and the module
;; (for resolving toplevel vars).
@ -834,8 +797,7 @@
;; free-id=? must be passed fully wrapped ids since (free-id=? x y)
;; may be true even if (free-id=? (wrap x w) (wrap y w)) is not.
(define free-id=?
(lambda (i j)
(define (free-id=? i j)
(let* ((mi (and (syntax? i) (syntax-module i)))
(mj (and (syntax? j) (syntax-module j)))
(ni (id-var-name i empty-wrap mi))
@ -867,33 +829,31 @@
(else
;; Otherwise `i' is bound, so check that `j' is bound, and
;; bound to the same thing.
(equal? ni nj))))))
(equal? ni nj)))))
;; bound-id=? may be passed unwrapped (or partially wrapped) ids as
;; long as the missing portion of the wrap is common to both of the ids
;; since (bound-id=? x y) iff (bound-id=? (wrap x w) (wrap y w))
(define bound-id=?
(lambda (i j)
(define (bound-id=? i j)
(if (and (syntax? i) (syntax? j))
(and (eq? (syntax-expression i)
(syntax-expression j))
(same-marks? (wrap-marks (syntax-wrap i))
(wrap-marks (syntax-wrap j))))
(eq? i j))))
(eq? i j)))
;; "valid-bound-ids?" returns #t if it receives a list of distinct ids.
;; valid-bound-ids? may be passed unwrapped (or partially wrapped) ids
;; as long as the missing portion of the wrap is common to all of the
;; ids.
(define valid-bound-ids?
(lambda (ids)
(define (valid-bound-ids? ids)
(and (let all-ids? ((ids ids))
(or (null? ids)
(and (id? (car ids))
(all-ids? (cdr ids)))))
(distinct-bound-ids? ids))))
(distinct-bound-ids? ids)))
;; distinct-bound-ids? expects a list of ids and returns #t if there are
;; no duplicates. It is quadratic on the length of the id list; long
@ -901,24 +861,21 @@
;; may be passed unwrapped (or partially wrapped) ids as long as the
;; missing portion of the wrap is common to all of the ids.
(define distinct-bound-ids?
(lambda (ids)
(define (distinct-bound-ids? ids)
(let distinct? ((ids ids))
(or (null? ids)
(and (not (bound-id-member? (car ids) (cdr ids)))
(distinct? (cdr ids)))))))
(distinct? (cdr ids))))))
(define bound-id-member?
(lambda (x list)
(define (bound-id-member? x list)
(and (not (null? list))
(or (bound-id=? x (car list))
(bound-id-member? x (cdr list))))))
(bound-id-member? x (cdr list)))))
;; wrapping expressions and identifiers
(define wrap
(lambda (x w defmod)
(source-wrap x w #f defmod)))
(define (wrap x w defmod)
(source-wrap x w #f defmod))
(define (wrap-syntax x w defmod)
(make-syntax (syntax-expression x)
@ -938,14 +895,13 @@
;; expanding
(define expand-sequence
(lambda (body r w s mod)
(define (expand-sequence body r w s mod)
(build-sequence s
(let dobody ((body body) (r r) (w w) (mod mod))
(if (null? body)
'()
(let ((first (expand (car body) r w mod)))
(cons first (dobody (cdr body) r w mod))))))))
(cons first (dobody (cdr body) r w mod)))))))
;; At top-level, we allow mixed definitions and expressions. Like
;; expand-body we expand in two passes.
@ -961,8 +917,7 @@
;; expansions of all normal definitions and expressions in the
;; sequence.
;;
(define expand-top-sequence
(lambda (body r w s m esew mod)
(define (expand-top-sequence body r w s m esew mod)
(let* ((r (cons '("placeholder" . (placeholder)) r))
(ribcage (make-empty-ribcage))
(w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w)))))
@ -1137,10 +1092,9 @@
(reverse (parse body r w s m esew mod)))))
(if (null? exps)
(build-void s)
(build-sequence s exps))))))
(build-sequence s exps)))))
(define expand-install-global
(lambda (mod name type e)
(define (expand-install-global mod name type e)
(build-global-definition
no-source
mod
@ -1153,15 +1107,9 @@
(if (eq? type 'define-syntax-parameter-form)
'syntax-parameter
'macro))
e)))))
e))))
(define parse-when-list
(lambda (e when-list)
;; `when-list' is syntax'd version of list of situations. We
;; could match these keywords lexically, via free-id=?, but then
;; we twingle the definition of eval-when to the bindings of
;; eval, load, expand, and compile, which is totally unintended.
;; So do a symbolic match instead.
(define (parse-when-list e when-list)
(let ((result (strip when-list)))
(let lp ((l result))
(if (null? l)
@ -1169,7 +1117,7 @@
(if (memq (car l) '(compile load eval expand))
(lp (cdr l))
(syntax-violation 'eval-when "invalid situation" e
(car l))))))))
(car l)))))))
;; syntax-type returns seven values: type, value, form, e, w, s, and
;; mod. The first two are described in the table below.
@ -1212,8 +1160,7 @@
;; of the forms above. It also parses definition forms, although
;; perhaps this should be done by the consumer.
(define syntax-type
(lambda (e r w s rib mod for-car?)
(define (syntax-type e r w s rib mod for-car?)
(cond
((symbol? e)
(call-with-values (lambda () (resolve-identifier e w r mod #t))
@ -1301,17 +1248,15 @@
(or (source-annotation e) s) rib
(or (syntax-module e) mod) for-car?))
((self-evaluating? e) (values 'constant #f e e w s mod))
(else (values 'other #f e e w s mod)))))
(else (values 'other #f e e w s mod))))
(define expand
(lambda (e r w mod)
(define (expand e r w mod)
(call-with-values
(lambda () (syntax-type e r w (source-annotation e) #f mod #f))
(lambda (type value form e w s mod)
(expand-expr type value form e r w s mod)))))
(expand-expr type value form e r w s mod))))
(define expand-expr
(lambda (type value form e r w s mod)
(define (expand-expr type value form e r w s mod)
(case type
((lexical)
(build-lexical-reference 'value s e value))
@ -1376,14 +1321,13 @@
(syntax-violation #f "reference to identifier outside its scope"
(source-wrap e w s mod)))
(else (syntax-violation #f "unexpected syntax"
(source-wrap e w s mod))))))
(source-wrap e w s mod)))))
(define expand-call
(lambda (x e r w s mod)
(define (expand-call x e r w s mod)
(syntax-case e ()
((e0 e1 ...)
(build-call s x
(map (lambda (e) (expand e r w mod)) #'(e1 ...)))))))
(map (lambda (e) (expand e r w mod)) #'(e1 ...))))))
;; (What follows is my interpretation of what's going on here -- Andy)
;;
@ -1418,8 +1362,7 @@
;; really nice if we could also annotate introduced expressions with the
;; locations corresponding to the macro definition, but that is not yet
;; possible.
(define expand-macro
(lambda (p e r w s rib mod)
(define (expand-macro p e r w s rib mod)
(define (decorate-source x)
(source-wrap x empty-wrap s #f))
(define (map* f x)
@ -1468,9 +1411,9 @@
(with-fluids ((transformer-environment
(lambda (k) (k e r w s rib mod))))
(rebuild-macro-output (p (source-wrap e (anti-mark w) s mod))
(new-mark)))))
(new-mark))))
(define expand-body
(define (expand-body body outer-form r w mod)
;; In processing the forms of the body, we create a new, empty wrap.
;; This wrap is augmented (destructively) each time we discover that
;; the next form is a definition. This is done:
@ -1509,7 +1452,6 @@
;; into the body.
;;
;; outer-form is fully wrapped w/source
(lambda (body outer-form r w mod)
(let* ((r (cons '("placeholder" . (placeholder)) r))
(ribcage (make-empty-ribcage))
(w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w)))))
@ -1635,10 +1577,9 @@
(let ((wrapped (source-wrap e w s mod)))
(parse body ids labels var-ids vars vals bindings
(lambda ()
(expand wrapped er empty-wrap mod)))))))))))))))
(expand wrapped er empty-wrap mod))))))))))))))
(define expand-local-syntax
(lambda (rec? e r w s mod k)
(define (expand-local-syntax rec? e r w s mod k)
(syntax-case e ()
((_ ((id val) ...) e1 e2 ...)
(let ((ids #'(id ...)))
@ -1662,21 +1603,18 @@
s
mod))))))
(_ (syntax-violation #f "bad local syntax definition"
(source-wrap e w s mod))))))
(source-wrap e w s mod)))))
(define eval-local-transformer
(lambda (expanded mod)
(define (eval-local-transformer expanded mod)
(let ((p (local-eval expanded mod)))
(if (procedure? p)
p
(syntax-violation #f "nonprocedure transformer" p)))))
(syntax-violation #f "nonprocedure transformer" p))))
(define expand-void
(lambda ()
(build-void no-source)))
(define (expand-void)
(build-void no-source))
(define ellipsis?
(lambda (e r mod)
(define (ellipsis? e r mod)
(and (nonsymbol-id? e)
;; If there is a binding for the special identifier
;; #{ $sc-ellipsis }# in the lexical environment of E,
@ -1694,10 +1632,9 @@
(lambda (type value mod)
(if (eq? type 'ellipsis)
(bound-id=? e value)
(free-id=? e #'(... ...))))))))
(free-id=? e #'(... ...)))))))
(define lambda-formals
(lambda (orig-args)
(define (lambda-formals orig-args)
(define (req args rreq)
(syntax-case args ()
(()
@ -1715,10 +1652,9 @@
(else
(syntax-violation 'lambda "duplicate identifier in argument list"
orig-args))))
(req orig-args '())))
(req orig-args '()))
(define expand-simple-lambda
(lambda (e r w s mod req rest meta body)
(define (expand-simple-lambda e r w s mod req rest meta body)
(let* ((ids (if rest (append req (list rest)) req))
(vars (map gen-var ids))
(labels (gen-labels ids)))
@ -1729,10 +1665,9 @@
(expand-body body (source-wrap e w s mod)
(extend-var-env labels vars r)
(make-binding-wrap ids labels w)
mod)))))
mod))))
(define lambda*-formals
(lambda (orig-args)
(define (lambda*-formals orig-args)
(define (req args rreq)
(syntax-case args ()
(()
@ -1810,10 +1745,9 @@
(else
(syntax-violation 'lambda* "duplicate identifier in argument list"
orig-args))))
(req orig-args '())))
(req orig-args '()))
(define expand-lambda-case
(lambda (e r w s mod get-formals clauses)
(define (expand-lambda-case e r w s mod get-formals clauses)
(define (parse-req req opt rest kw body)
(let ((vars (map gen-var req))
(labels (gen-labels req)))
@ -1901,7 +1835,7 @@
(values
(append meta meta*)
(build-lambda-case s req opt rest kw inits vars
body else*))))))))))))
body else*)))))))))))
;; data
@ -1924,14 +1858,12 @@
;; lexical variables
(define gen-var
(lambda (id)
(define (gen-var id)
(let ((id (if (syntax? id) (syntax-expression id) id)))
(gen-lexical id))))
(gen-lexical id)))
;; appears to return a reversed list
(define lambda-var-list
(lambda (vars)
(define (lambda-var-list vars)
(let lvl ((vars vars) (ls '()) (w empty-wrap))
(cond
((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w #f) ls) w))
@ -1943,7 +1875,7 @@
(join-wraps w (syntax-wrap vars))))
;; include anything else to be caught by subsequent error
;; checking
(else (cons vars ls))))))
(else (cons vars ls)))))
;; core transformers
@ -2006,8 +1938,7 @@
(global-extend
'core 'syntax
(let ()
(define gen-syntax
(lambda (src e r maps ellipsis? mod)
(define (gen-syntax src e r maps ellipsis? mod)
(if (id? e)
(call-with-values (lambda ()
(resolve-identifier e empty-wrap r mod #f))
@ -2075,10 +2006,9 @@
(lambda (e maps) (values (gen-vector e) maps))))
(x (eq? (syntax->datum #'x) #nil) (values '(quote #nil) maps))
(() (values '(quote ()) maps))
(_ (values `(quote ,e) maps))))))
(_ (values `(quote ,e) maps)))))
(define gen-ref
(lambda (src var level maps)
(define (gen-ref src var level maps)
(if (= level 0)
(values var maps)
(if (null? maps)
@ -2093,14 +2023,12 @@
(values inner-var
(cons (cons (cons outer-var inner-var)
(car maps))
outer-maps)))))))))))
outer-maps))))))))))
(define gen-mappend
(lambda (e map-env)
`(apply (primitive append) ,(gen-map e map-env))))
(define (gen-mappend e map-env)
`(apply (primitive append) ,(gen-map e map-env)))
(define gen-map
(lambda (e map-env)
(define (gen-map e map-env)
(let ((formals (map cdr map-env))
(actuals (map (lambda (x) `(ref ,(car x))) map-env)))
(cond
@ -2117,10 +2045,9 @@
,@(map (let ((r (map cons formals actuals)))
(lambda (x) (cdr (assq (cadr x) r))))
(cdr e))))
(else `(map (lambda ,formals ,e) ,@actuals))))))
(else `(map (lambda ,formals ,e) ,@actuals)))))
(define gen-cons
(lambda (x y)
(define (gen-cons x y)
(case (car y)
((quote)
(if (eq? (car x) 'quote)
@ -2129,24 +2056,21 @@
`(list ,x)
`(cons ,x ,y))))
((list) `(list ,x ,@(cdr y)))
(else `(cons ,x ,y)))))
(else `(cons ,x ,y))))
(define gen-append
(lambda (x y)
(define (gen-append x y)
(if (equal? y '(quote ()))
x
`(append ,x ,y))))
`(append ,x ,y)))
(define gen-vector
(lambda (x)
(define (gen-vector x)
(cond
((eq? (car x) 'list) `(vector ,@(cdr x)))
((eq? (car x) 'quote) `(quote #(,@(cadr x))))
(else `(list->vector ,x)))))
(else `(list->vector ,x))))
(define regen
(lambda (x)
(define (regen x)
(case (car x)
((ref) (build-lexical-reference 'value no-source (cadr x) (cadr x)))
((primitive) (build-primref no-source (cadr x)))
@ -2155,7 +2079,7 @@
(if (list? (cadr x))
(build-simple-lambda no-source (cadr x) #f (cadr x) '() (regen (caddr x)))
(error "how did we get here" x)))
(else (build-primcall no-source (car x) (map regen (cdr x)))))))
(else (build-primcall no-source (car x) (map regen (cdr x))))))
(lambda (e r w s mod)
(let ((e (source-wrap e w s mod)))
@ -2394,8 +2318,7 @@
(global-extend 'module-ref '@@
(lambda (e r w mod)
(define remodulate
(lambda (x mod)
(define (remodulate x mod)
(cond ((pair? x)
(cons (remodulate (car x) mod)
(remodulate (cdr x) mod)))
@ -2411,7 +2334,7 @@
(do ((i 0 (1+ i)))
((= i n) v)
(vector-set! v i (remodulate (vector-ref x i) mod)))))
(else x))))
(else x)))
(syntax-case e (@@ primitive)
((_ primitive id)
(and (id? #'id)
@ -2467,10 +2390,9 @@
(global-extend 'core 'syntax-case
(let ()
(define convert-pattern
(define (convert-pattern pattern keys ellipsis?)
;; accepts pattern & keys
;; returns $sc-dispatch pattern & ids
(lambda (pattern keys ellipsis?)
(define cvt*
(lambda (p* n ids)
(syntax-case p* ()
@ -2535,10 +2457,9 @@
(lambda () (cvt (syntax (x ...)) n ids))
(lambda (p ids) (values (vector 'vector p) ids))))
(x (values (vector 'atom (strip p)) ids))))))
(cvt pattern 0 '())))
(cvt pattern 0 '()))
(define build-dispatch-call
(lambda (pvars exp y r mod)
(define (build-dispatch-call pvars exp y r mod)
(let ((ids (map car pvars)) (levels (map cdr pvars)))
(let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
(build-primcall
@ -2555,10 +2476,9 @@
r)
(make-binding-wrap ids labels empty-wrap)
mod))
y))))))
y)))))
(define gen-clause
(lambda (x keys clauses r pat fender exp mod)
(define (gen-clause x keys clauses r pat fender exp mod)
(call-with-values
(lambda () (convert-pattern pat keys (lambda (e) (ellipsis? e r mod))))
(lambda (p pvars)
@ -2586,10 +2506,9 @@
(list (if (eq? p 'any)
(build-primcall no-source 'list (list x))
(build-primcall no-source '$sc-dispatch
(list x (build-data no-source p)))))))))))))
(list x (build-data no-source p))))))))))))
(define gen-syntax-case
(lambda (x keys clauses r mod)
(define (gen-syntax-case x keys clauses r mod)
(if (null? clauses)
(build-primcall no-source 'syntax-violation
(list (build-data no-source #f)
@ -2623,7 +2542,7 @@
(gen-clause x keys (cdr clauses) r
#'pat #'fender #'exp mod))
(_ (syntax-violation 'syntax-case "invalid clause"
(car clauses)))))))
(car clauses))))))
(lambda (e r w s mod)
(let ((e (source-wrap e w s mod)))
@ -2817,8 +2736,7 @@
(let ()
(define match-each
(lambda (e p w mod)
(define (match-each e p w mod)
(cond
((pair? e)
(let ((first (match (car e) p w '() mod)))
@ -2831,10 +2749,9 @@
p
(join-wraps w (syntax-wrap e))
(or (syntax-module e) mod)))
(else #f))))
(else #f)))
(define match-each+
(lambda (e x-pat y-pat z-pat w r mod)
(define (match-each+ e x-pat y-pat z-pat w r mod)
(let f ((e e) (w w))
(cond
((pair? e)
@ -2855,10 +2772,9 @@
(f (syntax-expression e)
(join-wraps w (syntax-wrap e))))
(else
(values '() y-pat (match e z-pat w r mod)))))))
(values '() y-pat (match e z-pat w r mod))))))
(define match-each-any
(lambda (e w mod)
(define (match-each-any e w mod)
(cond
((pair? e)
(let ((l (match-each-any (cdr e) w mod)))
@ -2868,10 +2784,9 @@
(match-each-any (syntax-expression e)
(join-wraps w (syntax-wrap e))
mod))
(else #f))))
(else #f)))
(define match-empty
(lambda (p r)
(define (match-empty p r)
(cond
((null? p) r)
((eq? p '_) r)
@ -2886,16 +2801,14 @@
(reverse (vector-ref p 2))
(match-empty (vector-ref p 3) r))))
((free-id atom) r)
((vector) (match-empty (vector-ref p 1) r)))))))
((vector) (match-empty (vector-ref p 1) r))))))
(define combine
(lambda (r* r)
(define (combine r* r)
(if (null? (car r*))
r
(cons (map car r*) (combine (map cdr r*) r)))))
(cons (map car r*) (combine (map cdr r*) r))))
(define match*
(lambda (e p w r mod)
(define (match* e p w r mod)
(cond
((null? p) (and (null? e) r))
((pair? p)
@ -2929,10 +2842,9 @@
((atom) (and (equal? (vector-ref p 1) (strip e)) r))
((vector)
(and (vector? e)
(match (vector->list e) (vector-ref p 1) w r mod))))))))
(match (vector->list e) (vector-ref p 1) w r mod)))))))
(define match
(lambda (e p w r mod)
(define (match e p w r mod)
(cond
((not r) #f)
((eq? p '_) r)
@ -2944,7 +2856,7 @@
(join-wraps w (syntax-wrap e))
r
(or (syntax-module e) mod)))
(else (match* e p w r mod)))))
(else (match* e p w r mod))))
(set! $sc-dispatch
(lambda (e p)