[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 06/12: psyntax: Functional annotation of function names
From: |
Andy Wingo |
Subject: |
[Guile-commits] 06/12: psyntax: Functional annotation of function names |
Date: |
Fri, 15 Nov 2024 10:25:31 -0500 (EST) |
wingo pushed a commit to branch main
in repository guile.
commit 8c78234e80d6af41bc0935ceb16b7326a8384341
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Thu Nov 14 16:45:29 2024 +0100
psyntax: Functional annotation of function names
* module/ice-9/psyntax.scm (maybe-name-value): Return a fresh lambda
instead of mutating the given lambda.
(define-expansion-accessors): No need to define setters.
---
module/ice-9/psyntax-pp.scm | 108 +++++++++++++++++++++-----------------------
module/ice-9/psyntax.scm | 98 ++++++++++++++++++++--------------------
2 files changed, 100 insertions(+), 106 deletions(-)
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index e2e122310..db706dfe5 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -43,8 +43,9 @@
(lambda (src in-order? names gensyms vals body)
(make-struct/simple (vector-ref %expanded-vtables 17) src
in-order? names gensyms vals body)))
(lambda? (lambda (x) (and (struct? x) (eq? (struct-vtable x)
(vector-ref %expanded-vtables 14)))))
+ (lambda-src (lambda (x) (struct-ref x 0)))
(lambda-meta (lambda (x) (struct-ref x 1)))
- (set-lambda-meta! (lambda (x v) (struct-set! x 1 v)))
+ (lambda-body (lambda (x) (struct-ref x 2)))
(top-level-eval (lambda (x mod) (primitive-eval x)))
(local-eval (lambda (x mod) (primitive-eval x)))
(sourcev-filename (lambda (s) (vector-ref s 0)))
@@ -58,18 +59,19 @@
'filename
(sourcev-filename sourcev)
(list (cons 'line (sourcev-line sourcev)) (cons 'column
(sourcev-column sourcev))))))))
- (maybe-name-value!
+ (maybe-name-value
(lambda (name val)
(if (lambda? val)
(let ((meta (lambda-meta val)))
- (if (not (assq 'name meta)) (set-lambda-meta! val (acons
'name name meta)))))))
+ (if (assq 'name meta) val (make-lambda (lambda-src val)
(acons 'name name meta) (lambda-body val))))
+ val)))
(build-void (lambda (sourcev) (make-void sourcev)))
(build-call (lambda (sourcev fun-exp arg-exps) (make-call sourcev
fun-exp arg-exps)))
(build-conditional
(lambda (sourcev test-exp then-exp else-exp) (make-conditional
sourcev test-exp then-exp else-exp)))
(build-lexical-reference (lambda (type sourcev name var)
(make-lexical-ref sourcev name var)))
(build-lexical-assignment
- (lambda (sourcev name var exp) (maybe-name-value! name exp)
(make-lexical-set sourcev name var exp)))
+ (lambda (sourcev name var exp) (make-lexical-set sourcev name var
(maybe-name-value name exp))))
(analyze-variable
(lambda (mod var modref-cont bare-cont)
(if (not mod)
@@ -92,16 +94,15 @@
(lambda (mod var) (make-toplevel-ref sourcev mod var)))))
(build-global-assignment
(lambda (sourcev var exp mod)
- (maybe-name-value! var exp)
- (analyze-variable
- mod
- var
- (lambda (mod var public?) (make-module-set sourcev mod var
public? exp))
- (lambda (mod var) (make-toplevel-set sourcev mod var exp)))))
+ (let ((exp (maybe-name-value var exp)))
+ (analyze-variable
+ mod
+ var
+ (lambda (mod var public?) (make-module-set sourcev mod var
public? exp))
+ (lambda (mod var) (make-toplevel-set sourcev mod var
exp))))))
(build-global-definition
(lambda (sourcev mod var exp)
- (maybe-name-value! var exp)
- (make-toplevel-define sourcev (and mod (cdr mod)) var exp)))
+ (make-toplevel-define sourcev (and mod (cdr mod)) var
(maybe-name-value var exp))))
(build-simple-lambda
(lambda (src req rest vars meta exp)
(make-lambda src meta (make-lambda-case src req #f rest #f '()
vars exp #f))))
@@ -117,28 +118,24 @@
(if (null? (cdr exps)) (car exps) (make-seq src (car exps)
(build-sequence #f (cdr exps))))))
(build-let
(lambda (src ids vars val-exps body-exp)
- (for-each maybe-name-value! ids val-exps)
- (if (null? vars) body-exp (make-let src ids vars val-exps
body-exp))))
+ (let ((val-exps (map maybe-name-value ids val-exps)))
+ (if (null? vars) body-exp (make-let src ids vars val-exps
body-exp)))))
(build-named-let
(lambda (src ids vars val-exps body-exp)
(let ((f (car vars)) (f-name (car ids)) (vars (cdr vars)) (ids
(cdr ids)))
(let ((proc (build-simple-lambda src ids #f vars '()
body-exp)))
- (maybe-name-value! f-name proc)
- (for-each maybe-name-value! ids val-exps)
(make-letrec
src
#f
(list f-name)
(list f)
- (list proc)
- (build-call src (build-lexical-reference 'fun src f-name
f) val-exps))))))
+ (list (maybe-name-value f-name proc))
+ (build-call src (build-lexical-reference 'fun src f-name
f) (map maybe-name-value ids val-exps)))))))
(build-letrec
(lambda (src in-order? ids vars val-exps body-exp)
(if (null? vars)
body-exp
- (begin
- (for-each maybe-name-value! ids val-exps)
- (make-letrec src in-order? ids vars val-exps body-exp)))))
+ (make-letrec src in-order? ids vars (map maybe-name-value
ids val-exps) body-exp))))
(gen-lexical (lambda (id) (module-gensym (symbol->string id))))
(datum-sourcev
(lambda (datum)
@@ -798,11 +795,11 @@
(source-wrap e w (cdr w) mod)
x))
(else (decorate-source x))))))
- (let* ((t-680b775fb37a463-dac transformer-environment)
- (t-680b775fb37a463-dad (lambda (k) (k e r w s rib
mod))))
+ (let* ((t-680b775fb37a463-db0 transformer-environment)
+ (t-680b775fb37a463-db1 (lambda (k) (k e r w s rib
mod))))
(with-fluid*
- t-680b775fb37a463-dac
- t-680b775fb37a463-dad
+ t-680b775fb37a463-db0
+ t-680b775fb37a463-db1
(lambda () (rebuild-macro-output (p (source-wrap e
(anti-mark w) s mod)) (new-mark))))))))
(expand-body
(lambda (body outer-form r w mod)
@@ -1332,11 +1329,11 @@
s
mod
get-formals
- (map (lambda
(tmp-680b775fb37a463-2
-
tmp-680b775fb37a463-1
-
tmp-680b775fb37a463)
- (cons
tmp-680b775fb37a463
- (cons
tmp-680b775fb37a463-1 tmp-680b775fb37a463-2)))
+ (map (lambda
(tmp-680b775fb37a463-102c
+
tmp-680b775fb37a463-102b
+
tmp-680b775fb37a463-102a)
+ (cons
tmp-680b775fb37a463-102a
+ (cons
tmp-680b775fb37a463-102b tmp-680b775fb37a463-102c)))
e2*
e1*
args*)))
@@ -2446,11 +2443,8 @@
#f
k
(list docstring)
- (map (lambda (tmp-680b775fb37a463-115d
- tmp-680b775fb37a463-115c
- tmp-680b775fb37a463-115b)
- (list (cons tmp-680b775fb37a463-115b
tmp-680b775fb37a463-115c)
- tmp-680b775fb37a463-115d))
+ (map (lambda (tmp-680b775fb37a463-1
tmp-680b775fb37a463 tmp-680b775fb37a463-115f)
+ (list (cons tmp-680b775fb37a463-115f
tmp-680b775fb37a463) tmp-680b775fb37a463-1))
template
pattern
keyword)))
@@ -2462,9 +2456,9 @@
dots
k
'()
- (map (lambda (tmp-680b775fb37a463-2
tmp-680b775fb37a463-1 tmp-680b775fb37a463)
+ (map (lambda (tmp-680b775fb37a463-117a
tmp-680b775fb37a463-1 tmp-680b775fb37a463)
(list (cons tmp-680b775fb37a463
tmp-680b775fb37a463-1)
- tmp-680b775fb37a463-2))
+ tmp-680b775fb37a463-117a))
template
pattern
keyword)))
@@ -2639,9 +2633,9 @@
(apply
(lambda (p)
(if (= lev 0)
(quasiappend
-
(map (lambda (tmp-680b775fb37a463)
+
(map (lambda (tmp-680b775fb37a463-124b)
(list "value"
-
tmp-680b775fb37a463))
+
tmp-680b775fb37a463-124b))
p)
(quasi q lev))
(quasicons
@@ -2677,8 +2671,8 @@
(apply (lambda (p)
(if (= lev 0)
(quasilist*
- (map (lambda
(tmp-680b775fb37a463-125d)
- (list "value"
tmp-680b775fb37a463-125d))
+ (map (lambda
(tmp-680b775fb37a463)
+ (list "value"
tmp-680b775fb37a463))
p)
(vquasi q lev))
(quasicons
@@ -2781,8 +2775,8 @@
(let ((tmp-1 ls))
(let ((tmp ($sc-dispatch tmp-1
'each-any)))
(if tmp
- (apply (lambda
(t-680b775fb37a463-12ab)
- (cons "vector"
t-680b775fb37a463-12ab))
+ (apply (lambda
(t-680b775fb37a463-12af)
+ (cons "vector"
t-680b775fb37a463-12af))
tmp)
(syntax-violation
#f
@@ -2792,8 +2786,8 @@
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote")
each-any))))
(if tmp-1
(apply (lambda (y)
- (k (map (lambda
(tmp-680b775fb37a463-12b7)
- (list "quote"
tmp-680b775fb37a463-12b7))
+ (k (map (lambda
(tmp-680b775fb37a463-12bb)
+ (list "quote"
tmp-680b775fb37a463-12bb))
y)))
tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(#(atom
"list") . each-any))))
@@ -2804,8 +2798,8 @@
(apply (lambda (y z) (f z
(lambda (ls) (k (append y ls))))) tmp-1)
(let ((else tmp))
(let ((tmp x))
- (let
((t-680b775fb37a463-12c6 tmp))
- (list "list->vector"
t-680b775fb37a463-12c6)))))))))))))))))
+ (let
((t-680b775fb37a463-12ca tmp))
+ (list "list->vector"
t-680b775fb37a463-12ca)))))))))))))))))
(emit (lambda (x)
(let ((tmp x))
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote")
any))))
@@ -2817,9 +2811,9 @@
(let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1
'each-any)))
(if tmp
- (apply (lambda
(t-680b775fb37a463-12d5)
+ (apply (lambda
(t-680b775fb37a463-12d9)
(cons
(make-syntax 'list '((top)) '(hygiene guile))
-
t-680b775fb37a463-12d5))
+
t-680b775fb37a463-12d9))
tmp)
(syntax-violation
#f
@@ -2835,14 +2829,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-12e9
-
t-680b775fb37a463-12e8)
+ (apply
(lambda (t-680b775fb37a463-12ed
+
t-680b775fb37a463-12ec)
(list (make-syntax
'cons
'((top))
'(hygiene guile))
-
t-680b775fb37a463-12e9
-
t-680b775fb37a463-12e8))
+
t-680b775fb37a463-12ed
+
t-680b775fb37a463-12ec))
tmp)
(syntax-violation
#f
@@ -2855,12 +2849,12 @@
(let ((tmp-1 (map
emit x)))
(let ((tmp
($sc-dispatch tmp-1 'each-any)))
(if tmp
- (apply
(lambda (t-680b775fb37a463-12f5)
+ (apply
(lambda (t-680b775fb37a463-12f9)
(cons (make-syntax
'append
'((top))
'(hygiene guile))
-
t-680b775fb37a463-12f5))
+
t-680b775fb37a463-12f9))
tmp)
(syntax-violation
#f
@@ -2889,12 +2883,12 @@
(if tmp-1
(apply (lambda (x)
(let
((tmp (emit x)))
- (let
((t-680b775fb37a463-130d tmp))
+ (let
((t-680b775fb37a463 tmp))
(list (make-syntax
'list->vector
'((top))
'(hygiene guile))
-
t-680b775fb37a463-130d))))
+
t-680b775fb37a463))))
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 7e0558e9c..9e4a978d0 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -100,29 +100,28 @@
(lambda (x)
(syntax-case x ()
((_ stem field ...)
- (let lp ((n 0))
- (let ((vtable (vector-ref %expanded-vtables n))
- (stem (syntax->datum #'stem)))
- (if (eq? (struct-ref vtable (+ vtable-offset-user 0)) stem)
- #`(begin
- (define (#,(datum->syntax x (symbol-append stem '?)) x)
- (and (struct? x)
- (eq? (struct-vtable x)
- (vector-ref %expanded-vtables #,n))))
- #,@(map
- (lambda (f)
- (let ((get (datum->syntax x (symbol-append stem '-
f)))
- (set (datum->syntax x (symbol-append 'set-
stem '- f '!)))
- (idx (list-index (struct-ref vtable
- (+
vtable-offset-user 2))
- f)))
- #`(begin
- (define (#,get x)
- (struct-ref x #,idx))
- (define (#,set x v)
- (struct-set! x #,idx v)))))
- (syntax->datum #'(field ...))))
- (lp (1+ n)))))))))
+ (let ((stem (syntax->datum #'stem))
+ (fields (map syntax->datum #'(field ...))))
+ (let lp ((n 0))
+ (let ((vtable (vector-ref %expanded-vtables n)))
+ (if (eq? (struct-ref vtable (+ vtable-offset-user 0)) stem)
+ (let ((pred (datum->syntax x (symbol-append stem '?)))
+ (all-fields (struct-ref vtable (+ vtable-offset-user
2))))
+ #`(begin
+ (define (#,pred x)
+ (and (struct? x)
+ (eq? (struct-vtable x)
+ (vector-ref %expanded-vtables #,n))))
+ #,@(map
+ (lambda (f)
+ (define get
+ (datum->syntax x (symbol-append stem '- f)))
+ (define idx
+ (list-index all-fields f))
+ #`(define (#,get x)
+ (struct-ref x #,idx)))
+ fields)))
+ (lp (1+ n))))))))))
(define-syntax define-structure
(lambda (x)
@@ -177,7 +176,7 @@
(let ()
(define-expansion-constructors)
- (define-expansion-accessors lambda meta)
+ (define-expansion-accessors lambda src meta body)
(define (top-level-eval x mod)
(primitive-eval x))
@@ -195,11 +194,15 @@
`((line . ,(sourcev-line sourcev))
(column . ,(sourcev-column sourcev))))))
- (define (maybe-name-value! name val)
+ (define (maybe-name-value name val)
(if (lambda? val)
(let ((meta (lambda-meta val)))
- (if (not (assq 'name meta))
- (set-lambda-meta! val (acons 'name name meta))))))
+ (if (assq 'name meta)
+ val
+ (make-lambda (lambda-src val)
+ (acons 'name name meta)
+ (lambda-body val))))
+ val))
;; output constructors
(define build-void
@@ -220,8 +223,7 @@
(define build-lexical-assignment
(lambda (sourcev name var exp)
- (maybe-name-value! name exp)
- (make-lexical-set sourcev name var exp)))
+ (make-lexical-set sourcev name var (maybe-name-value name exp))))
(define (analyze-variable mod var modref-cont bare-cont)
(if (not mod)
@@ -249,18 +251,18 @@
(define build-global-assignment
(lambda (sourcev var exp mod)
- (maybe-name-value! var exp)
- (analyze-variable
- mod var
- (lambda (mod var public?)
- (make-module-set sourcev mod var public? exp))
- (lambda (mod var)
- (make-toplevel-set sourcev mod var exp)))))
+ (let ((exp (maybe-name-value var exp)))
+ (analyze-variable
+ mod var
+ (lambda (mod var public?)
+ (make-module-set sourcev mod var public? exp))
+ (lambda (mod var)
+ (make-toplevel-set sourcev mod var exp))))))
(define build-global-definition
(lambda (sourcev mod var exp)
- (maybe-name-value! var exp)
- (make-toplevel-define sourcev (and mod (cdr mod)) var exp)))
+ (make-toplevel-define sourcev (and mod (cdr mod)) var
+ (maybe-name-value var exp))))
(define build-simple-lambda
(lambda (src req rest vars meta exp)
@@ -308,10 +310,10 @@
(define build-let
(lambda (src ids vars val-exps body-exp)
- (for-each maybe-name-value! ids val-exps)
- (if (null? vars)
- body-exp
- (make-let src ids vars val-exps body-exp))))
+ (let ((val-exps (map maybe-name-value ids val-exps)))
+ (if (null? vars)
+ body-exp
+ (make-let src ids vars val-exps body-exp)))))
(define build-named-let
(lambda (src ids vars val-exps body-exp)
@@ -320,21 +322,19 @@
(vars (cdr vars))
(ids (cdr ids)))
(let ((proc (build-simple-lambda src ids #f vars '() body-exp)))
- (maybe-name-value! f-name proc)
- (for-each maybe-name-value! ids val-exps)
(make-letrec
src #f
- (list f-name) (list f) (list proc)
+ (list f-name) (list f) (list (maybe-name-value f-name proc))
(build-call src (build-lexical-reference 'fun src f-name f)
- val-exps))))))
+ (map maybe-name-value ids val-exps)))))))
(define build-letrec
(lambda (src in-order? ids vars val-exps body-exp)
(if (null? vars)
body-exp
- (begin
- (for-each maybe-name-value! ids val-exps)
- (make-letrec src in-order? ids vars val-exps body-exp)))))
+ (make-letrec src in-order? ids vars
+ (map maybe-name-value ids val-exps)
+ body-exp))))
(define (gen-lexical id)
- [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, 2024/11/15
- [Guile-commits] 06/12: psyntax: Functional annotation of function names,
Andy Wingo <=
- [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
- [Guile-commits] 02/12: psyntax: Remove useless gen-label invocations, Andy Wingo, 2024/11/15