[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 05/12: psyntax: Clean up use of fx+, etc
From: |
Andy Wingo |
Subject: |
[Guile-commits] 05/12: psyntax: Clean up use of fx+, etc |
Date: |
Fri, 15 Nov 2024 10:25:31 -0500 (EST) |
wingo pushed a commit to branch main
in repository guile.
commit f376e6445d11cf16acc658806038567b35856d8a
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Thu Nov 14 16:10:40 2024 +0100
psyntax: Clean up use of fx+, etc
* module/ice-9/psyntax.scm (fx+, fx-, fx=): Remove. Replace uses with
1+, 1-, =.
* module/ice-9/psyntax-pp.scm: Regenerate.
---
module/ice-9/psyntax-pp.scm | 130 +++++++++++++++++++++-----------------------
module/ice-9/psyntax.scm | 49 ++++++-----------
2 files changed, 81 insertions(+), 98 deletions(-)
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 (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 (top-level-eval x mod)
+ (primitive-eval x))
+
+ (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))))
- [Guile-commits] branch main updated (bb7154fb8 -> 2daea4020), Andy Wingo, 2024/11/15
- [Guile-commits] 05/12: psyntax: Clean up use of fx+, etc,
Andy Wingo <=
- [Guile-commits] 06/12: psyntax: Functional annotation of function names, Andy Wingo, 2024/11/15
- [Guile-commits] 10/12: psyntax: Add simple pattern matcher, Andy Wingo, 2024/11/15
- [Guile-commits] 04/12: psyntax: Rename top-level-eval, local-eval, Andy Wingo, 2024/11/15
- [Guile-commits] 07/12: psyntax: Inline the single use of define-structure, Andy Wingo, 2024/11/15
- [Guile-commits] 08/12: psyntax: Remove a useless level of let, Andy Wingo, 2024/11/15
- [Guile-commits] 12/12: psyntax: Use new `match' instead of cdadring, Andy Wingo, 2024/11/15
- [Guile-commits] 11/12: psyntax: Use new `match' instead of cdadring, Andy Wingo, 2024/11/15
- [Guile-commits] 09/12: psyntax: Avoid lambda in procedure definitions, Andy Wingo, 2024/11/15
- [Guile-commits] 01/12: psyntax: Clean up lexical gensym creation, Andy Wingo, 2024/11/15
- [Guile-commits] 03/12: psyntax: Use vectors instead of gensyms for labels, marks, Andy Wingo, 2024/11/15