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