guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.5-153-g4eaf6


From: Andy Wingo
Subject: [Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.5-153-g4eaf64c
Date: Tue, 15 May 2012 15:38:17 +0000

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=4eaf64cd462ef7730e17299e60f578100ff9c032

The branch, stable-2.0 has been updated
       via  4eaf64cd462ef7730e17299e60f578100ff9c032 (commit)
       via  63216d80def079922016fc9084c0ee57af3af383 (commit)
       via  83bd53abb697dd9597f3b78e13e74344b0b676e6 (commit)
       via  86e4479abb89d26840d6ba3afe9df611fbeb4b98 (commit)
       via  dc1ee62046c130c6b26a96ca862663406ecbc7b1 (commit)
      from  9b1750ed4250c6ad3bcf764b4d2bdeec6ca2c79e (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 4eaf64cd462ef7730e17299e60f578100ff9c032
Author: Andy Wingo <address@hidden>
Date:   Tue May 15 17:37:57 2012 +0200

    fix the cse tests
    
    * test-suite/tests/cse.test (pass-if-cse): Fix-letrec and canonicalize
      the output, so that unreferenced failure continuations get trimmed.
      ("cse"): Fix the two tests regarding bailout info.

commit 63216d80def079922016fc9084c0ee57af3af383
Author: Andy Wingo <address@hidden>
Date:   Tue May 15 17:23:06 2012 +0200

    cse passes a lookup procedure to the effects analyzer
    
    * module/language/tree-il/cse.scm (cse): Arrange to pass a lookup
      procedure to compute-effects, for better effects analysis.

commit 83bd53abb697dd9597f3b78e13e74344b0b676e6
Author: Andy Wingo <address@hidden>
Date:   Tue May 15 17:22:05 2012 +0200

    better effects analysis for calls to lexically bound procedures
    
    * module/language/tree-il/effects.scm (make-effects-analyzer): The
      analyzer will take an optional second argument, a lookup procedure of
      type sym -> exp.  This can let the analyzer dig into calls to
      lexically bound procedures.

commit 86e4479abb89d26840d6ba3afe9df611fbeb4b98
Author: Andy Wingo <address@hidden>
Date:   Tue May 15 17:20:57 2012 +0200

    fix-letrec tweak
    
    * module/language/tree-il/fix-letrec.scm (make-sequence*, fix-letrec!):
      When turning unreferenced bindings into sequences, don't bother
      emitting trivially constant expressions in effect position.

commit dc1ee62046c130c6b26a96ca862663406ecbc7b1
Author: Andy Wingo <address@hidden>
Date:   Tue May 15 17:20:01 2012 +0200

    CSE in tail position
    
    * module/language/tree-il/cse.scm (singly-valued-expression?, cse):
      Allow CSE to propagate lexicals to tail positions, if the expression
      is singly-valued.

-----------------------------------------------------------------------

Summary of changes:
 module/language/tree-il/cse.scm        |   38 +++-
 module/language/tree-il/effects.scm    |  352 +++++++++++++++++---------------
 module/language/tree-il/fix-letrec.scm |   22 ++-
 test-suite/tests/cse.test              |   59 ++++--
 4 files changed, 274 insertions(+), 197 deletions(-)

diff --git a/module/language/tree-il/cse.scm b/module/language/tree-il/cse.scm
index a3b4a9d..ceef15f 100644
--- a/module/language/tree-il/cse.scm
+++ b/module/language/tree-il/cse.scm
@@ -154,6 +154,21 @@
     (($ <const> _ (? boolean?)) #t)
     (_ (eq? ctx 'test))))
 
+(define (singly-valued-expression? x ctx)
+  (match x
+    (($ <const>) #t)
+    (($ <lexical-ref>) #t)
+    (($ <void>) #t)
+    (($ <lexical-ref>) #t)
+    (($ <primitive-ref>) #t)
+    (($ <module-ref>) #t)
+    (($ <toplevel-ref>) #t)
+    (($ <application> _
+        ($ <primitive-ref> _ (? singly-valued-primitive?))) #t)
+    (($ <application> _ ($ <primitive-ref> _ 'values) (val)) #t)
+    (($ <lambda>) #t)
+    (_ (eq? ctx 'value))))
+
 (define* (cse exp)
   "Eliminate common subexpressions in EXP."
 
@@ -162,7 +177,7 @@
       (lambda (sym)
         (vhash-assq sym table))))
 
-  (define compute-effects
+  (define %compute-effects
     (make-effects-analyzer assigned-lexical?))
 
   (define (negate exp ctx)
@@ -186,9 +201,6 @@
        (make-application #f (make-primitive-ref #f 'not) (list exp)))))
 
   
-  (define (bailout? exp)
-    (causes-effects? (compute-effects exp) &definite-bailout))
-
   (define (hasher n)
     (lambda (x size) (modulo n size)))
 
@@ -323,6 +335,16 @@
                                 (make-lexical-ref (tree-il-src exp) name sym)
                                 (lp (1+ n) (- db-len db-len*))))))))))))
 
+  (define (lookup-lexical sym env)
+    (let ((env-len (vlist-length env)))
+      (let lp ((n 0))
+        (and (< n env-len)
+             (match (vlist-ref env n)
+               ((#(exp _ sym* _) . _)
+                (if (eq? sym sym*)
+                    exp
+                    (lp (1+ n)))))))))
+
   (define (intersection db+ db-)
     (vhash-fold-right
      (lambda (k h out)
@@ -350,6 +372,12 @@
                 (lp (cdr in) (cons x out) (concat db** db*))))
             (values (reverse out) db*))))
 
+    (define (compute-effects exp)
+      (%compute-effects exp (lambda (sym) (lookup-lexical sym env))))
+
+    (define (bailout? exp)
+      (causes-effects? (compute-effects exp) &definite-bailout))
+
     (define (return exp db*)
       (let ((effects (compute-effects exp)))
         (cond
@@ -371,7 +399,7 @@
           => (lambda (exp)
                (log 'propagate-test ctx (unparse-tree-il exp))
                (values exp db*)))
-         ((and (eq? ctx 'value)
+         ((and (singly-valued-expression? exp ctx)
                (find-dominating-lexical exp effects env db))
           => (lambda (exp)
                (log 'propagate-value ctx (unparse-tree-il exp))
diff --git a/module/language/tree-il/effects.scm 
b/module/language/tree-il/effects.scm
index 67bb8b7..656b262 100644
--- a/module/language/tree-il/effects.scm
+++ b/module/language/tree-il/effects.scm
@@ -162,174 +162,194 @@
   "Returns a procedure of type EXP -> EFFECTS that analyzes the effects
 of an expression."
 
-  (define compute-effects
-    (let ((cache (make-hash-table)))
-      (lambda (exp)
+  (let ((cache (make-hash-table)))
+    (define* (compute-effects exp #:optional (lookup (lambda (x) #f)))
+      (define (compute-effects exp)
         (or (hashq-ref cache exp)
             (let ((effects (visit exp)))
               (hashq-set! cache exp effects)
-              effects)))))
-
-  (define (accumulate-effects exps)
-    (let lp ((exps exps) (out &no-effects))
-      (if (null? exps)
-          out
-          (lp (cdr exps) (logior out (compute-effects (car exps)))))))
-
-  (define (visit exp)
-    (match exp
-      (($ <const>)
-       &no-effects)
-      (($ <void>)
-       &no-effects)
-      (($ <lexical-ref> _ _ gensym)
-       (if (assigned-lexical? gensym)
-           &mutable-lexical
-           &no-effects))
-      (($ <lexical-set> _ name gensym exp)
-       (logior (cause &mutable-lexical)
-               (compute-effects exp)))
-      (($ <let> _ names gensyms vals body)
-       (logior (if (or-map assigned-lexical? gensyms)
-                   (cause &allocation)
-                   &no-effects)
-               (accumulate-effects vals)
-               (compute-effects body)))
-      (($ <letrec> _ in-order? names gensyms vals body)
-       (logior (if (or-map assigned-lexical? gensyms)
-                   (cause &allocation)
-                   &no-effects)
-               (accumulate-effects vals)
-               (compute-effects body)))
-      (($ <fix> _ names gensyms vals body)
-       (logior (if (or-map assigned-lexical? gensyms)
-                   (cause &allocation)
-                   &no-effects)
-               (accumulate-effects vals)
-               (compute-effects body)))
-      (($ <let-values> _ producer consumer)
-       (logior (compute-effects producer)
-               (compute-effects consumer)
-               (cause &type-check)))
-      (($ <dynwind> _ winder body unwinder)
-       (logior (compute-effects winder)
-               (compute-effects body)
-               (compute-effects unwinder)))
-      (($ <dynlet> _ fluids vals body)
-       (logior (accumulate-effects fluids)
-               (accumulate-effects vals)
-               (cause &type-check)
-               (cause &fluid)
-               (compute-effects body)))
-      (($ <dynref> _ fluid)
-       (logior (compute-effects fluid)
-               (cause &type-check)
-               &fluid))
-      (($ <dynset> _ fluid exp)
-       (logior (compute-effects fluid)
-               (compute-effects exp)
-               (cause &type-check)
-               (cause &fluid)))
-      (($ <toplevel-ref>)
-       (logior &toplevel
-               (cause &type-check)))
-      (($ <module-ref>)
-       (logior &toplevel
-               (cause &type-check)))
-      (($ <module-set> _ mod name public? exp)
-       (logior (cause &toplevel)
-               (cause &type-check)
-               (compute-effects exp)))
-      (($ <toplevel-define> _ name exp)
-       (logior (cause &toplevel)
-               (compute-effects exp)))
-      (($ <toplevel-set> _ name exp)
-       (logior (cause &toplevel)
-               (compute-effects exp)))
-      (($ <primitive-ref>)
-       &no-effects)
-      (($ <conditional> _ test consequent alternate)
-       (let ((tfx (compute-effects test))
-             (cfx (compute-effects consequent))
-             (afx (compute-effects alternate)))
-         (if (causes-effects? (logior tfx (logand afx cfx))
-                              &definite-bailout)
-             (logior tfx cfx afx)
-             (exclude-effects (logior tfx cfx afx)
-                              &definite-bailout))))
-
-      ;; Zero values.
-      (($ <application> _ ($ <primitive-ref> _ 'values) ())
-       (cause &zero-values))
-
-      ;; Effect-free primitives.
-      (($ <application> _
-          ($ <primitive-ref> _ (and name
-                                    (? effect+exception-free-primitive?)))
-          args)
-       (logior (accumulate-effects args)
-               (if (constructor-primitive? name)
-                   (cause &allocation)
-                   &no-effects)))
-      (($ <application> _
-          ($ <primitive-ref> _ (and name
-                                    (? effect-free-primitive?)))
-          args)
-       (logior (accumulate-effects args)
-               (cause &type-check)
-               (if (constructor-primitive? name)
-                   (cause &allocation)
-                   (if (accessor-primitive? name)
-                       &mutable-data
-                       &no-effects))))
+              effects)))
+
+      (define (accumulate-effects exps)
+        (let lp ((exps exps) (out &no-effects))
+          (if (null? exps)
+              out
+              (lp (cdr exps) (logior out (compute-effects (car exps)))))))
+
+      (define (visit exp)
+        (match exp
+          (($ <const>)
+           &no-effects)
+          (($ <void>)
+           &no-effects)
+          (($ <lexical-ref> _ _ gensym)
+           (if (assigned-lexical? gensym)
+               &mutable-lexical
+               &no-effects))
+          (($ <lexical-set> _ name gensym exp)
+           (logior (cause &mutable-lexical)
+                   (compute-effects exp)))
+          (($ <let> _ names gensyms vals body)
+           (logior (if (or-map assigned-lexical? gensyms)
+                       (cause &allocation)
+                       &no-effects)
+                   (accumulate-effects vals)
+                   (compute-effects body)))
+          (($ <letrec> _ in-order? names gensyms vals body)
+           (logior (if (or-map assigned-lexical? gensyms)
+                       (cause &allocation)
+                       &no-effects)
+                   (accumulate-effects vals)
+                   (compute-effects body)))
+          (($ <fix> _ names gensyms vals body)
+           (logior (if (or-map assigned-lexical? gensyms)
+                       (cause &allocation)
+                       &no-effects)
+                   (accumulate-effects vals)
+                   (compute-effects body)))
+          (($ <let-values> _ producer consumer)
+           (logior (compute-effects producer)
+                   (compute-effects consumer)
+                   (cause &type-check)))
+          (($ <dynwind> _ winder body unwinder)
+           (logior (compute-effects winder)
+                   (compute-effects body)
+                   (compute-effects unwinder)))
+          (($ <dynlet> _ fluids vals body)
+           (logior (accumulate-effects fluids)
+                   (accumulate-effects vals)
+                   (cause &type-check)
+                   (cause &fluid)
+                   (compute-effects body)))
+          (($ <dynref> _ fluid)
+           (logior (compute-effects fluid)
+                   (cause &type-check)
+                   &fluid))
+          (($ <dynset> _ fluid exp)
+           (logior (compute-effects fluid)
+                   (compute-effects exp)
+                   (cause &type-check)
+                   (cause &fluid)))
+          (($ <toplevel-ref>)
+           (logior &toplevel
+                   (cause &type-check)))
+          (($ <module-ref>)
+           (logior &toplevel
+                   (cause &type-check)))
+          (($ <module-set> _ mod name public? exp)
+           (logior (cause &toplevel)
+                   (cause &type-check)
+                   (compute-effects exp)))
+          (($ <toplevel-define> _ name exp)
+           (logior (cause &toplevel)
+                   (compute-effects exp)))
+          (($ <toplevel-set> _ name exp)
+           (logior (cause &toplevel)
+                   (compute-effects exp)))
+          (($ <primitive-ref>)
+           &no-effects)
+          (($ <conditional> _ test consequent alternate)
+           (let ((tfx (compute-effects test))
+                 (cfx (compute-effects consequent))
+                 (afx (compute-effects alternate)))
+             (if (causes-effects? (logior tfx (logand afx cfx))
+                                  &definite-bailout)
+                 (logior tfx cfx afx)
+                 (exclude-effects (logior tfx cfx afx)
+                                  &definite-bailout))))
+
+          ;; Zero values.
+          (($ <application> _ ($ <primitive-ref> _ 'values) ())
+           (cause &zero-values))
+
+          ;; Effect-free primitives.
+          (($ <application> _
+              ($ <primitive-ref> _ (and name
+                                        (? effect+exception-free-primitive?)))
+              args)
+           (logior (accumulate-effects args)
+                   (if (constructor-primitive? name)
+                       (cause &allocation)
+                       &no-effects)))
+          (($ <application> _
+              ($ <primitive-ref> _ (and name
+                                        (? effect-free-primitive?)))
+              args)
+           (logior (accumulate-effects args)
+                   (cause &type-check)
+                   (if (constructor-primitive? name)
+                       (cause &allocation)
+                       (if (accessor-primitive? name)
+                           &mutable-data
+                           &no-effects))))
       
-      ;; Lambda applications might throw wrong-number-of-args.
-      (($ <application> _ ($ <lambda> _ _ body) args)
-       (logior (compute-effects body)
-               (accumulate-effects args)
-               (cause &type-check)))
+          ;; Lambda applications might throw wrong-number-of-args.
+          (($ <application> _ ($ <lambda> _ _ body) args)
+           (logior (accumulate-effects args)
+                   (match body
+                     (($ <lambda-case> _ req #f #f #f () syms body #f)
+                      (logior (compute-effects body)
+                              (if (= (length req) (length args))
+                                  0
+                                  (cause &type-check))))
+                     (($ <lambda-case>)
+                      (logior (compute-effects body)
+                              (cause &type-check))))))
         
-      ;; Bailout primitives.
-      (($ <application> src ($ <primitive-ref> _ (? bailout-primitive? name))
-          args)
-       (logior (accumulate-effects args)
-               (cause &definite-bailout)
-               (cause &possible-bailout)))
-
-      ;; A call to an unknown procedure can do anything.
-      (($ <application> _ proc args)
-       (logior &all-effects-but-bailout
-               (cause &all-effects-but-bailout)))
-
-      (($ <lambda> _ meta body)
-       &no-effects)
-      (($ <lambda-case> _ req opt rest kw inits gensyms body alt)
-       (logior (exclude-effects (accumulate-effects inits)
-                                &definite-bailout)
-               (if (or-map assigned-lexical? gensyms)
-                   (cause &allocation)
-                   &no-effects)
-               (compute-effects body)
-               (if alt (compute-effects alt) &no-effects)))
-
-      (($ <sequence> _ exps)
-       (let lp ((exps exps) (effects &no-effects))
-         (match exps
-           ((tail)
-            (logior (compute-effects tail)
-                    ;; Returning zero values to a for-effect continuation is
-                    ;; not observable.
-                    (exclude-effects effects (cause &zero-values))))
-           ((head . tail)
-            (lp tail (logior (compute-effects head) effects))))))
-
-      (($ <prompt> _ tag body handler)
-       (logior (compute-effects tag)
-               (compute-effects body)
-               (compute-effects handler)))
-
-      (($ <abort> _ tag args tail)
-       (logior &all-effects-but-bailout
-               (cause &all-effects-but-bailout)))))
-
-  compute-effects)
+          ;; Bailout primitives.
+          (($ <application> src ($ <primitive-ref> _ (? bailout-primitive? 
name))
+              args)
+           (logior (accumulate-effects args)
+                   (cause &definite-bailout)
+                   (cause &possible-bailout)))
+
+          ;; A call to a lexically bound procedure, perhaps labels
+          ;; allocated.
+          (($ <application> _ (and proc ($ <lexical-ref> _ _ sym)) args)
+           (cond
+            ((lookup sym)
+             => (lambda (proc)
+                  (compute-effects (make-application #f proc args))))
+            (else
+             (logior &all-effects-but-bailout
+                     (cause &all-effects-but-bailout)))))
+
+          ;; A call to an unknown procedure can do anything.
+          (($ <application> _ proc args)
+           (logior &all-effects-but-bailout
+                   (cause &all-effects-but-bailout)))
+
+          (($ <lambda> _ meta body)
+           &no-effects)
+          (($ <lambda-case> _ req opt rest kw inits gensyms body alt)
+           (logior (exclude-effects (accumulate-effects inits)
+                                    &definite-bailout)
+                   (if (or-map assigned-lexical? gensyms)
+                       (cause &allocation)
+                       &no-effects)
+                   (compute-effects body)
+                   (if alt (compute-effects alt) &no-effects)))
+
+          (($ <sequence> _ exps)
+           (let lp ((exps exps) (effects &no-effects))
+             (match exps
+               ((tail)
+                (logior (compute-effects tail)
+                        ;; Returning zero values to a for-effect continuation 
is
+                        ;; not observable.
+                        (exclude-effects effects (cause &zero-values))))
+               ((head . tail)
+                (lp tail (logior (compute-effects head) effects))))))
+
+          (($ <prompt> _ tag body handler)
+           (logior (compute-effects tag)
+                   (compute-effects body)
+                   (compute-effects handler)))
+
+          (($ <abort> _ tag args tail)
+           (logior &all-effects-but-bailout
+                   (cause &all-effects-but-bailout)))))
+
+      (compute-effects exp))
+
+    compute-effects))
diff --git a/module/language/tree-il/fix-letrec.scm 
b/module/language/tree-il/fix-letrec.scm
index f387df1..0a21d14 100644
--- a/module/language/tree-il/fix-letrec.scm
+++ b/module/language/tree-il/fix-letrec.scm
@@ -1,6 +1,6 @@
 ;;; transformation of letrec into simpler forms
 
-;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -181,6 +181,20 @@
                   '())))
     (values unref simple lambda* complex)))
 
+(define (make-sequence* src exps)
+  (let lp ((in exps) (out '()))
+    (if (null? (cdr in))
+        (if (null? out)
+            (car in)
+            (make-sequence src (reverse (cons (car in) out))))
+        (let ((head (car in)))
+          (record-case head
+            ((<lambda>) (lp (cdr in) out))
+            ((<const>) (lp (cdr in) out))
+            ((<lexical-ref>) (lp (cdr in) out))
+            ((<void>) (lp (cdr in) out))
+            (else (lp (cdr in) (cons head out))))))))
+
 (define (fix-letrec! x)
   (let-values (((unref simple lambda* complex) (partition-vars x)))
     (post-order!
@@ -191,7 +205,7 @@
          ;; expression, called for effect.
          ((<lexical-set> gensym exp)
           (if (memq gensym unref)
-              (make-sequence #f (list exp (make-void #f)))
+              (make-sequence* #f (list exp (make-void #f)))
               x))
 
          ((<letrec> src in-order? names gensyms vals body)
@@ -219,7 +233,7 @@
                ;; Bind lambdas using the fixpoint operator.
                (make-fix
                 src (map cadr l) (map car l) (map caddr l)
-                (make-sequence
+                (make-sequence*
                  src
                  (append
                   ;; The right-hand-sides of the unreferenced
@@ -263,7 +277,7 @@
             (let ((u (lookup unref))
                   (l (lookup lambda*))
                   (c (lookup complex)))
-              (make-sequence
+              (make-sequence*
                src
                (append
                 ;; unreferenced bindings, called for effect.
diff --git a/test-suite/tests/cse.test b/test-suite/tests/cse.test
index a6308d5..ee31285 100644
--- a/test-suite/tests/cse.test
+++ b/test-suite/tests/cse.test
@@ -23,7 +23,9 @@
   #:use-module (system base pmatch)
   #:use-module (system base message)
   #:use-module (language tree-il)
+  #:use-module (language tree-il canonicalize)
   #:use-module (language tree-il primitives)
+  #:use-module (language tree-il fix-letrec)
   #:use-module (language tree-il cse)
   #:use-module (language tree-il peval)
   #:use-module (language glil)
@@ -34,12 +36,14 @@
     ((_ in pat)
      (pass-if 'in
        (let ((evaled (unparse-tree-il
-                      (cse
-                       (peval
-                        (expand-primitives!
-                         (resolve-primitives!
-                          (compile 'in #:from 'scheme #:to 'tree-il)
-                          (current-module))))))))
+                      (canonicalize!
+                       (fix-letrec!
+                        (cse
+                         (peval
+                          (expand-primitives!
+                           (resolve-primitives!
+                            (compile 'in #:from 'scheme #:to 'tree-il)
+                            (current-module))))))))))
          (pmatch evaled
            (pat #t)
            (_   (pk 'cse-mismatch)
@@ -216,14 +220,19 @@
      (lambda-case
       (((x y) #f #f #f () (_ _))
        (begin
-         (if (if (apply (primitive struct?) (lexical x _))
-                 (apply (primitive eq?)
-                        (apply (primitive struct-vtable)
-                               (lexical x _))
-                        (toplevel x-vtable))
-                 (const #f))
-             (void)
-             (apply (primitive 'throw) (const 'foo)))
+         (fix (failure) (_)
+              ((lambda _
+                 (lambda-case
+                  ((() #f #f #f () ())
+                   (apply (primitive throw) (const foo))))))
+              (if (apply (primitive struct?) (lexical x _))
+                  (if (apply (primitive eq?)
+                             (apply (primitive struct-vtable)
+                                    (lexical x _))
+                             (toplevel x-vtable))
+                      (void)
+                      (apply (lexical failure _)))
+                  (apply (lexical failure _))))
          (apply (primitive struct-ref) (lexical x _) (lexical y _)))))))
 
   ;; Strict argument evaluation also adds info to the DB.
@@ -240,14 +249,20 @@
     (lambda _
       (lambda-case
        (((x) #f #f #f () (_))
-        (let (z) (_) ((if (if (apply (primitive struct?) (lexical x _))
-                              (apply (primitive eq?)
-                                     (apply (primitive struct-vtable)
-                                            (lexical x _))
-                                     (toplevel x-vtable))
-                              (const #f))
-                          (apply (primitive struct-ref) (lexical x _) (const 
1))
-                          (apply (primitive 'throw) (const 'foo))))
+        (let (z) (_)
+             ((fix (failure) (_)
+                   ((lambda _
+                      (lambda-case
+                       ((() #f #f #f () ())
+                        (apply (primitive throw) (const foo))))))
+                   (if (apply (primitive struct?) (lexical x _))
+                       (if (apply (primitive eq?)
+                                  (apply (primitive struct-vtable)
+                                         (lexical x _))
+                                  (toplevel x-vtable))
+                           (apply (primitive struct-ref) (lexical x _) (const 
1))
+                           (apply (lexical failure _)))
+                       (apply (lexical failure _)))))
              (apply (primitive +) (lexical z _)
                     (apply (primitive struct-ref) (lexical x _) (const 
2))))))))
 


hooks/post-receive
-- 
GNU Guile



reply via email to

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