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

only bend hygiene in macro-introduced output, not for explicit @/@@

Browse source 
* 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 2009-04-24 13:13:29 +02:00
parent 384e92b3ae
commit a2716cbe1e
3 changed files with 50 additions and 49 deletions
Download patch file Download diff file Expand all files Collapse all files

22
module/ice-9/boot-9.scm
View file

@ -132,15 +132,19 @@
(define (module-add! module sym var) (define (module-add! module sym var)
(hashq-set! (%get-pre-modules-obarray) sym var)) (hashq-set! (%get-pre-modules-obarray) sym var))
(define sc-macro 'sc-macro) (define sc-macro 'sc-macro)
(define (make-module-ref mod var public?) (define (make-module-ref mod var kind)
(cond (case kind
((or (not mod) ((public #t) (if mod `(@ ,mod ,var) var))
(equal? mod (module-name (current-module))) ((private #f) (if (and mod (not (equal? mod (module-name (current-module)))))
(and (not public?) `(@@ ,mod ,var)
(not (module-variable (resolve-module mod) var)))) var))
var) ((bare) var)
(else ((hygiene) (if (and mod
(list (if public? '@ '@@) mod var)))) (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) (define (resolve-module . args)
#f) #f)

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

File diff suppressed because one or more lines are too long

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

@ -320,13 +320,11 @@
(define top-level-eval-hook (define top-level-eval-hook
(lambda (x mod) (lambda (x mod)
(eval `(,noexpand ,x) (if mod (resolve-module mod) (primitive-eval `(,noexpand ,x))))
(interaction-environment)))))
(define local-eval-hook (define local-eval-hook
(lambda (x mod) (lambda (x mod)
(eval `(,noexpand ,x) (if mod (resolve-module mod) (primitive-eval `(,noexpand ,x))))
(interaction-environment)))))
(define error-hook (define error-hook
(lambda (who why what) (lambda (who why what)
@ -337,10 +335,8 @@
((_) (gensym)))) ((_) (gensym))))
(define put-global-definition-hook (define put-global-definition-hook
(lambda (symbol binding modname) (lambda (symbol binding)
(let* ((module (if modname (let* ((module (current-module))
(resolve-module modname)
(current-module)))
(v (or (module-variable module symbol) (v (or (module-variable module symbol)
(let ((v (make-variable (gensym)))) (let ((v (make-variable (gensym))))
(module-add! module symbol v) (module-add! module symbol v)
@ -351,10 +347,8 @@
(set-object-property! v '*sc-expander* binding)))) (set-object-property! v '*sc-expander* binding))))
(define remove-global-definition-hook (define remove-global-definition-hook
(lambda (symbol modname) (lambda (symbol)
(let* ((module (if modname (let* ((module (current-module))
(resolve-module modname)
(current-module)))
(v (module-local-variable module symbol))) (v (module-local-variable module symbol)))
(if v (if v
(let ((p (assq '*sc-expander* (object-properties v)))) (let ((p (assq '*sc-expander* (object-properties v))))
@ -363,7 +357,9 @@
(define get-global-definition-hook (define get-global-definition-hook
(lambda (symbol module) (lambda (symbol module)
(let* ((module (if 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))) (let ((mod (current-module)))
(if mod (warn "wha" symbol)) (if mod (warn "wha" symbol))
mod))) mod)))
@ -406,19 +402,21 @@
(define-syntax build-global-reference (define-syntax build-global-reference
(syntax-rules () (syntax-rules ()
((_ source var mod) ((_ source var mod)
(cond (build-annotated
((and mod (not (car mod))) source
(build-annotated source (make-module-ref (cdr mod) var #t))) (cond ((not mod) (make-module-ref mod var 'bare))
(else ((not (car mod)) (make-module-ref (cdr mod) var 'public))
(build-annotated source (make-module-ref mod var #f))))))) ((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 (define-syntax build-global-assignment
(syntax-rules () (syntax-rules ()
((_ source var exp mod) ((_ source var exp mod)
(build-annotated source (build-annotated source
`(set! ,(cond `(set! ,(cond ((not mod) (make-module-ref mod var 'bare))
((and mod (not (car mod))) (make-module-ref (cdr mod) var #t)) ((not (car mod)) (make-module-ref (cdr mod) var 'public))
(else (make-module-ref mod var #f))) ((memq (car mod) '(bare public private hygiene)) (make-module-ref (cdr mod) var (car mod)))
(else (make-module-ref mod var 'private)))
,exp))))) ,exp)))))
(define-syntax build-global-definition (define-syntax build-global-definition
@ -608,8 +606,7 @@
(define global-extend (define global-extend
(lambda (type sym val) (lambda (type sym val)
(put-global-definition-hook sym (make-binding type val) (put-global-definition-hook sym (make-binding type val))))
(module-name (current-module)))))
;;; Conceptually, identifiers are always syntax objects. Internally, ;;; Conceptually, identifiers are always syntax objects. Internally,
@ -1123,7 +1120,7 @@
((displaced-lexical) ((displaced-lexical)
(syntax-error (wrap value w mod) "identifier out of context")) (syntax-error (wrap value w mod) "identifier out of context"))
((core macro module-ref) ((core macro module-ref)
(remove-global-definition-hook n mod) (remove-global-definition-hook n)
(eval-if-c&e m (eval-if-c&e m
(build-global-definition s n (chi e r w mod) mod) (build-global-definition s n (chi e r w mod) mod)
mod)) mod))
@ -1217,7 +1214,7 @@
(if rib (if rib
(cons rib (cons 'shift s)) (cons rib (cons 'shift s))
(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) ((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)))
@ -1812,7 +1809,7 @@
(and (andmap id? (syntax (mod ...))) (id? (syntax id))) (and (andmap id? (syntax (mod ...))) (id? (syntax id)))
(values (syntax-object->datum (syntax id)) (values (syntax-object->datum (syntax id))
(syntax-object->datum (syntax-object->datum
(syntax (#f mod ...)))))))) (syntax (public mod ...))))))))
(global-extend 'module-ref '@@ (global-extend 'module-ref '@@
(lambda (e) (lambda (e)
@ -1821,7 +1818,7 @@
(and (andmap id? (syntax (mod ...))) (id? (syntax id))) (and (andmap id? (syntax (mod ...))) (id? (syntax id)))
(values (syntax-object->datum (syntax id)) (values (syntax-object->datum (syntax id))
(syntax-object->datum (syntax-object->datum
(syntax (mod ...)))))))) (syntax (private mod ...))))))))
(global-extend 'begin 'begin '()) (global-extend 'begin 'begin '())
@ -1981,7 +1978,7 @@
(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
(module-name (current-module))))))) (cons 'hygiene (module-name (current-module))))))))
(set! sc-expand3 (set! sc-expand3
(let ((m 'e) (esew '(eval))) (let ((m 'e) (esew '(eval)))
@ -1995,7 +1992,7 @@
(if (or (null? rest) (null? (cdr rest))) (if (or (null? rest) (null? (cdr rest)))
esew esew
(cadr rest)) (cadr rest))
(module-name (current-module))))))) (cons 'hygiene (module-name (current-module))))))))
(set! identifier? (set! identifier?
(lambda (x) (lambda (x)