summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2012-01-30 18:25:07 +0100
committerAndy Wingo <wingo@pobox.com>2012-01-30 18:25:07 +0100
commit855db1905d56efcdf91ae51a9e80990f79030eae (patch)
tree9c918dba899ddae458147ce1095018fcbdec18b0 /module
parent91ee7515da0bad91330ce5c87b250d6cf12a2789 (diff)
parent9b0975f1dc41ddd10d81fb5b0965b9e9a54ef37a (diff)
downloadguile-855db1905d56efcdf91ae51a9e80990f79030eae.tar.gz
Merge commit '9b0975f1dc41ddd10d81fb5b0965b9e9a54ef37a'
Conflicts: libguile/foreign.c module/ice-9/psyntax-pp.scm module/ice-9/psyntax.scm
Diffstat (limited to 'module')
-rw-r--r--module/ice-9/boot-9.scm5
-rw-r--r--module/ice-9/psyntax.scm44
-rw-r--r--module/language/glil/compile-assembly.scm13
3 files changed, 56 insertions, 6 deletions
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 1de5edf5b..0de5eed60 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -142,7 +142,7 @@ If it exits normally, Guile unwinds the stack and dynamic context
and then calls the normal (third argument) handler. If it exits
non-locally, that exit determines the continuation."
(if (not (or (symbol? k) (eqv? k #t)))
- (scm-error "catch" 'wrong-type-arg
+ (scm-error 'wrong-type-arg "catch"
"Wrong type argument in position ~a: ~a"
(list 1 k) (list k)))
(let ((tag (make-prompt-tag "catch")))
@@ -163,7 +163,7 @@ non-locally, that exit determines the continuation."
"Add @var{handler} to the dynamic context as a throw handler
for key @var{key}, then invoke @var{thunk}."
(if (not (or (symbol? k) (eqv? k #t)))
- (scm-error "with-throw-handler" 'wrong-type-arg
+ (scm-error 'wrong-type-arg "with-throw-handler"
"Wrong type argument in position ~a: ~a"
(list 1 k) (list k)))
(with-fluids ((%exception-handler
@@ -389,6 +389,7 @@ If there is no handler at all, Guile prints an error and then exits."
(define generate-temporaries #f)
(define bound-identifier=? #f)
(define free-identifier=? #f)
+(define syntax-local-binding #f)
;; $sc-dispatch is an implementation detail of psyntax. It is used by
;; expanded macros, to dispatch an input against a set of patterns.
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index d96c3cf5a..1c6a95111 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -850,6 +850,14 @@
(else
(error "unexpected id-var-name" id w n)))))
+ (define transformer-environment
+ (make-fluid
+ (lambda (k)
+ (error "called outside the dynamic extent of a syntax transformer"))))
+
+ (define (with-transformer-environment k)
+ ((fluid-ref transformer-environment) k))
+
;; 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.
@@ -1423,8 +1431,10 @@
(syntax-violation #f "encountered raw symbol in macro output"
(source-wrap e w (wrap-subst w) mod) x))
(else (decorate-source x s)))))
- (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod))
- (new-mark))))
+ (with-fluids ((transformer-environment
+ (lambda (k) (k e r w s rib mod))))
+ (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod))
+ (new-mark)))))
(define expand-body
;; In processing the forms of the body, we create a new, empty wrap.
@@ -2541,6 +2551,36 @@
(set! syntax-source
(lambda (x) (source-annotation x)))
+ (set! syntax-local-binding
+ (lambda (id)
+ (arg-check nonsymbol-id? id 'syntax-local-value)
+ (with-transformer-environment
+ (lambda (e r w s rib mod)
+ (define (strip-anti-mark w)
+ (let ((ms (wrap-marks w)) (s (wrap-subst w)))
+ (if (and (pair? ms) (eq? (car ms) the-anti-mark))
+ ;; output is from original text
+ (make-wrap (cdr ms) (if rib (cons rib (cdr s)) (cdr s)))
+ ;; output introduced by macro
+ (make-wrap ms (if rib (cons rib s) s)))))
+ (call-with-values (lambda ()
+ (resolve-identifier
+ (syntax-object-expression id)
+ (strip-anti-mark (syntax-object-wrap id))
+ r
+ (syntax-object-module id)
+ ;; FIXME: come up with a better policy for
+ ;; resolve-syntax-parameters
+ #t))
+ (lambda (type value mod)
+ (case type
+ ((lexical) (values 'lexical value))
+ ((macro) (values 'macro value))
+ ((syntax) (values 'pattern-variable value))
+ ((displaced-lexical) (values 'displaced-lexical #f))
+ ((global) (values 'global (cons value mod)))
+ (else (values 'other #f)))))))))
+
(set! generate-temporaries
(lambda (ls)
(arg-check list? ls 'generate-temporaries)
diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm
index c76e41225..a51fd580a 100644
--- a/module/language/glil/compile-assembly.scm
+++ b/module/language/glil/compile-assembly.scm
@@ -103,6 +103,15 @@
(define (immediate? x)
(object->assembly x))
+;; This tests for a proper scheme list whose last cdr is '(), not #nil.
+;;
+(define (scheme-list? x)
+ (and (list? x)
+ (or (eq? x '())
+ (let ((p (last-pair x)))
+ (and (pair? p)
+ (eq? (cdr p) '()))))))
+
;; Note: in all of these procedures that build up constant tables, the
;; first (zeroth) index is reserved. At runtime it is replaced with the
;; procedure's module. Hence all of this 1+ length business.
@@ -733,7 +742,7 @@
((keyword? x)
`(,@(dump-object (keyword->symbol x) addr)
(make-keyword)))
- ((list? x)
+ ((scheme-list? x)
(let ((tail (let ((len (length x)))
(if (>= len 65536) (too-long "list"))
`((list ,(quotient len 256) ,(modulo len 256))))))
@@ -815,7 +824,7 @@
(values code (addr+ addr code))))
((variable-cache-cell? x)
(dump1 (variable-cache-cell-key x) i addr))
- ((list? x)
+ ((scheme-list? x)
(receive (codes addr)
(fold2 (lambda (x codes addr)
(receive (subcode addr) (ref-or-dump x i addr)