diff options
Diffstat (limited to 'module/ice-9/psyntax-pp.scm')
-rw-r--r-- | module/ice-9/psyntax-pp.scm | 153 |
1 files changed, 61 insertions, 92 deletions
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index d5b428d8c..687d1f6cf 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -5,8 +5,7 @@ (make-syntax (module-ref (current-module) 'make-syntax)) (syntax-expression (module-ref (current-module) 'syntax-expression)) (syntax-wrap (module-ref (current-module) 'syntax-wrap)) - (syntax-module (module-ref (current-module) 'syntax-module)) - (syntax-sourcev (module-ref (current-module) 'syntax-sourcev))) + (syntax-module (module-ref (current-module) 'syntax-module))) (letrec* ((make-void (lambda (src) (make-struct/simple (vector-ref %expanded-vtables 0) src))) (make-const (lambda (src exp) (make-struct/simple (vector-ref %expanded-vtables 1) src exp))) (make-primitive-ref (lambda (src name) (make-struct/simple (vector-ref %expanded-vtables 2) src name))) @@ -177,11 +176,7 @@ (if (null? v) body-exp (fk))))) (gen-lexical (lambda (id) (module-gensym (symbol->string id)))) (no-source #f) - (datum-sourcev - (lambda (datum) - (let ((props (source-properties datum))) - (and (pair? props) (vector (assq-ref props 'filename) (assq-ref props 'line) (assq-ref props 'column)))))) - (source-annotation (lambda (x) (if (syntax? x) (syntax-sourcev x) (datum-sourcev x)))) + (source-annotation (lambda (x) (and (syntax? x) (syntax-source x)))) (binding-type (lambda (x) (car x))) (binding-value (lambda (x) (cdr x))) (null-env '()) @@ -667,8 +662,7 @@ (if (null? v) #f (fk))))) (wrap (lambda (x w defmod) (source-wrap x w #f defmod))) (wrap-syntax - (lambda (x w defmod) - (make-syntax (syntax-expression x) w (or (syntax-module x) defmod) (syntax-sourcev x)))) + (lambda (x w defmod) (make-syntax (syntax-expression x) w (or (syntax-module x) defmod) (syntax-source x)))) (source-wrap (lambda (x w s defmod) (cond @@ -1141,11 +1135,11 @@ (source-wrap e w (wrap-subst w) mod) x)) (else (decorate-source x)))))) - (let* ((t-680b775fb37a463-c45 transformer-environment) - (t-680b775fb37a463-c46 (lambda (k) (k e r w s rib mod)))) + (let* ((t-680b775fb37a463-c30 transformer-environment) + (t-680b775fb37a463-c31 (lambda (k) (k e r w s rib mod)))) (with-fluid* - t-680b775fb37a463-c45 - t-680b775fb37a463-c46 + t-680b775fb37a463-c30 + t-680b775fb37a463-c31 (lambda () (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod)) (new-mark)))))))) (expand-body (lambda (body outer-form r w mod) @@ -1676,11 +1670,11 @@ s mod get-formals - (map (lambda (tmp-680b775fb37a463-ece - tmp-680b775fb37a463-ecd - tmp-680b775fb37a463-ecc) - (cons tmp-680b775fb37a463-ecc - (cons tmp-680b775fb37a463-ecd tmp-680b775fb37a463-ece))) + (map (lambda (tmp-680b775fb37a463-eb9 + tmp-680b775fb37a463-eb8 + tmp-680b775fb37a463-eb7) + (cons tmp-680b775fb37a463-eb7 + (cons tmp-680b775fb37a463-eb8 tmp-680b775fb37a463-eb9))) e2* e1* args*))) @@ -1691,17 +1685,11 @@ tmp-1) (syntax-violation #f "source expression failed to match any pattern" tmp)))))))) (strip (lambda (x) - (letrec* ((annotate - (lambda (proc datum) - (let ((s (proc x))) - (if (and s (supports-source-properties? datum)) - (set-source-properties! datum (sourcev->alist s))) - datum)))) - (cond - ((syntax? x) (annotate syntax-sourcev (strip (syntax-expression x)))) - ((pair? x) (cons (strip (car x)) (strip (cdr x)))) - ((vector? x) (list->vector (strip (vector->list x)))) - (else x))))) + (cond + ((syntax? x) (strip (syntax-expression x))) + ((pair? x) (cons (strip (car x)) (strip (cdr x)))) + ((vector? x) (list->vector (strip (vector->list x)))) + (else x)))) (gen-var (lambda (id) (let ((id (if (syntax? id) (syntax-expression id) id))) (gen-lexical id)))) (lambda-var-list (lambda (vars) @@ -1995,11 +1983,11 @@ (apply (lambda (docstring args e1 e2) (build-it (list (cons 'documentation (syntax->datum docstring))) - (map (lambda (tmp-680b775fb37a463-117f - tmp-680b775fb37a463-117e - tmp-680b775fb37a463-117d) - (cons tmp-680b775fb37a463-117d - (cons tmp-680b775fb37a463-117e tmp-680b775fb37a463-117f))) + (map (lambda (tmp-680b775fb37a463-115f + tmp-680b775fb37a463-115e + tmp-680b775fb37a463-115d) + (cons tmp-680b775fb37a463-115d + (cons tmp-680b775fb37a463-115e tmp-680b775fb37a463-115f))) e2 e1 args))) @@ -2016,7 +2004,7 @@ '#{ $sc-ellipsis }# (syntax-wrap dots) (syntax-module dots) - (syntax-sourcev dots))))) + (syntax-source dots))))) (let ((ids (list id)) (labels (list (gen-label))) (bindings (list (cons 'ellipsis (source-wrap dots w s mod))))) @@ -2166,7 +2154,7 @@ (remodulate (syntax-expression x) mod) (syntax-wrap x) mod - (syntax-sourcev x))) + (syntax-source x))) ((vector? x) (let* ((n (vector-length x)) (v (make-vector n))) (let loop ((i 0)) @@ -2449,27 +2437,7 @@ (global-extend 'core 'syntax-case expand-syntax-case) (set! macroexpand (lambda* (x #:optional (m 'e) (esew '(eval))) - (letrec* ((unstrip - (lambda (x) - (letrec* ((annotate - (lambda (result) - (let ((props (source-properties x))) - (if (pair? props) (datum->syntax #f result #:source props) result))))) - (cond - ((pair? x) (annotate (cons (unstrip (car x)) (unstrip (cdr x))))) - ((vector? x) - (let ((v (make-vector (vector-length x)))) - (annotate (list->vector (map unstrip (vector->list x)))))) - ((syntax? x) x) - (else (annotate x))))))) - (expand-top-sequence - (list (unstrip x)) - null-env - top-wrap - #f - m - esew - (cons 'hygiene (module-name (current-module))))))) + (expand-top-sequence (list x) null-env top-wrap #f m esew (cons 'hygiene (module-name (current-module)))))) (set! identifier? (lambda (x) (nonsymbol-id? x))) (set! datum->syntax (lambda* (id datum #:key (source #f #:source)) @@ -2482,10 +2450,10 @@ (if id (syntax-wrap id) empty-wrap) (and id (syntax-module id)) (cond - ((not source) (props->sourcev (source-properties datum))) + ((not source) #f) ((and (list? source) (and-map pair? source)) (props->sourcev source)) ((and (vector? source) (= 3 (vector-length source))) source) - (else (syntax-sourcev source))))))) + (else (syntax-source source))))))) (set! syntax->datum (lambda (x) (strip x))) (set! generate-temporaries (lambda (ls) @@ -2822,9 +2790,9 @@ #f k '() - (map (lambda (tmp-680b775fb37a463-145d tmp-680b775fb37a463-145c tmp-680b775fb37a463-145b) - (list (cons tmp-680b775fb37a463-145b tmp-680b775fb37a463-145c) - tmp-680b775fb37a463-145d)) + (map (lambda (tmp-680b775fb37a463-143d tmp-680b775fb37a463-143c tmp-680b775fb37a463-143b) + (list (cons tmp-680b775fb37a463-143b tmp-680b775fb37a463-143c) + tmp-680b775fb37a463-143d)) template pattern keyword))) @@ -2852,11 +2820,11 @@ dots k '() - (map (lambda (tmp-680b775fb37a463-148f - tmp-680b775fb37a463-148e - tmp-680b775fb37a463-148d) - (list (cons tmp-680b775fb37a463-148d tmp-680b775fb37a463-148e) - tmp-680b775fb37a463-148f)) + (map (lambda (tmp-680b775fb37a463-146f + tmp-680b775fb37a463-146e + tmp-680b775fb37a463-146d) + (list (cons tmp-680b775fb37a463-146d tmp-680b775fb37a463-146e) + tmp-680b775fb37a463-146f)) template pattern keyword))) @@ -2872,11 +2840,11 @@ dots k (list docstring) - (map (lambda (tmp-680b775fb37a463-14ae - tmp-680b775fb37a463-14ad - tmp-680b775fb37a463-14ac) - (list (cons tmp-680b775fb37a463-14ac tmp-680b775fb37a463-14ad) - tmp-680b775fb37a463-14ae)) + (map (lambda (tmp-680b775fb37a463-148e + tmp-680b775fb37a463-148d + tmp-680b775fb37a463-148c) + (list (cons tmp-680b775fb37a463-148c tmp-680b775fb37a463-148d) + tmp-680b775fb37a463-148e)) template pattern keyword))) @@ -3004,9 +2972,9 @@ (apply (lambda (p) (if (= lev 0) (quasilist* - (map (lambda (tmp-680b775fb37a463-155b) + (map (lambda (tmp-680b775fb37a463-153b) (list "value" - tmp-680b775fb37a463-155b)) + tmp-680b775fb37a463-153b)) p) (quasi q lev)) (quasicons @@ -3091,8 +3059,8 @@ (apply (lambda (p) (if (= lev 0) (quasiappend - (map (lambda (tmp-680b775fb37a463-157b) - (list "value" tmp-680b775fb37a463-157b)) + (map (lambda (tmp-680b775fb37a463-155b) + (list "value" tmp-680b775fb37a463-155b)) p) (vquasi q lev)) (quasicons @@ -3174,8 +3142,8 @@ (let ((tmp-1 ls)) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t-680b775fb37a463-15c4) - (cons "vector" t-680b775fb37a463-15c4)) + (apply (lambda (t-680b775fb37a463-15a4) + (cons "vector" t-680b775fb37a463-15a4)) tmp) (syntax-violation #f @@ -3185,8 +3153,8 @@ (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any)))) (if tmp-1 (apply (lambda (y) - (k (map (lambda (tmp-680b775fb37a463-15d0) - (list "quote" tmp-680b775fb37a463-15d0)) + (k (map (lambda (tmp-680b775fb37a463-15b0) + (list "quote" tmp-680b775fb37a463-15b0)) y))) tmp-1) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any)))) @@ -3197,8 +3165,8 @@ (apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1) (let ((else tmp)) (let ((tmp x)) - (let ((t-680b775fb37a463-15df tmp)) - (list "list->vector" t-680b775fb37a463-15df))))))))))))))))) + (let ((t-680b775fb37a463-15bf tmp)) + (list "list->vector" t-680b775fb37a463-15bf))))))))))))))))) (emit (lambda (x) (let ((tmp x)) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any)))) @@ -3210,9 +3178,9 @@ (let ((tmp-1 (map emit x))) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t-680b775fb37a463-15ee) + (apply (lambda (t-680b775fb37a463-15ce) (cons (make-syntax 'list '((top)) '(hygiene guile)) - t-680b775fb37a463-15ee)) + t-680b775fb37a463-15ce)) tmp) (syntax-violation #f @@ -3228,13 +3196,14 @@ (let ((tmp-1 (list (emit (car x*)) (f (cdr x*))))) (let ((tmp ($sc-dispatch tmp-1 '(any any)))) (if tmp - (apply (lambda (t-680b775fb37a463-1 t-680b775fb37a463) + (apply (lambda (t-680b775fb37a463-15e2 + t-680b775fb37a463-15e1) (list (make-syntax 'cons '((top)) '(hygiene guile)) - t-680b775fb37a463-1 - t-680b775fb37a463)) + t-680b775fb37a463-15e2 + t-680b775fb37a463-15e1)) tmp) (syntax-violation #f @@ -3247,12 +3216,12 @@ (let ((tmp-1 (map emit x))) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t-680b775fb37a463-160e) + (apply (lambda (t-680b775fb37a463-15ee) (cons (make-syntax 'append '((top)) '(hygiene guile)) - t-680b775fb37a463-160e)) + t-680b775fb37a463-15ee)) tmp) (syntax-violation #f @@ -3265,12 +3234,12 @@ (let ((tmp-1 (map emit x))) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t-680b775fb37a463-161a) + (apply (lambda (t-680b775fb37a463-15fa) (cons (make-syntax 'vector '((top)) '(hygiene guile)) - t-680b775fb37a463-161a)) + t-680b775fb37a463-15fa)) tmp) (syntax-violation #f @@ -3305,7 +3274,7 @@ (define call-with-include-port (let ((syntax-dirname (lambda (stx) - (letrec* ((src (syntax-source stx)) (filename (if src (assq-ref src 'filename) #f))) + (letrec* ((src (syntax-source stx)) (filename (if src (vector-ref src 0) #f))) (if (string? filename) (dirname filename) #f))))) (lambda* (filename proc #:key (dirname (syntax-dirname filename) #:dirname)) "Like @code{call-with-input-file}, except relative paths are\nsearched relative to the @var{dirname} instead of the current working\ndirectory. Also, @var{filename} can be a syntax object; in that case,\nand if @var{dirname} is not specified, the @code{syntax-source} of\n@var{filename} is used to obtain a base directory for relative file\nnames." |