guile-commits
[Top][All Lists]
Advanced

[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)



reply via email to

[Prev in Thread] Current Thread [Next in Thread]