diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 0798331f6..e2e122310 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -47,8 +47,6 @@ (set-lambda-meta! (lambda (x v) (struct-set! x 1 v))) (top-level-eval (lambda (x mod) (primitive-eval x))) (local-eval (lambda (x mod) (primitive-eval x))) - (session-id - (let ((v (module-variable (current-module) 'syntax-session-id))) (lambda () ((variable-ref v))))) (sourcev-filename (lambda (s) (vector-ref s 0))) (sourcev-line (lambda (s) (vector-ref s 1))) (sourcev-column (lambda (s) (vector-ref s 2))) @@ -210,7 +208,7 @@ (lambda (symname marks) (vector-set! symnamevec i symname) (vector-set! marksvec i marks) - (f (cdr ids) (+ i 1)))))) + (f (cdr ids) (#{1+}# i)))))) (make-ribcage symnamevec marksvec labelvec))) (cdr w)))))) (smart-append (lambda (m1 m2) (if (null? m2) m1 (append m1 m2)))) @@ -262,9 +260,9 @@ (same-marks? marks (vector-ref (ribcage-marks ribcage) i))) (let ((n (vector-ref (ribcage-labels ribcage) i))) (if (pair? n) - (if (equal? mod (car n)) (values (cdr n) marks) (f (+ i 1))) + (if (equal? mod (car n)) (values (cdr n) marks) (f (#{1+}# i))) (values n marks)))) - (else (f (+ i 1))))))))) + (else (f (#{1+}# i))))))))) (cond ((symbol? id) (or (search id (cdr w) (car w) mod) id)) ((syntax? id) @@ -300,7 +298,7 @@ (let f ((i 0) (results results)) (if (= i n) (scan (cdr subst) results) - (f (+ i 1) + (f (#{1+}# i) (cons (wrap (vector-ref symnames i) (anti-mark (cons (vector-ref marks i) subst)) mod) @@ -791,7 +789,7 @@ (begin (if #f #f) v) (begin (vector-set! v i (rebuild-macro-output (vector-ref x i) m)) - (loop (+ i 1))))) + (loop (#{1+}# i))))) (decorate-source v))) ((symbol? x) (syntax-violation @@ -800,11 +798,11 @@ (source-wrap e w (cdr w) mod) x)) (else (decorate-source x)))))) - (let* ((t-680b775fb37a463-df3 transformer-environment) - (t-680b775fb37a463-df4 (lambda (k) (k e r w s rib mod)))) + (let* ((t-680b775fb37a463-dac transformer-environment) + (t-680b775fb37a463-dad (lambda (k) (k e r w s rib mod)))) (with-fluid* - t-680b775fb37a463-df3 - t-680b775fb37a463-df4 + t-680b775fb37a463-dac + t-680b775fb37a463-dad (lambda () (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod)) (new-mark)))))))) (expand-body (lambda (body outer-form r w mod) @@ -1334,11 +1332,11 @@ s mod get-formals - (map (lambda (tmp-680b775fb37a463-1 - tmp-680b775fb37a463 - tmp-680b775fb37a463-106f) - (cons tmp-680b775fb37a463-106f - (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1))) + (map (lambda (tmp-680b775fb37a463-2 + tmp-680b775fb37a463-1 + tmp-680b775fb37a463) + (cons tmp-680b775fb37a463 + (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2))) e2* e1* args*))) @@ -1500,7 +1498,7 @@ ((= level 0) (values var maps)) ((null? maps) (syntax-violation 'syntax "missing ellipsis" src)) (else (call-with-values - (lambda () (gen-ref src var (- level 1) (cdr maps))) + (lambda () (gen-ref src var (#{1-}# level) (cdr maps))) (lambda (outer-var outer-maps) (let ((b (assq outer-var (car maps)))) (if b @@ -1606,8 +1604,8 @@ (apply (lambda (args e1 e2) (build-it '() - (map (lambda (tmp-680b775fb37a463-6b4 tmp-680b775fb37a463-6b3 tmp-680b775fb37a463-6b2) - (cons tmp-680b775fb37a463-6b2 (cons tmp-680b775fb37a463-6b3 tmp-680b775fb37a463-6b4))) + (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) + (cons tmp-680b775fb37a463 (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2))) e2 e1 args))) @@ -1617,9 +1615,9 @@ (apply (lambda (docstring args e1 e2) (build-it (list (cons 'documentation (syntax->datum docstring))) - (map (lambda (tmp-680b775fb37a463-6ca tmp-680b775fb37a463-6c9 tmp-680b775fb37a463-6c8) - (cons tmp-680b775fb37a463-6c8 - (cons tmp-680b775fb37a463-6c9 tmp-680b775fb37a463-6ca))) + (map (lambda (tmp-680b775fb37a463-68d tmp-680b775fb37a463-68c tmp-680b775fb37a463-68b) + (cons tmp-680b775fb37a463-68b + (cons tmp-680b775fb37a463-68c tmp-680b775fb37a463-68d))) e2 e1 args))) @@ -1639,8 +1637,8 @@ (apply (lambda (args e1 e2) (build-it '() - (map (lambda (tmp-680b775fb37a463-67e tmp-680b775fb37a463-67d tmp-680b775fb37a463-67c) - (cons tmp-680b775fb37a463-67c (cons tmp-680b775fb37a463-67d tmp-680b775fb37a463-67e))) + (map (lambda (tmp-680b775fb37a463-1 tmp-680b775fb37a463 tmp-680b775fb37a463-63f) + (cons tmp-680b775fb37a463-63f (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1))) e2 e1 args))) @@ -1829,7 +1827,7 @@ (let loop ((i 0)) (if (= i n) (begin (if #f #f) v) - (begin (vector-set! v i (remodulate (vector-ref x i) mod)) (loop (+ i 1))))))) + (begin (vector-set! v i (remodulate (vector-ref x i) mod)) (loop (#{1+}# i))))))) (else x))))) (let* ((tmp e) (tmp-1 ($sc-dispatch @@ -1914,7 +1912,7 @@ (if (and tmp-1 (apply (lambda (x dots) (ellipsis? dots)) tmp-1)) (apply (lambda (x dots) (call-with-values - (lambda () (cvt x (+ n 1) ids)) + (lambda () (cvt x (#{1+}# n) ids)) (lambda (p ids) (values (if (eq? p 'any) 'each-any (vector 'each p)) ids)))) tmp-1) @@ -2432,9 +2430,8 @@ #f k '() - (map (lambda (tmp-680b775fb37a463-118d tmp-680b775fb37a463-118c tmp-680b775fb37a463-118b) - (list (cons tmp-680b775fb37a463-118b tmp-680b775fb37a463-118c) - tmp-680b775fb37a463-118d)) + (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) + (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) tmp-680b775fb37a463-2)) template pattern keyword))) @@ -2449,11 +2446,11 @@ #f k (list docstring) - (map (lambda (tmp-680b775fb37a463-11a6 - tmp-680b775fb37a463-11a5 - tmp-680b775fb37a463-11a4) - (list (cons tmp-680b775fb37a463-11a4 tmp-680b775fb37a463-11a5) - tmp-680b775fb37a463-11a6)) + (map (lambda (tmp-680b775fb37a463-115d + tmp-680b775fb37a463-115c + tmp-680b775fb37a463-115b) + (list (cons tmp-680b775fb37a463-115b tmp-680b775fb37a463-115c) + tmp-680b775fb37a463-115d)) template pattern keyword))) @@ -2465,11 +2462,9 @@ dots k '() - (map (lambda (tmp-680b775fb37a463-11bf - tmp-680b775fb37a463-11be - tmp-680b775fb37a463-11bd) - (list (cons tmp-680b775fb37a463-11bd tmp-680b775fb37a463-11be) - tmp-680b775fb37a463-11bf)) + (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) + (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) + tmp-680b775fb37a463-2)) template pattern keyword))) @@ -2485,11 +2480,11 @@ dots k (list docstring) - (map (lambda (tmp-680b775fb37a463-11de - tmp-680b775fb37a463-11dd - tmp-680b775fb37a463-11dc) - (list (cons tmp-680b775fb37a463-11dc tmp-680b775fb37a463-11dd) - tmp-680b775fb37a463-11de)) + (map (lambda (tmp-680b775fb37a463-2 + tmp-680b775fb37a463-1 + tmp-680b775fb37a463) + (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) + tmp-680b775fb37a463-2)) template pattern keyword))) @@ -2617,9 +2612,8 @@ (apply (lambda (p) (if (= lev 0) (quasilist* - (map (lambda (tmp-680b775fb37a463-128b) - (list "value" - tmp-680b775fb37a463-128b)) + (map (lambda (tmp-680b775fb37a463) + (list "value" tmp-680b775fb37a463)) p) (quasi q lev)) (quasicons @@ -2683,8 +2677,8 @@ (apply (lambda (p) (if (= lev 0) (quasilist* - (map (lambda (tmp-680b775fb37a463-12a6) - (list "value" tmp-680b775fb37a463-12a6)) + (map (lambda (tmp-680b775fb37a463-125d) + (list "value" tmp-680b775fb37a463-125d)) p) (vquasi q lev)) (quasicons @@ -2704,8 +2698,8 @@ (apply (lambda (p) (if (= lev 0) (quasiappend - (map (lambda (tmp-680b775fb37a463-12ab) - (list "value" tmp-680b775fb37a463-12ab)) + (map (lambda (tmp-680b775fb37a463) + (list "value" tmp-680b775fb37a463)) p) (vquasi q lev)) (quasicons @@ -2787,8 +2781,8 @@ (let ((tmp-1 ls)) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t-680b775fb37a463-12f4) - (cons "vector" t-680b775fb37a463-12f4)) + (apply (lambda (t-680b775fb37a463-12ab) + (cons "vector" t-680b775fb37a463-12ab)) tmp) (syntax-violation #f @@ -2798,7 +2792,8 @@ (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any)))) (if tmp-1 (apply (lambda (y) - (k (map (lambda (tmp-680b775fb37a463) (list "quote" tmp-680b775fb37a463)) + (k (map (lambda (tmp-680b775fb37a463-12b7) + (list "quote" tmp-680b775fb37a463-12b7)) y))) tmp-1) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any)))) @@ -2809,8 +2804,8 @@ (apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1) (let ((else tmp)) (let ((tmp x)) - (let ((t-680b775fb37a463-130f tmp)) - (list "list->vector" t-680b775fb37a463-130f))))))))))))))))) + (let ((t-680b775fb37a463-12c6 tmp)) + (list "list->vector" t-680b775fb37a463-12c6))))))))))))))))) (emit (lambda (x) (let ((tmp x)) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any)))) @@ -2822,9 +2817,9 @@ (let ((tmp-1 (map emit x))) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t-680b775fb37a463-131e) + (apply (lambda (t-680b775fb37a463-12d5) (cons (make-syntax 'list '((top)) '(hygiene guile)) - t-680b775fb37a463-131e)) + t-680b775fb37a463-12d5)) tmp) (syntax-violation #f @@ -2840,13 +2835,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-12e9 + t-680b775fb37a463-12e8) (list (make-syntax 'cons '((top)) '(hygiene guile)) - t-680b775fb37a463-1 - t-680b775fb37a463)) + t-680b775fb37a463-12e9 + t-680b775fb37a463-12e8)) tmp) (syntax-violation #f @@ -2859,12 +2855,12 @@ (let ((tmp-1 (map emit x))) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t-680b775fb37a463-133e) + (apply (lambda (t-680b775fb37a463-12f5) (cons (make-syntax 'append '((top)) '(hygiene guile)) - t-680b775fb37a463-133e)) + t-680b775fb37a463-12f5)) tmp) (syntax-violation #f @@ -2877,12 +2873,12 @@ (let ((tmp-1 (map emit x))) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t-680b775fb37a463-134a) + (apply (lambda (t-680b775fb37a463) (cons (make-syntax 'vector '((top)) '(hygiene guile)) - t-680b775fb37a463-134a)) + t-680b775fb37a463)) tmp) (syntax-violation #f @@ -2893,12 +2889,12 @@ (if tmp-1 (apply (lambda (x) (let ((tmp (emit x))) - (let ((t-680b775fb37a463 tmp)) + (let ((t-680b775fb37a463-130d tmp)) (list (make-syntax 'list->vector '((top)) '(hygiene guile)) - t-680b775fb37a463)))) + t-680b775fb37a463-130d)))) tmp-1) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any)))) (if tmp-1 diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 843a99607..7e0558e9c 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -179,24 +179,11 @@ (define-expansion-constructors) (define-expansion-accessors lambda meta) - ;; hooks to nonportable run-time helpers - (begin - (define-syntax fx+ (identifier-syntax +)) - (define-syntax fx- (identifier-syntax -)) - (define-syntax fx= (identifier-syntax =)) - (define-syntax fx< (identifier-syntax <)) + (define (top-level-eval x mod) + (primitive-eval x)) - (define (top-level-eval x mod) - (primitive-eval x)) - - (define (local-eval x mod) - (primitive-eval x)) - - ;; Capture syntax-session-id before we shove it off into a module. - (define session-id - (let ((v (module-variable (current-module) 'syntax-session-id))) - (lambda () - ((variable-ref v)))))) + (define (local-eval x mod) + (primitive-eval x)) (define (sourcev-filename s) (vector-ref s 0)) (define (sourcev-line s) (vector-ref s 1)) @@ -618,7 +605,7 @@ (lambda (symname marks) (vector-set! symnamevec i symname) (vector-set! marksvec i marks) - (f (cdr ids) (fx+ i 1)))))) + (f (cdr ids) (1+ i)))))) (make-ribcage symnamevec marksvec labelvec)))) (wrap-subst w)))))) @@ -713,16 +700,16 @@ (let ((n (vector-length symnames))) (let f ((i 0)) (cond - ((fx= i n) (search sym (cdr subst) marks mod)) + ((= i n) (search sym (cdr subst) marks mod)) ((and (eq? (vector-ref symnames i) sym) (same-marks? marks (vector-ref (ribcage-marks ribcage) i))) (let ((n (vector-ref (ribcage-labels ribcage) i))) (if (pair? n) (if (equal? mod (car n)) (values (cdr n) marks) - (f (fx+ i 1))) + (f (1+ i))) (values n marks)))) - (else (f (fx+ i 1)))))))) + (else (f (1+ i)))))))) (cond ((symbol? id) (or (first (search id (wrap-subst w) (wrap-marks w) mod)) id)) @@ -778,9 +765,9 @@ (lambda (subst symnames marks results) (let ((n (vector-length symnames))) (let f ((i 0) (results results)) - (if (fx= i n) + (if (= i n) (scan (cdr subst) results) - (f (fx+ i 1) + (f (1+ i) (cons (wrap (vector-ref symnames i) (anti-mark (make-wrap (vector-ref marks i) subst)) mod) @@ -1515,8 +1502,8 @@ ((vector? x) (let* ((n (vector-length x)) (v (make-vector n))) - (do ((i 0 (fx+ i 1))) - ((fx= i n) v) + (do ((i 0 (1+ i))) + ((= i n) v) (vector-set! v i (rebuild-macro-output (vector-ref x i) m))) (decorate-source v))) @@ -2138,12 +2125,12 @@ (define gen-ref (lambda (src var level maps) - (if (fx= level 0) + (if (= level 0) (values var maps) (if (null? maps) (syntax-violation 'syntax "missing ellipsis" src) (call-with-values - (lambda () (gen-ref src var (fx- level 1) (cdr maps))) + (lambda () (gen-ref src var (1- level) (cdr maps))) (lambda (outer-var outer-maps) (let ((b (assq outer-var (car maps)))) (if b @@ -2467,8 +2454,8 @@ (syntax-sourcev x))) ((vector? x) (let* ((n (vector-length x)) (v (make-vector n))) - (do ((i 0 (fx+ i 1))) - ((fx= i n) v) + (do ((i 0 (1+ i))) + ((= i n) v) (vector-set! v i (remodulate (vector-ref x i) mod))))) (else x)))) (syntax-case e (@@ primitive) @@ -2563,7 +2550,7 @@ ((x dots) (ellipsis? (syntax dots)) (call-with-values - (lambda () (cvt (syntax x) (fx+ n 1) ids)) + (lambda () (cvt (syntax x) (1+ n) ids)) (lambda (p ids) (values (if (eq? p 'any) 'each-any (vector 'each p)) ids))))