mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-01 04:10:18 +02:00
only bend hygiene in macro-introduced output, not for explicit @/@@
* module/ice-9/psyntax.scm
* module/ice-9/psyntax-pp.scm
* module/ice-9/boot-9.scm (make-module-ref): We were so almost there
with what we had, sniff. The deal is that
(begin (load "foo.scm") ((@@ (foo) bar)))
would expand to
(begin (load "foo.scm") (bar))
because bar was unbound at expansion time, and make-module-ref assumed
it was like the else in a cond. But it shouldn't have, because we
/explicitly/ asked for the @@ var -- so now if we see a @ or @@, we
never drop it. @@ introduced by hygiene can be dropped if it doesn't
reference a var, though.
Practically speaking, this means tagging all modules in psyntax with
their intent: public or private (corresponding to @ or @@), hygiene
(introduced by a macro), or bare (when we don't have a module). I'm
not sure when we'd see a bare.
The implementation is complicated by the need to support the old
format and the new format at the same time, so that psyntax-pp can be
regenerated.
This commit is contained in:
Andy Wingo
parent
384e92b3ae
commit
a2716cbe1e
3 changed files with 50 additions and 49 deletions
|
|
@ -132,15 +132,19 @@
|
|||
(define (module-add! module sym var)
|
||||
(hashq-set! (%get-pre-modules-obarray) sym var))
|
||||
(define sc-macro 'sc-macro)
|
||||
(define (make-module-ref mod var public?)
|
||||
(cond
|
||||
((or (not mod)
|
||||
(equal? mod (module-name (current-module)))
|
||||
(and (not public?)
|
||||
(not (module-variable (resolve-module mod) var))))
|
||||
var)
|
||||
(else
|
||||
(list (if public? '@ '@@) mod var))))
|
||||
(define (make-module-ref mod var kind)
|
||||
(case kind
|
||||
((public #t) (if mod `(@ ,mod ,var) var))
|
||||
((private #f) (if (and mod (not (equal? mod (module-name (current-module)))))
|
||||
`(@@ ,mod ,var)
|
||||
var))
|
||||
((bare) var)
|
||||
((hygiene) (if (and mod
|
||||
(not (equal? mod (module-name (current-module))))
|
||||
(module-variable (resolve-module mod) var))
|
||||
`(@@ ,mod ,var)
|
||||
var))
|
||||
(else (error "foo" mod var kind))))
|
||||
(define (resolve-module . args)
|
||||
#f)
|
||||
|
||||
|
|
|
|||
File diff suppressed because one or more lines are too long
|
|
@ -320,13 +320,11 @@
|
|||
|
||||
(define top-level-eval-hook
|
||||
(lambda (x mod)
|
||||
(eval `(,noexpand ,x) (if mod (resolve-module mod)
|
||||
(interaction-environment)))))
|
||||
(primitive-eval `(,noexpand ,x))))
|
||||
|
||||
(define local-eval-hook
|
||||
(lambda (x mod)
|
||||
(eval `(,noexpand ,x) (if mod (resolve-module mod)
|
||||
(interaction-environment)))))
|
||||
(primitive-eval `(,noexpand ,x))))
|
||||
|
||||
(define error-hook
|
||||
(lambda (who why what)
|
||||
|
|
@ -337,10 +335,8 @@
|
|||
((_) (gensym))))
|
||||
|
||||
(define put-global-definition-hook
|
||||
(lambda (symbol binding modname)
|
||||
(let* ((module (if modname
|
||||
(resolve-module modname)
|
||||
(current-module)))
|
||||
(lambda (symbol binding)
|
||||
(let* ((module (current-module))
|
||||
(v (or (module-variable module symbol)
|
||||
(let ((v (make-variable (gensym))))
|
||||
(module-add! module symbol v)
|
||||
|
|
@ -351,10 +347,8 @@
|
|||
(set-object-property! v '*sc-expander* binding))))
|
||||
|
||||
(define remove-global-definition-hook
|
||||
(lambda (symbol modname)
|
||||
(let* ((module (if modname
|
||||
(resolve-module modname)
|
||||
(current-module)))
|
||||
(lambda (symbol)
|
||||
(let* ((module (current-module))
|
||||
(v (module-local-variable module symbol)))
|
||||
(if v
|
||||
(let ((p (assq '*sc-expander* (object-properties v))))
|
||||
|
|
@ -363,7 +357,9 @@
|
|||
(define get-global-definition-hook
|
||||
(lambda (symbol module)
|
||||
(let* ((module (if module
|
||||
(resolve-module module)
|
||||
(resolve-module (if (memq (car module) '(#f hygiene public private bare))
|
||||
(cdr module)
|
||||
module))
|
||||
(let ((mod (current-module)))
|
||||
(if mod (warn "wha" symbol))
|
||||
mod)))
|
||||
|
|
@ -406,19 +402,21 @@
|
|||
(define-syntax build-global-reference
|
||||
(syntax-rules ()
|
||||
((_ source var mod)
|
||||
(cond
|
||||
((and mod (not (car mod)))
|
||||
(build-annotated source (make-module-ref (cdr mod) var #t)))
|
||||
(else
|
||||
(build-annotated source (make-module-ref mod var #f)))))))
|
||||
(build-annotated
|
||||
source
|
||||
(cond ((not mod) (make-module-ref mod var 'bare))
|
||||
((not (car mod)) (make-module-ref (cdr mod) var 'public))
|
||||
((memq (car mod) '(bare public private hygiene)) (make-module-ref (cdr mod) var (car mod)))
|
||||
(else (make-module-ref mod var 'private)))))))
|
||||
|
||||
(define-syntax build-global-assignment
|
||||
(syntax-rules ()
|
||||
((_ source var exp mod)
|
||||
(build-annotated source
|
||||
`(set! ,(cond
|
||||
((and mod (not (car mod))) (make-module-ref (cdr mod) var #t))
|
||||
(else (make-module-ref mod var #f)))
|
||||
`(set! ,(cond ((not mod) (make-module-ref mod var 'bare))
|
||||
((not (car mod)) (make-module-ref (cdr mod) var 'public))
|
||||
((memq (car mod) '(bare public private hygiene)) (make-module-ref (cdr mod) var (car mod)))
|
||||
(else (make-module-ref mod var 'private)))
|
||||
,exp)))))
|
||||
|
||||
(define-syntax build-global-definition
|
||||
|
|
@ -608,8 +606,7 @@
|
|||
|
||||
(define global-extend
|
||||
(lambda (type sym val)
|
||||
(put-global-definition-hook sym (make-binding type val)
|
||||
(module-name (current-module)))))
|
||||
(put-global-definition-hook sym (make-binding type val))))
|
||||
|
||||
|
||||
;;; Conceptually, identifiers are always syntax objects. Internally,
|
||||
|
|
@ -1123,7 +1120,7 @@
|
|||
((displaced-lexical)
|
||||
(syntax-error (wrap value w mod) "identifier out of context"))
|
||||
((core macro module-ref)
|
||||
(remove-global-definition-hook n mod)
|
||||
(remove-global-definition-hook n)
|
||||
(eval-if-c&e m
|
||||
(build-global-definition s n (chi e r w mod) mod)
|
||||
mod))
|
||||
|
|
@ -1217,7 +1214,7 @@
|
|||
(if rib
|
||||
(cons rib (cons 'shift s))
|
||||
(cons 'shift s)))
|
||||
(module-name (procedure-module p))))))) ;; hither the hygiene
|
||||
(cons 'hygiene (module-name (procedure-module p)))))))) ;; hither the hygiene
|
||||
((vector? x)
|
||||
(let* ((n (vector-length x)) (v (make-vector n)))
|
||||
(do ((i 0 (fx+ i 1)))
|
||||
|
|
@ -1812,7 +1809,7 @@
|
|||
(and (andmap id? (syntax (mod ...))) (id? (syntax id)))
|
||||
(values (syntax-object->datum (syntax id))
|
||||
(syntax-object->datum
|
||||
(syntax (#f mod ...))))))))
|
||||
(syntax (public mod ...))))))))
|
||||
|
||||
(global-extend 'module-ref '@@
|
||||
(lambda (e)
|
||||
|
|
@ -1821,7 +1818,7 @@
|
|||
(and (andmap id? (syntax (mod ...))) (id? (syntax id)))
|
||||
(values (syntax-object->datum (syntax id))
|
||||
(syntax-object->datum
|
||||
(syntax (mod ...))))))))
|
||||
(syntax (private mod ...))))))))
|
||||
|
||||
(global-extend 'begin 'begin '())
|
||||
|
||||
|
|
@ -1981,7 +1978,7 @@
|
|||
(if (and (pair? x) (equal? (car x) noexpand))
|
||||
(cadr x)
|
||||
(chi-top x null-env top-wrap m esew
|
||||
(module-name (current-module)))))))
|
||||
(cons 'hygiene (module-name (current-module))))))))
|
||||
|
||||
(set! sc-expand3
|
||||
(let ((m 'e) (esew '(eval)))
|
||||
|
|
@ -1995,7 +1992,7 @@
|
|||
(if (or (null? rest) (null? (cdr rest)))
|
||||
esew
|
||||
(cadr rest))
|
||||
(module-name (current-module)))))))
|
||||
(cons 'hygiene (module-name (current-module))))))))
|
||||
|
||||
(set! identifier?
|
||||
(lambda (x)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue