diff options
Diffstat (limited to 'module')
-rw-r--r-- | module/ice-9/boot-9.scm | 5 | ||||
-rw-r--r-- | module/ice-9/psyntax.scm | 44 | ||||
-rw-r--r-- | module/language/glil/compile-assembly.scm | 13 |
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) |