mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-17 01:00:20 +02:00
Code Activity

thread the module through syntax-case's expansion

Browse source 
* libguile/debug.h:
* libguile/debug.c (scm_procedure_module): New procedure, returns the
  module that was current when the given procedure was defined. Used by
  syncase to scope free identifiers.

* module/ice-9/psyntax-pp.scm: Recompiled.

* module/ice-9/psyntax.scm: Thread the module through the syntax
  expansion. This is harder than it would appear because in many places
  the different components of syntax objects are destructured.

* module/ice-9/syncase.scm (guile-macro): Adapt to new signature for
  syntax transformer functions.
This commit is contained in:
Andy Wingo 2009-03-29 17:15:25 -07:00
parent e02e84deed
commit 4e237f1460
5 changed files with 279 additions and 209 deletions
Download patch file Download diff file Expand all files Collapse all files

31
libguile/debug.c
View file

@ -400,6 +400,37 @@ SCM_DEFINE (scm_procedure_environment, "procedure-environment", 1, 0, 0,
} }
#undef FUNC_NAME #undef FUNC_NAME
SCM_DEFINE (scm_procedure_module, "procedure-module", 1, 0, 0,
(SCM proc),
"Return the module that was current when this procedure was defined.\n"
"Free variables in this procedure are resolved relative to the\n"
"procedure's module.")
#define FUNC_NAME s_scm_procedure_module
{
SCM_VALIDATE_PROC (SCM_ARG1, proc);
if (scm_is_true (scm_program_p (proc)))
return scm_program_module (proc);
else
{
SCM env = scm_procedure_environment (proc);
if (scm_is_null (env))
return SCM_BOOL_F;
else
{
for (; !scm_is_null (scm_cdr (env)); env = scm_cdr (env))
;
if (SCM_EVAL_CLOSURE_P (scm_car (env)))
return SCM_PACK (SCM_SMOB_DATA (scm_car (env)));
else
return SCM_BOOL_F;
}
}
}
#undef FUNC_NAME
/* Eval in a local environment. We would like to have the ability to /* Eval in a local environment. We would like to have the ability to

1
libguile/debug.h
View file

@ -140,6 +140,7 @@ SCM_API SCM scm_local_eval (SCM exp, SCM env);
SCM_API SCM scm_reverse_lookup (SCM env, SCM data); SCM_API SCM scm_reverse_lookup (SCM env, SCM data);
SCM_API SCM scm_sys_start_stack (SCM info_id, SCM thunk); SCM_API SCM scm_sys_start_stack (SCM info_id, SCM thunk);
SCM_API SCM scm_procedure_environment (SCM proc); SCM_API SCM scm_procedure_environment (SCM proc);
SCM_API SCM scm_procedure_module (SCM proc);
SCM_API SCM scm_procedure_source (SCM proc); SCM_API SCM scm_procedure_source (SCM proc);
SCM_API SCM scm_procedure_name (SCM proc); SCM_API SCM scm_procedure_name (SCM proc);
SCM_API SCM scm_memoized_environment (SCM m); SCM_API SCM scm_memoized_environment (SCM m);

22
module/ice-9/psyntax-pp.scm
View file

File diff suppressed because one or more lines are too long

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

@ -319,12 +319,12 @@
(define fx< <) (define fx< <)
(define top-level-eval-hook (define top-level-eval-hook
(lambda (x) (lambda (x mod)
(eval `(,noexpand ,x) (interaction-environment)))) (eval `(,noexpand ,x) (or mod (interaction-environment)))))
(define local-eval-hook (define local-eval-hook
(lambda (x) (lambda (x mod)
(eval `(,noexpand ,x) (interaction-environment)))) (eval `(,noexpand ,x) (or mod (interaction-environment)))))
(define error-hook (define error-hook
(lambda (who why what) (lambda (who why what)
@ -334,6 +334,7 @@
(syntax-rules () (syntax-rules ()
((_) (gensym)))) ((_) (gensym))))
;; wingo: FIXME: use modules natively?
(define put-global-definition-hook (define put-global-definition-hook
(lambda (symbol binding) (lambda (symbol binding)
(putprop symbol '*sc-expander* binding))) (putprop symbol '*sc-expander* binding)))
@ -372,17 +373,17 @@
(define-syntax build-global-reference (define-syntax build-global-reference
(syntax-rules () (syntax-rules ()
((_ source var) ((_ source var mod)
(build-annotated source (make-module-ref #f var #f))))) (build-annotated source (make-module-ref #f var mod)))))
(define-syntax build-global-assignment (define-syntax build-global-assignment
(syntax-rules () (syntax-rules ()
((_ source var exp) ((_ source var exp mod)
(build-annotated source `(set! ,(make-module-ref #f var #f) ,exp))))) (build-annotated source `(set! ,(make-module-ref #f var mod) ,exp)))))
(define-syntax build-global-definition (define-syntax build-global-definition
(syntax-rules () (syntax-rules ()
((_ source var exp) ((_ source var exp mod)
(build-annotated source `(define ,var ,exp))))) (build-annotated source `(define ,var ,exp)))))
(define-syntax build-lambda (define-syntax build-lambda
@ -390,6 +391,7 @@
((_ src vars exp) ((_ src vars exp)
(build-annotated src `(lambda ,vars ,exp))))) (build-annotated src `(lambda ,vars ,exp)))))
;; FIXME: wingo: add modules here somehow?
(define-syntax build-primref (define-syntax build-primref
(syntax-rules () (syntax-rules ()
((_ src name) (build-annotated src name)) ((_ src name) (build-annotated src name))
@ -428,6 +430,7 @@
(build-annotated src (build-annotated src
`(letrec ,(map list vars val-exps) ,body-exp))))) `(letrec ,(map list vars val-exps) ,body-exp)))))
;; FIXME: wingo: use make-lexical
(define-syntax build-lexical-var (define-syntax build-lexical-var
(syntax-rules () (syntax-rules ()
((_ src id) (build-annotated src (gensym (symbol->string id)))))) ((_ src id) (build-annotated src (gensym (symbol->string id))))))
@ -832,7 +835,7 @@
;;; wrapping expressions and identifiers ;;; wrapping expressions and identifiers
(define wrap (define wrap
(lambda (x w) (lambda (x w defmod)
(cond (cond
((and (null? (wrap-marks w)) (null? (wrap-subst w))) x) ((and (null? (wrap-marks w)) (null? (wrap-subst w))) x)
((syntax-object? x) ((syntax-object? x)
@ -841,32 +844,33 @@
(join-wraps w (syntax-object-wrap x)) (join-wraps w (syntax-object-wrap x))
(syntax-object-module x))) (syntax-object-module x)))
((null? x) x) ((null? x) x)
(else (make-syntax-object x w #f))))) (else (make-syntax-object x w defmod)))))
(define source-wrap (define source-wrap
(lambda (x w s) (lambda (x w s defmod)
(wrap (if s (make-annotation x s #f) x) w))) (wrap (if s (make-annotation x s #f) x) w defmod)))
;;; expanding ;;; expanding
(define chi-sequence (define chi-sequence
(lambda (body r w s) (lambda (body r w s mod)
(build-sequence s (build-sequence s
(let dobody ((body body) (r r) (w w)) (let dobody ((body body) (r r) (w w) (mod mod))
(if (null? body) (if (null? body)
'() '()
(let ((first (chi (car body) r w))) (let ((first (chi (car body) r w mod)))
(cons first (dobody (cdr body) r w)))))))) (cons first (dobody (cdr body) r w mod))))))))
(define chi-top-sequence (define chi-top-sequence
(lambda (body r w s m esew) (lambda (body r w s m esew mod)
(build-sequence s (build-sequence s
(let dobody ((body body) (r r) (w w) (m m) (esew esew)) (let dobody ((body body) (r r) (w w) (m m) (esew esew) (mod mod))
(if (null? body) (if (null? body)
'() '()
(let ((first (chi-top (car body) r w m esew))) (let ((first (chi-top (car body) r w m esew mod)))
(cons first (dobody (cdr body) r w m esew)))))))) (cons first (dobody (cdr body) r w m esew mod))))))))
;; FIXME: module?
(define chi-install-global (define chi-install-global
(lambda (name e) (lambda (name e)
(build-application no-source (build-application no-source
@ -885,12 +889,12 @@
((free-id=? x (syntax compile)) 'compile) ((free-id=? x (syntax compile)) 'compile)
((free-id=? x (syntax load)) 'load) ((free-id=? x (syntax load)) 'load)
((free-id=? x (syntax eval)) 'eval) ((free-id=? x (syntax eval)) 'eval)
(else (syntax-error (wrap x w) (else (syntax-error (wrap x w #f)
"invalid eval-when situation")))) "invalid eval-when situation"))))
situations)))))) situations))))))
;;; syntax-type returns five values: type, value, e, w, and s. The first ;;; syntax-type returns six values: type, value, e, w, s, and mod. The
;;; two are described in the table below. ;;; first two are described in the table below.
;;; ;;;
;;; type value explanation ;;; type value explanation
;;; ------------------------------------------------------------------- ;;; -------------------------------------------------------------------
@ -918,25 +922,26 @@
;;; ;;;
;;; For define-form and define-syntax-form, e is the rhs expression. ;;; For define-form and define-syntax-form, e is the rhs expression.
;;; For all others, e is the entire form. w is the wrap for e. ;;; For all others, e is the entire form. w is the wrap for e.
;;; s is the source for the entire form. ;;; s is the source for the entire form. mod is the module for e.
;;; ;;;
;;; syntax-type expands macros and unwraps as necessary to get to ;;; syntax-type expands macros and unwraps as necessary to get to
;;; one of the forms above. It also parses define and define-syntax ;;; one of the forms above. It also parses define and define-syntax
;;; forms, although perhaps this should be done by the consumer. ;;; forms, although perhaps this should be done by the consumer.
(define syntax-type (define syntax-type
(lambda (e r w s rib) (lambda (e r w s rib mod)
(cond (cond
((symbol? e) ((symbol? e)
(let* ((n (id-var-name e w)) (let* ((n (id-var-name e w))
(b (lookup n r)) (b (lookup n r))
(type (binding-type b))) (type (binding-type b)))
(case type (case type
((lexical) (values type (binding-value b) e w s)) ((lexical) (values type (binding-value b) e w s #f))
((global) (values type n e w s)) ((global) (values type n e w s mod))
((macro) ((macro)
(syntax-type (chi-macro (binding-value b) e r w rib) r empty-wrap s rib)) (syntax-type (chi-macro (binding-value b) e r w rib mod)
(else (values type (binding-value b) e w s))))) r empty-wrap s rib mod))
(else (values type (binding-value b) e w s mod)))))
((pair? e) ((pair? e)
(let ((first (car e))) (let ((first (car e)))
(if (id? first) (if (id? first)
@ -944,73 +949,79 @@
(b (lookup n r)) (b (lookup n r))
(type (binding-type b))) (type (binding-type b)))
(case type (case type
((lexical) (values 'lexical-call (binding-value b) e w s)) ((lexical)
((global) (values 'global-call n e w s)) (values 'lexical-call (binding-value b) e w s mod))
((global)
(values 'global-call n e w s mod))
((macro) ((macro)
(syntax-type (chi-macro (binding-value b) e r w rib) (syntax-type (chi-macro (binding-value b) e r w rib mod)
r empty-wrap s rib)) r empty-wrap s rib mod))
((core external-macro) (values type (binding-value b) e w s)) ((core external-macro)
(values type (binding-value b) e w s mod))
((local-syntax) ((local-syntax)
(values 'local-syntax-form (binding-value b) e w s)) (values 'local-syntax-form (binding-value b) e w s mod))
((begin) (values 'begin-form #f e w s)) ((begin)
((eval-when) (values 'eval-when-form #f e w s)) (values 'begin-form #f e w s mod))
((eval-when)
(values 'eval-when-form #f e w s mod))
((define) ((define)
(syntax-case e () (syntax-case e ()
((_ name val) ((_ name val)
(id? (syntax name)) (id? (syntax name))
(values 'define-form (syntax name) (syntax val) w s)) (values 'define-form (syntax name) (syntax val) w s mod))
((_ (name . args) e1 e2 ...) ((_ (name . args) e1 e2 ...)
(and (id? (syntax name)) (and (id? (syntax name))
(valid-bound-ids? (lambda-var-list (syntax args)))) (valid-bound-ids? (lambda-var-list (syntax args))))
; need lambda here... ; need lambda here...
(values 'define-form (wrap (syntax name) w) (values 'define-form (wrap (syntax name) w #f)
(cons (syntax lambda) (wrap (syntax (args e1 e2 ...)) w)) (cons (syntax lambda) (wrap (syntax (args e1 e2 ...)) w mod))
empty-wrap s)) empty-wrap s mod))
((_ name) ((_ name)
(id? (syntax name)) (id? (syntax name))
(values 'define-form (wrap (syntax name) w) (values 'define-form (wrap (syntax name) w #f)
(syntax (void)) (syntax (void))
empty-wrap s)))) empty-wrap s mod))))
((define-syntax) ((define-syntax)
(syntax-case e () (syntax-case e ()
((_ name val) ((_ name val)
(id? (syntax name)) (id? (syntax name))
(values 'define-syntax-form (syntax name) (values 'define-syntax-form (syntax name)
(syntax val) w s)))) (syntax val) w s mod))))
(else (values 'call #f e w s)))) (else
(values 'call #f e w s)))) (values 'call #f e w s mod))))
(values 'call #f e w s mod))))
((syntax-object? e) ((syntax-object? e)
;; s can't be valid source if we've unwrapped ;; s can't be valid source if we've unwrapped
(syntax-type (syntax-object-expression e) (syntax-type (syntax-object-expression e)
r r
(join-wraps w (syntax-object-wrap e)) (join-wraps w (syntax-object-wrap e))
no-source rib)) no-source rib (syntax-object-module e)))
((annotation? e) ((annotation? e)
(syntax-type (annotation-expression e) r w (annotation-source e) rib)) (syntax-type (annotation-expression e) r w (annotation-source e) rib mod))
((self-evaluating? e) (values 'constant #f e w s)) ((self-evaluating? e) (values 'constant #f e w s mod))
(else (values 'other #f e w s))))) (else (values 'other #f e w s mod)))))
(define chi-top (define chi-top
(lambda (e r w m esew) (lambda (e r w m esew mod)
(define-syntax eval-if-c&e (define-syntax eval-if-c&e
(syntax-rules () (syntax-rules ()
((_ m e) ((_ m e mod)
(let ((x e)) (let ((x e))
(if (eq? m 'c&e) (top-level-eval-hook x)) (if (eq? m 'c&e) (top-level-eval-hook x mod))
x)))) x))))
(call-with-values (call-with-values
(lambda () (syntax-type e r w no-source #f)) (lambda () (syntax-type e r w no-source #f mod))
(lambda (type value e w s) (lambda (type value e w s mod)
(case type (case type
((begin-form) ((begin-form)
(syntax-case e () (syntax-case e ()
((_) (chi-void)) ((_) (chi-void))
((_ e1 e2 ...) ((_ e1 e2 ...)
(chi-top-sequence (syntax (e1 e2 ...)) r w s m esew)))) (chi-top-sequence (syntax (e1 e2 ...)) r w s m esew mod))))
((local-syntax-form) ((local-syntax-form)
(chi-local-syntax value e r w s (chi-local-syntax value e r w s mod
(lambda (body r w s) (lambda (body r w s mod)
(chi-top-sequence body r w s m esew)))) (chi-top-sequence body r w s m esew mod))))
((eval-when-form) ((eval-when-form)
(syntax-case e () (syntax-case e ()
((_ (x ...) e1 e2 ...) ((_ (x ...) e1 e2 ...)
@ -1019,19 +1030,20 @@
(cond (cond
((eq? m 'e) ((eq? m 'e)
(if (memq 'eval when-list) (if (memq 'eval when-list)
(chi-top-sequence body r w s 'e '(eval)) (chi-top-sequence body r w s 'e '(eval) mod)
(chi-void))) (chi-void)))
((memq 'load when-list) ((memq 'load when-list)
(if (or (memq 'compile when-list) (if (or (memq 'compile when-list)
(and (eq? m 'c&e) (memq 'eval when-list))) (and (eq? m 'c&e) (memq 'eval when-list)))
(chi-top-sequence body r w s 'c&e '(compile load)) (chi-top-sequence body r w s 'c&e '(compile load) mod)
(if (memq m '(c c&e)) (if (memq m '(c c&e))
(chi-top-sequence body r w s 'c '(load)) (chi-top-sequence body r w s 'c '(load) mod)
(chi-void)))) (chi-void))))
((or (memq 'compile when-list) ((or (memq 'compile when-list)
(and (eq? m 'c&e) (memq 'eval when-list))) (and (eq? m 'c&e) (memq 'eval when-list)))
(top-level-eval-hook (top-level-eval-hook
(chi-top-sequence body r w s 'e '(eval))) (chi-top-sequence body r w s 'e '(eval) mod)
mod)
(chi-void)) (chi-void))
(else (chi-void))))))) (else (chi-void)))))))
((define-syntax-form) ((define-syntax-form)
@ -1039,20 +1051,21 @@
(case m (case m
((c) ((c)
(if (memq 'compile esew) (if (memq 'compile esew)
(let ((e (chi-install-global n (chi e r w)))) (let ((e (chi-install-global n (chi e r w mod))))
(top-level-eval-hook e) (top-level-eval-hook e mod)
(if (memq 'load esew) e (chi-void))) (if (memq 'load esew) e (chi-void)))
(if (memq 'load esew) (if (memq 'load esew)
(chi-install-global n (chi e r w)) (chi-install-global n (chi e r w mod))
(chi-void)))) (chi-void))))
((c&e) ((c&e)
(let ((e (chi-install-global n (chi e r w)))) (let ((e (chi-install-global n (chi e r w mod))))
(top-level-eval-hook e) (top-level-eval-hook e mod)
e)) e))
(else (else
(if (memq 'eval esew) (if (memq 'eval esew)
(top-level-eval-hook (top-level-eval-hook
(chi-install-global n (chi e r w)))) (chi-install-global n (chi e r w mod))
mod))
(chi-void))))) (chi-void)))))
((define-form) ((define-form)
(let* ((n (id-var-name value w)) (let* ((n (id-var-name value w))
@ -1060,72 +1073,76 @@
(case type (case type
((global) ((global)
(eval-if-c&e m (eval-if-c&e m
(build-global-definition s n (chi e r w)))) (build-global-definition s n (chi e r w mod) mod)
mod))
((displaced-lexical) ((displaced-lexical)
(syntax-error (wrap value w) "identifier out of context")) (syntax-error (wrap value w #f) "identifier out of context"))
(else (else
(if (eq? type 'external-macro) (if (eq? type 'external-macro)
(eval-if-c&e m (eval-if-c&e m
(build-global-definition s n (chi e r w))) (build-global-definition s n (chi e r w mod) mod)
(syntax-error (wrap value w) mod)
(syntax-error (wrap value w #f)
"cannot define keyword at top level")))))) "cannot define keyword at top level"))))))
(else (eval-if-c&e m (chi-expr type value e r w s)))))))) (else (eval-if-c&e m (chi-expr type value e r w s mod) mod)))))))
(define chi (define chi
(lambda (e r w) (lambda (e r w mod)
(call-with-values (call-with-values
(lambda () (syntax-type e r w no-source #f)) (lambda () (syntax-type e r w no-source #f mod))
(lambda (type value e w s) (lambda (type value e w s mod)
(chi-expr type value e r w s))))) (chi-expr type value e r w s mod)))))
(define chi-expr (define chi-expr
(lambda (type value e r w s) (lambda (type value e r w s mod)
(case type (case type
((lexical) ((lexical)
(build-lexical-reference 'value s value)) (build-lexical-reference 'value s value))
((core external-macro) (value e r w s)) ((core external-macro)
;; apply transformer
(value e r w s mod))
((lexical-call) ((lexical-call)
(chi-application (chi-application
(build-lexical-reference 'fun (source-annotation (car e)) value) (build-lexical-reference 'fun (source-annotation (car e)) value)
e r w s)) e r w s mod))
((global-call) ((global-call)
(chi-application (chi-application
(build-global-reference (source-annotation (car e)) value) (build-global-reference (source-annotation (car e)) value mod)
e r w s)) e r w s mod))
((constant) (build-data s (strip (source-wrap e w s) empty-wrap))) ((constant) (build-data s (strip (source-wrap e w s mod) empty-wrap)))
((global) (build-global-reference s value)) ((global) (build-global-reference s value mod))
((call) (chi-application (chi (car e) r w) e r w s)) ((call) (chi-application (chi (car e) r w mod) e r w s mod))
((begin-form) ((begin-form)
(syntax-case e () (syntax-case e ()
((_ e1 e2 ...) (chi-sequence (syntax (e1 e2 ...)) r w s)))) ((_ e1 e2 ...) (chi-sequence (syntax (e1 e2 ...)) r w s mod))))
((local-syntax-form) ((local-syntax-form)
(chi-local-syntax value e r w s chi-sequence)) (chi-local-syntax value e r w s mod chi-sequence))
((eval-when-form) ((eval-when-form)
(syntax-case e () (syntax-case e ()
((_ (x ...) e1 e2 ...) ((_ (x ...) e1 e2 ...)
(let ((when-list (chi-when-list e (syntax (x ...)) w))) (let ((when-list (chi-when-list e (syntax (x ...)) w)))
(if (memq 'eval when-list) (if (memq 'eval when-list)
(chi-sequence (syntax (e1 e2 ...)) r w s) (chi-sequence (syntax (e1 e2 ...)) r w s mod)
(chi-void)))))) (chi-void))))))
((define-form define-syntax-form) ((define-form define-syntax-form)
(syntax-error (wrap value w) "invalid context for definition of")) (syntax-error (wrap value w #f) "invalid context for definition of"))
((syntax) ((syntax)
(syntax-error (source-wrap e w s) (syntax-error (source-wrap e w s mod)
"reference to pattern variable outside syntax form")) "reference to pattern variable outside syntax form"))
((displaced-lexical) ((displaced-lexical)
(syntax-error (source-wrap e w s) (syntax-error (source-wrap e w s mod)
"reference to identifier outside its scope")) "reference to identifier outside its scope"))
(else (syntax-error (source-wrap e w s)))))) (else (syntax-error (source-wrap e w s mod))))))
(define chi-application (define chi-application
(lambda (x e r w s) (lambda (x e r w s mod)
(syntax-case e () (syntax-case e ()
((e0 e1 ...) ((e0 e1 ...)
(build-application s x (build-application s x
(map (lambda (e) (chi e r w)) (syntax (e1 ...)))))))) (map (lambda (e) (chi e r w mod)) (syntax (e1 ...))))))))
(define chi-macro (define chi-macro
(lambda (p e r w rib) (lambda (p e r w rib mod)
(define rebuild-macro-output (define rebuild-macro-output
(lambda (x m) (lambda (x m)
(cond ((pair? x) (cond ((pair? x)
@ -1134,15 +1151,20 @@
((syntax-object? x) ((syntax-object? x)
(let ((w (syntax-object-wrap x))) (let ((w (syntax-object-wrap x)))
(let ((ms (wrap-marks w)) (s (wrap-subst w))) (let ((ms (wrap-marks w)) (s (wrap-subst w)))
(make-syntax-object (syntax-object-expression x) (if (and (pair? ms) (eq? (car ms) the-anti-mark))
(if (and (pair? ms) (eq? (car ms) the-anti-mark)) ;; output is from original text
(make-wrap (cdr ms) (make-syntax-object
(if rib (cons rib (cdr s)) (cdr s))) (syntax-object-expression x)
(make-wrap (cons m ms) (make-wrap (cdr ms) (if rib (cons rib (cdr s)) (cdr s)))
(if rib (syntax-object-module x))
(cons rib (cons 'shift s)) ;; output introduced by macro
(cons 'shift s)))) (make-syntax-object
(syntax-object-module x))))) (syntax-object-expression x)
(make-wrap (cons m ms)
(if rib
(cons rib (cons 'shift s))
(cons 'shift s)))
(procedure-module p)))))) ;; hither the hygiene
((vector? x) ((vector? x)
(let* ((n (vector-length x)) (v (make-vector n))) (let* ((n (vector-length x)) (v (make-vector n)))
(do ((i 0 (fx+ i 1))) (do ((i 0 (fx+ i 1)))
@ -1152,7 +1174,7 @@
((symbol? x) ((symbol? x)
(syntax-error x "encountered raw symbol in macro output")) (syntax-error x "encountered raw symbol in macro output"))
(else x)))) (else x))))
(rebuild-macro-output (p (wrap e (anti-mark w))) (new-mark)))) (rebuild-macro-output (p (wrap e (anti-mark w) mod)) (new-mark))))
(define chi-body (define chi-body
;; 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.
@ -1193,34 +1215,34 @@
;; 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) (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)))))
(let parse ((body (map (lambda (x) (cons r (wrap x w))) body)) (let parse ((body (map (lambda (x) (cons r (wrap x w mod))) body))
(ids '()) (labels '()) (vars '()) (vals '()) (bindings '())) (ids '()) (labels '()) (vars '()) (vals '()) (bindings '()))
(if (null? body) (if (null? body)
(syntax-error outer-form "no expressions in body") (syntax-error outer-form "no expressions in body")
(let ((e (cdar body)) (er (caar body))) (let ((e (cdar body)) (er (caar body)))
(call-with-values (call-with-values
(lambda () (syntax-type e er empty-wrap no-source ribcage)) (lambda () (syntax-type e er empty-wrap no-source ribcage mod))
(lambda (type value e w s) (lambda (type value e w s mod)
(case type (case type
((define-form) ((define-form)
(let ((id (wrap value w)) (label (gen-label))) (let ((id (wrap value w mod)) (label (gen-label)))
(let ((var (gen-var id))) (let ((var (gen-var id)))
(extend-ribcage! ribcage id label) (extend-ribcage! ribcage id label)
(parse (cdr body) (parse (cdr body)
(cons id ids) (cons label labels) (cons id ids) (cons label labels)
(cons var vars) (cons (cons er (wrap e w)) vals) (cons var vars) (cons (cons er (wrap e w mod)) vals)
(cons (make-binding 'lexical var) bindings))))) (cons (make-binding 'lexical var) bindings)))))
((define-syntax-form) ((define-syntax-form)
(let ((id (wrap value w)) (label (gen-label))) (let ((id (wrap value w mod)) (label (gen-label)))
(extend-ribcage! ribcage id label) (extend-ribcage! ribcage id label)
(parse (cdr body) (parse (cdr body)
(cons id ids) (cons label labels) (cons id ids) (cons label labels)
vars vals vars vals
(cons (make-binding 'macro (cons er (wrap e w))) (cons (make-binding 'macro (cons er (wrap e w mod)))
bindings)))) bindings))))
((begin-form) ((begin-form)
(syntax-case e () (syntax-case e ()
@ -1228,24 +1250,24 @@
(parse (let f ((forms (syntax (e1 ...)))) (parse (let f ((forms (syntax (e1 ...))))
(if (null? forms) (if (null? forms)
(cdr body) (cdr body)
(cons (cons er (wrap (car forms) w)) (cons (cons er (wrap (car forms) w mod))
(f (cdr forms))))) (f (cdr forms)))))
ids labels vars vals bindings)))) ids labels vars vals bindings))))
((local-syntax-form) ((local-syntax-form)
(chi-local-syntax value e er w s (chi-local-syntax value e er w s mod
(lambda (forms er w s) (lambda (forms er w s mod)
(parse (let f ((forms forms)) (parse (let f ((forms forms))
(if (null? forms) (if (null? forms)
(cdr body) (cdr body)
(cons (cons er (wrap (car forms) w)) (cons (cons er (wrap (car forms) w mod))
(f (cdr forms))))) (f (cdr forms)))))
ids labels vars vals bindings)))) ids labels vars vals bindings))))
(else ; found a non-definition (else ; found a non-definition
(if (null? ids) (if (null? ids)
(build-sequence no-source (build-sequence no-source
(map (lambda (x) (map (lambda (x)
(chi (cdr x) (car x) empty-wrap)) (chi (cdr x) (car x) empty-wrap mod))
(cons (cons er (source-wrap e w s)) (cons (cons er (source-wrap e w s mod))
(cdr body)))) (cdr body))))
(begin (begin
(if (not (valid-bound-ids? ids)) (if (not (valid-bound-ids? ids))
@ -1262,23 +1284,24 @@
(macros-only-env er)))) (macros-only-env er))))
(set-cdr! b (set-cdr! b
(eval-local-transformer (eval-local-transformer
(chi (cddr b) r-cache empty-wrap))) (chi (cddr b) r-cache empty-wrap mod)
mod))
(loop (cdr bs) er r-cache)) (loop (cdr bs) er r-cache))
(loop (cdr bs) er-cache r-cache))))) (loop (cdr bs) er-cache r-cache)))))
(set-cdr! r (extend-env labels bindings (cdr r))) (set-cdr! r (extend-env labels bindings (cdr r)))
(build-letrec no-source (build-letrec no-source
vars vars
(map (lambda (x) (map (lambda (x)
(chi (cdr x) (car x) empty-wrap)) (chi (cdr x) (car x) empty-wrap mod))
vals) vals)
(build-sequence no-source (build-sequence no-source
(map (lambda (x) (map (lambda (x)
(chi (cdr x) (car x) empty-wrap)) (chi (cdr x) (car x) empty-wrap mod))
(cons (cons er (source-wrap e w s)) (cons (cons er (source-wrap e w s mod))
(cdr body))))))))))))))))) (cdr body)))))))))))))))))
(define chi-lambda-clause (define chi-lambda-clause
(lambda (e c r w k) (lambda (e c r w mod k)
(syntax-case c () (syntax-case c ()
(((id ...) e1 e2 ...) (((id ...) e1 e2 ...)
(let ((ids (syntax (id ...)))) (let ((ids (syntax (id ...))))
@ -1290,7 +1313,8 @@
(chi-body (syntax (e1 e2 ...)) (chi-body (syntax (e1 e2 ...))
e e
(extend-var-env labels new-vars r) (extend-var-env labels new-vars r)
(make-binding-wrap ids labels w))))))) (make-binding-wrap ids labels w)
mod))))))
((ids e1 e2 ...) ((ids e1 e2 ...)
(let ((old-ids (lambda-var-list (syntax ids)))) (let ((old-ids (lambda-var-list (syntax ids))))
(if (not (valid-bound-ids? old-ids)) (if (not (valid-bound-ids? old-ids))
@ -1304,11 +1328,12 @@
(chi-body (syntax (e1 e2 ...)) (chi-body (syntax (e1 e2 ...))
e e
(extend-var-env labels new-vars r) (extend-var-env labels new-vars r)
(make-binding-wrap old-ids labels w))))))) (make-binding-wrap old-ids labels w)
mod))))))
(_ (syntax-error e))))) (_ (syntax-error e)))))
(define chi-local-syntax (define chi-local-syntax
(lambda (rec? e r w s 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 (syntax (id ...)))) (let ((ids (syntax (id ...))))
@ -1323,16 +1348,19 @@
(trans-r (macros-only-env r))) (trans-r (macros-only-env r)))
(map (lambda (x) (map (lambda (x)
(make-binding 'macro (make-binding 'macro
(eval-local-transformer (chi x trans-r w)))) (eval-local-transformer
(chi x trans-r w mod)
mod)))
(syntax (val ...)))) (syntax (val ...))))
r) r)
new-w new-w
s)))))) s
(_ (syntax-error (source-wrap e w s)))))) mod))))))
(_ (syntax-error (source-wrap e w s mod))))))
(define eval-local-transformer (define eval-local-transformer
(lambda (expanded) (lambda (expanded mod)
(let ((p (local-eval-hook expanded))) (let ((p (local-eval-hook expanded mod)))
(if (procedure? p) (if (procedure? p)
p p
(syntax-error p "nonprocedure transformer"))))) (syntax-error p "nonprocedure transformer")))))
@ -1412,8 +1440,8 @@
(lambda (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) ls) w)) ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w #f) ls) w))
((id? vars) (cons (wrap vars w) ls)) ((id? vars) (cons (wrap vars w #f) ls))
((null? vars) ls) ((null? vars) ls)
((syntax-object? vars) ((syntax-object? vars)
(lvl (syntax-object-expression vars) (lvl (syntax-object-expression vars)
@ -1431,7 +1459,7 @@
(global-extend 'local-syntax 'let-syntax #f) (global-extend 'local-syntax 'let-syntax #f)
(global-extend 'core 'fluid-let-syntax (global-extend 'core 'fluid-let-syntax
(lambda (e r w s) (lambda (e r w s mod)
(syntax-case e () (syntax-case e ()
((_ ((var val) ...) e1 e2 ...) ((_ ((var val) ...) e1 e2 ...)
(valid-bound-ids? (syntax (var ...))) (valid-bound-ids? (syntax (var ...)))
@ -1440,29 +1468,31 @@
(lambda (id n) (lambda (id n)
(case (binding-type (lookup n r)) (case (binding-type (lookup n r))
((displaced-lexical) ((displaced-lexical)
(syntax-error (source-wrap id w s) (syntax-error (source-wrap id w s mod)
"identifier out of context")))) "identifier out of context"))))
(syntax (var ...)) (syntax (var ...))
names) names)
(chi-body (chi-body
(syntax (e1 e2 ...)) (syntax (e1 e2 ...))
(source-wrap e w s) (source-wrap e w s mod)
(extend-env (extend-env
names names
(let ((trans-r (macros-only-env r))) (let ((trans-r (macros-only-env r)))
(map (lambda (x) (map (lambda (x)
(make-binding 'macro (make-binding 'macro
(eval-local-transformer (chi x trans-r w)))) (eval-local-transformer (chi x trans-r w mod)
mod)))
(syntax (val ...)))) (syntax (val ...))))
r) r)
w))) w
(_ (syntax-error (source-wrap e w s)))))) mod)))
(_ (syntax-error (source-wrap e w s mod))))))
(global-extend 'core 'quote (global-extend 'core 'quote
(lambda (e r w s) (lambda (e r w s mod)
(syntax-case e () (syntax-case e ()
((_ e) (build-data s (strip (syntax e) w))) ((_ e) (build-data s (strip (syntax e) w)))
(_ (syntax-error (source-wrap e w s)))))) (_ (syntax-error (source-wrap e w s mod))))))
(global-extend 'core 'syntax (global-extend 'core 'syntax
(let () (let ()
@ -1620,27 +1650,29 @@
(build-primref no-source (car x)) (build-primref no-source (car x))
(map regen (cdr x))))))) (map regen (cdr x)))))))
(lambda (e r w s) (lambda (e r w s mod)
(let ((e (source-wrap e w s))) (let ((e (source-wrap e w s mod)))
(syntax-case e () (syntax-case e ()
((_ x) ((_ x)
(call-with-values (call-with-values
(lambda () (gen-syntax e (syntax x) r '() ellipsis?)) (lambda () (gen-syntax e (syntax x) r '() ellipsis?))
;; It doesn't seem we need `mod' here as `syntax' only
;; references lexical vars and primitives.
(lambda (e maps) (regen e)))) (lambda (e maps) (regen e))))
(_ (syntax-error e))))))) (_ (syntax-error e)))))))
(global-extend 'core 'lambda (global-extend 'core 'lambda
(lambda (e r w s) (lambda (e r w s mod)
(syntax-case e () (syntax-case e ()
((_ . c) ((_ . c)
(chi-lambda-clause (source-wrap e w s) (syntax c) r w (chi-lambda-clause (source-wrap e w s mod) (syntax c) r w mod
(lambda (vars body) (build-lambda s vars body))))))) (lambda (vars body) (build-lambda s vars body)))))))
(global-extend 'core 'let (global-extend 'core 'let
(let () (let ()
(define (chi-let e r w s constructor ids vals exps) (define (chi-let e r w s mod constructor ids vals exps)
(if (not (valid-bound-ids? ids)) (if (not (valid-bound-ids? ids))
(syntax-error e "duplicate bound variable in") (syntax-error e "duplicate bound variable in")
(let ((labels (gen-labels ids)) (let ((labels (gen-labels ids))
@ -1649,28 +1681,29 @@
(nr (extend-var-env labels new-vars r))) (nr (extend-var-env labels new-vars r)))
(constructor s (constructor s
new-vars new-vars
(map (lambda (x) (chi x r w)) vals) (map (lambda (x) (chi x r w mod)) vals)
(chi-body exps (source-wrap e nw s) nr nw)))))) (chi-body exps (source-wrap e nw s mod)
(lambda (e r w s) nr nw mod))))))
(lambda (e r w s mod)
(syntax-case e () (syntax-case e ()
((_ ((id val) ...) e1 e2 ...) ((_ ((id val) ...) e1 e2 ...)
(chi-let e r w s (chi-let e r w s mod
build-let build-let
(syntax (id ...)) (syntax (id ...))
(syntax (val ...)) (syntax (val ...))
(syntax (e1 e2 ...)))) (syntax (e1 e2 ...))))
((_ f ((id val) ...) e1 e2 ...) ((_ f ((id val) ...) e1 e2 ...)
(id? (syntax f)) (id? (syntax f))
(chi-let e r w s (chi-let e r w s mod
build-named-let build-named-let
(syntax (f id ...)) (syntax (f id ...))
(syntax (val ...)) (syntax (val ...))
(syntax (e1 e2 ...)))) (syntax (e1 e2 ...))))
(_ (syntax-error (source-wrap e w s))))))) (_ (syntax-error (source-wrap e w s mod)))))))
(global-extend 'core 'letrec (global-extend 'core 'letrec
(lambda (e r w s) (lambda (e r w s mod)
(syntax-case e () (syntax-case e ()
((_ ((id val) ...) e1 e2 ...) ((_ ((id val) ...) e1 e2 ...)
(let ((ids (syntax (id ...)))) (let ((ids (syntax (id ...))))
@ -1682,33 +1715,34 @@
(r (extend-var-env labels new-vars r))) (r (extend-var-env labels new-vars r)))
(build-letrec s (build-letrec s
new-vars new-vars
(map (lambda (x) (chi x r w)) (syntax (val ...))) (map (lambda (x) (chi x r w mod)) (syntax (val ...)))
(chi-body (syntax (e1 e2 ...)) (source-wrap e w s) r w))))))) (chi-body (syntax (e1 e2 ...))
(_ (syntax-error (source-wrap e w s)))))) (source-wrap e w s mod) r w mod)))))))
(_ (syntax-error (source-wrap e w s mod))))))
(global-extend 'core 'set! (global-extend 'core 'set!
(lambda (e r w s) (lambda (e r w s mod)
(syntax-case e () (syntax-case e ()
((_ id val) ((_ id val)
(id? (syntax id)) (id? (syntax id))
(let ((val (chi (syntax val) r w)) (let ((val (chi (syntax val) r w mod))
(n (id-var-name (syntax id) w))) (n (id-var-name (syntax id) w)))
(let ((b (lookup n r))) (let ((b (lookup n r)))
(case (binding-type b) (case (binding-type b)
((lexical) ((lexical)
(build-lexical-assignment s (binding-value b) val)) (build-lexical-assignment s (binding-value b) val))
((global) (build-global-assignment s n val)) ((global) (build-global-assignment s n val mod))
((displaced-lexical) ((displaced-lexical)
(syntax-error (wrap (syntax id) w) (syntax-error (wrap (syntax id) w #f)
"identifier out of context")) "identifier out of context"))
(else (syntax-error (source-wrap e w s))))))) (else (syntax-error (source-wrap e w s mod)))))))
((_ (getter arg ...) val) ((_ (getter arg ...) val)
(build-application s (build-application s
(chi (syntax (setter getter)) r w) (chi (syntax (setter getter)) r w mod)
(map (lambda (e) (chi e r w)) (map (lambda (e) (chi e r w mod))
(syntax (arg ... val))))) (syntax (arg ... val)))))
(_ (syntax-error (source-wrap e w s)))))) (_ (syntax-error (source-wrap e w s mod))))))
(global-extend 'begin 'begin '()) (global-extend 'begin 'begin '())
@ -1753,25 +1787,26 @@
(x (values (vector 'atom (strip p empty-wrap)) ids))))))) (x (values (vector 'atom (strip p empty-wrap)) ids)))))))
(define build-dispatch-call (define build-dispatch-call
(lambda (pvars exp y r) (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-application no-source (build-application no-source
(build-primref no-source 'apply) (build-primref no-source 'apply)
(list (build-lambda no-source new-vars (list (build-lambda no-source new-vars
(chi exp (chi exp
(extend-env (extend-env
labels labels
(map (lambda (var level) (map (lambda (var level)
(make-binding 'syntax `(,var . ,level))) (make-binding 'syntax `(,var . ,level)))
new-vars new-vars
(map cdr pvars)) (map cdr pvars))
r) r)
(make-binding-wrap ids labels empty-wrap))) (make-binding-wrap ids labels empty-wrap)
mod))
y)))))) y))))))
(define gen-clause (define gen-clause
(lambda (x keys clauses r pat fender exp) (lambda (x keys clauses r pat fender exp mod)
(call-with-values (call-with-values
(lambda () (convert-pattern pat keys)) (lambda () (convert-pattern pat keys))
(lambda (p pvars) (lambda (p pvars)
@ -1793,10 +1828,10 @@
(#t y) (#t y)
(_ (build-conditional no-source (_ (build-conditional no-source
y y
(build-dispatch-call pvars fender y r) (build-dispatch-call pvars fender y r mod)
(build-data no-source #f)))) (build-data no-source #f))))
(build-dispatch-call pvars exp y r) (build-dispatch-call pvars exp y r mod)
(gen-syntax-case x keys clauses r)))) (gen-syntax-case x keys clauses r mod))))
(list (if (eq? p 'any) (list (if (eq? p 'any)
(build-application no-source (build-application no-source
(build-primref no-source 'list) (build-primref no-source 'list)
@ -1806,7 +1841,7 @@
(list x (build-data no-source p))))))))))))) (list x (build-data no-source p)))))))))))))
(define gen-syntax-case (define gen-syntax-case
(lambda (x keys clauses r) (lambda (x keys clauses r mod)
(if (null? clauses) (if (null? clauses)
(build-application no-source (build-application no-source
(build-primref no-source 'syntax-error) (build-primref no-source 'syntax-error)
@ -1825,17 +1860,18 @@
(list (make-binding 'syntax `(,var . 0))) (list (make-binding 'syntax `(,var . 0)))
r) r)
(make-binding-wrap (syntax (pat)) (make-binding-wrap (syntax (pat))
labels empty-wrap))) labels empty-wrap)
mod))
(list x))) (list x)))
(gen-clause x keys (cdr clauses) r (gen-clause x keys (cdr clauses) r
(syntax pat) #t (syntax exp)))) (syntax pat) #t (syntax exp) mod)))
((pat fender exp) ((pat fender exp)
(gen-clause x keys (cdr clauses) r (gen-clause x keys (cdr clauses) r
(syntax pat) (syntax fender) (syntax exp))) (syntax pat) (syntax fender) (syntax exp) mod))
(_ (syntax-error (car clauses) "invalid syntax-case clause")))))) (_ (syntax-error (car clauses) "invalid syntax-case clause"))))))
(lambda (e r w s) (lambda (e r w s mod)
(let ((e (source-wrap e w s))) (let ((e (source-wrap e w s mod)))
(syntax-case e () (syntax-case e ()
((_ val (key ...) m ...) ((_ val (key ...) m ...)
(if (andmap (lambda (x) (and (id? x) (not (ellipsis? x)))) (if (andmap (lambda (x) (and (id? x) (not (ellipsis? x))))
@ -1846,8 +1882,9 @@
(build-lambda no-source (list x) (build-lambda no-source (list x)
(gen-syntax-case (build-lexical-reference 'value no-source x) (gen-syntax-case (build-lexical-reference 'value no-source x)
(syntax (key ...)) (syntax (m ...)) (syntax (key ...)) (syntax (m ...))
r)) r
(list (chi (syntax val) r empty-wrap)))) mod))
(list (chi (syntax val) r empty-wrap mod))))
(syntax-error e "invalid literals list in")))))))) (syntax-error e "invalid literals list in"))))))))
;;; The portable sc-expand seeds chi-top's mode m with 'e (for ;;; The portable sc-expand seeds chi-top's mode m with 'e (for
@ -1864,7 +1901,7 @@
(lambda (x) (lambda (x)
(if (and (pair? x) (equal? (car x) noexpand)) (if (and (pair? x) (equal? (car x) noexpand))
(cadr x) (cadr x)
(chi-top x null-env top-wrap m esew))))) (chi-top x null-env top-wrap m esew (current-module))))))
(set! sc-expand3 (set! sc-expand3
(let ((m 'e) (esew '(eval))) (let ((m 'e) (esew '(eval)))
@ -1877,7 +1914,8 @@
(if (null? rest) m (car rest)) (if (null? rest) m (car rest))
(if (or (null? rest) (null? (cdr rest))) (if (or (null? rest) (null? (cdr rest)))
esew esew
(cadr rest))))))) (cadr rest))
(current-module))))))
(set! identifier? (set! identifier?
(lambda (x) (lambda (x)
@ -1896,7 +1934,7 @@
(set! generate-temporaries (set! generate-temporaries
(lambda (ls) (lambda (ls)
(arg-check list? ls 'generate-temporaries) (arg-check list? ls 'generate-temporaries)
(map (lambda (x) (wrap (gensym-hook) top-wrap)) ls))) (map (lambda (x) (wrap (gensym-hook) top-wrap #f)) ls)))
(set! free-identifier=? (set! free-identifier=?
(lambda (x y) (lambda (x y)
@ -1972,7 +2010,7 @@
(match-each-any (annotation-expression e) w)) (match-each-any (annotation-expression e) w))
((pair? e) ((pair? e)
(let ((l (match-each-any (cdr e) w))) (let ((l (match-each-any (cdr e) w)))
(and l (cons (wrap (car e) w) l)))) (and l (cons (wrap (car e) w #f) l))))
((null? e) '()) ((null? e) '())
((syntax-object? e) ((syntax-object? e)
(match-each-any (syntax-object-expression e) (match-each-any (syntax-object-expression e)
@ -2012,7 +2050,7 @@
(if (null? (car l)) (if (null? (car l))
r r
(cons (map car l) (collect (map cdr l))))))))) (cons (map car l) (collect (map cdr l)))))))))
((free-id) (and (id? e) (free-id=? (wrap e w) (vector-ref p 1)) r)) ((free-id) (and (id? e) (free-id=? (wrap e w #f) (vector-ref p 1)) r))
((atom) (and (equal? (vector-ref p 1) (strip e w)) r)) ((atom) (and (equal? (vector-ref p 1) (strip e w)) r))
((vector) ((vector)
(and (vector? e) (and (vector? e)
@ -2022,7 +2060,7 @@
(lambda (e p w r) (lambda (e p w r)
(cond (cond
((not r) #f) ((not r) #f)
((eq? p 'any) (cons (wrap e w) r)) ((eq? p 'any) (cons (wrap e w #f) r))
((syntax-object? e) ((syntax-object? e)
(match* (match*
(unannotate (syntax-object-expression e)) (unannotate (syntax-object-expression e))

8
module/ice-9/syncase.scm
View file

@ -136,7 +136,7 @@
(define guile-macro (define guile-macro
(cons 'external-macro (cons 'external-macro
(lambda (e r w s) (lambda (e r w s mod)
(let ((e (syntax-object->datum e))) (let ((e (syntax-object->datum e)))
(if (symbol? e) (if (symbol? e)
;; pass the expression through ;; pass the expression through
@ -154,7 +154,7 @@
e e
(if (null? r) (if (null? r)
(sc-expand e) (sc-expand e)
(sc-chi e r w))))))))))) (sc-chi e r w mod)))))))))))
(define generated-symbols (make-weak-key-hash-table 1019)) (define generated-symbols (make-weak-key-hash-table 1019))
@ -208,8 +208,8 @@
(set! old-debug (debug-options)) (set! old-debug (debug-options))
(set! old-read (read-options))) (set! old-read (read-options)))
(lambda () (lambda ()
(debug-disable 'debug 'procnames) (debug-disable 'debug 'procnames)
(read-disable 'positions) (read-disable 'positions)
(load-from-path "ice-9/psyntax-pp")) (load-from-path "ice-9/psyntax-pp"))
(lambda () (lambda ()
(debug-options old-debug) (debug-options old-debug)