guile-commits
[Top][All Lists]
Advanced

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

[Guile-commits] GNU Guile branch, wip-rtl-cps, updated. v2.1.0-185-g8987


From: Noah Lavine
Subject: [Guile-commits] GNU Guile branch, wip-rtl-cps, updated. v2.1.0-185-g898799b
Date: Wed, 20 Feb 2013 04:49:08 +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=898799b786dc75d18f23a0fbc0f512ea2b9076ed

The branch, wip-rtl-cps has been updated
       via  898799b786dc75d18f23a0fbc0f512ea2b9076ed (commit)
       via  967985e0cf0fdf7e7aa1061955ed0a21a527333d (commit)
       via  627636130d246c3953c150067a0f1def34e45a34 (commit)
       via  c4b9e1845834e866f9ab540cbe8be20f09d33eae (commit)
       via  680c4ee2172cf97dd40a05df467014f3a86e08c3 (commit)
      from  0d0808ae3f7390ffb250b9deb6706ad4158cce0e (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 898799b786dc75d18f23a0fbc0f512ea2b9076ed
Author: Noah Lavine <address@hidden>
Date:   Tue Feb 19 23:43:47 2013 -0500

    Add CPS Printer
    
    * module/language/cps.scm: add CPS printer, using unparse-cps.

commit 967985e0cf0fdf7e7aa1061955ed0a21a527333d
Author: Noah Lavine <address@hidden>
Date:   Tue Feb 19 23:30:31 2013 -0500

    Sequences in CPS
    
    * module/language/cps.scm: let continuations take rest arguments.
    * module/language/tree-il/compile-cps.scm: compile sequences.
    * module/language/cps/compile-rtl.scm: handle rest arguments.
    * test-suite/tests/cps.test: test sequences.
    
    Note: sequences and rest arguments are grouped together because rest
    arguments are needed for sequences, and sequences are used to test rest
    arguments.

commit 627636130d246c3953c150067a0f1def34e45a34
Author: Noah Lavine <address@hidden>
Date:   Tue Feb 19 21:51:10 2013 -0500

    Lexical Sets in CPS
    
    * module/language/tree-il/compile-cps.scm: compile lexical-sets to CPS.
    * module/language/cps/compile-rtl.scm: fix bug in lexical set
      implementation.
    * test-suite/tests/cps.test: test lexical sets.

commit c4b9e1845834e866f9ab540cbe8be20f09d33eae
Author: Noah Lavine <address@hidden>
Date:   Tue Feb 19 11:47:47 2013 -0500

    CPS Compiler Function
    
    * module/language/cps/spec.scm: add module. Has 'cps-compile', like
      regular 'compile' but using CPS.
    * module/language/cps/compile-rtl.scm: remove duplicate functionality.
    * test-suite/tests/cps.test: use 'cps-compile'.

commit 680c4ee2172cf97dd40a05df467014f3a86e08c3
Author: Noah Lavine <address@hidden>
Date:   Tue Feb 19 11:32:53 2013 -0500

    Adopt Naming Convention
    
    * module/language/cps.scm: add note on using "value" and "variable"
      consistently.
    * module/language/tree-il/compile-cps.scm: adjust.
    * module/language/cps/compile-rtl.scm: adjust.

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

Summary of changes:
 module/language/cps.scm                 |   46 ++++++++----
 module/language/cps/compile-rtl.scm     |  123 ++++++++++++++++++-------------
 module/language/cps/spec.scm            |   24 ++++++
 module/language/tree-il/compile-cps.scm |   36 +++++++--
 test-suite/tests/cps.test               |   37 ++++-----
 5 files changed, 170 insertions(+), 96 deletions(-)
 create mode 100644 module/language/cps/spec.scm

diff --git a/module/language/cps.scm b/module/language/cps.scm
index 7b056fb..6a4dfad 100644
--- a/module/language/cps.scm
+++ b/module/language/cps.scm
@@ -8,7 +8,7 @@
             <letrec> letrec? make-letrec letrec-names letrec-funcs letrec-body
             <letcont> letcont? make-letcont letcont-names
                       letcont-conts letcont-body
-            <lambda> lambda? make-lambda lambda-names lambda-body
+            <lambda> lambda? make-lambda lambda-names lambda-rest lambda-body
             <call> call? make-call call-proc call-cont call-args
             <primitive> primitive? make-primitive primitive-name
             <if> if? make-if if-test if-consequent if-alternate
@@ -61,7 +61,7 @@
 
 ;; The handling of mutable variables is interesting. We would eventually
 ;; like to handle mutable variables and structs the same way - a
-;; container object that holds some number of mutable values, with a
+;; container object that holds some number of mutable slots, with a
 ;; mutable variable being the special case of holding only one
 ;; value. (Ideally we'd also model hash tables like that, but that's
 ;; ambitious.) Kennedy's paper handles struct-like objects by having
@@ -81,7 +81,16 @@
 ;; what things can go where - <cps-data> objects can only appear as the
 ;; value part of a letval, and only <cps-data> objects can be there.
 
-(define-type <cps>
+;; Naming Conventions
+
+;; The things that would normally be thought of as "variables" in CPS
+;; (i.e. the things that symbols refer to) are very different than the
+;; "variable objects" that we use to represent mutable variables. To
+;; keep things straight, we try to use "value" for the things that
+;; symbols refer to, since they are constant values, and "variable" for
+;; the variable objects, since they vary.
+
+(define-type (<cps> #:printer print-cps)
   ;; <letval> values can be anything in the <cps-data> declaration
   ;; below. I think it's an open question whether we need letvals - we
   ;; could also imagine having some primitive functions that define
@@ -96,14 +105,16 @@
   ;; is that they can always be compiled as jumps. this is information
   ;; that was in the program itself, but would be lost if we compiled
   ;; everything to lambdas without distinguishing them in some
-  ;; way. also, continuations can never be referenced by variables, so
-  ;; we don't need to worry about packaging them up.
+  ;; way. also, continuations can never be referenced, so we don't need
+  ;; to worry about packaging them up.
   (<letcont> names conts body)
   ;; the 'lambda' form appears in the 'funcs' list of a letrec form, the
   ;; 'conts' list of a letcont form, and as the outermost form of a
   ;; compilation unit (when we're compiling a procedure at a time) to
-  ;; distinguish procedure arguments from top-level variables.
-  (<lambda> names body)
+  ;; distinguish procedure arguments from top-level variables. names is
+  ;; a proper list of symbols, and rest is either #f or a single symbol
+  ;; naming a rest argument.
+  (<lambda> names rest body)
   ;; the 'call' form literally represents a call. the procedure will be
   ;; a variable bound by either a lambda form, a letval, a letrec, or a
   ;; letcont, or the special value 'return (which means to return from
@@ -117,8 +128,8 @@
   ;; the 'primitive' form represents a primitive procedure. it will
   ;; probably appear in the 'proc' field of a <call> record, so maybe we
   ;; should have a merged 'primcall' record like Tree-IL does, but it
-  ;; could also appear in a <letval> vals list. the name of a primitive
-  ;; is a symbol.
+  ;; could also appear in a <letval> values list. the name of a
+  ;; primitive is a symbol.
   (<primitive> name)
   ;; the 'if' form is like a Scheme 'if', except that the test must be a
   ;; lexical variable, and the consequent and alternate must be names of
@@ -135,9 +146,9 @@
 (define-type <cps-data>
   ;; const represents constants.
   (<const> value)
-  ;; var is for lexical variables. these things just map to variable
-  ;; objects in the VM. value is the value it is initialized to. it
-  ;; should be a CPS variable (which is a symbol).
+  ;; var is for lexical variables. these things map to variable objects
+  ;; in the VM. value is the value it is initialized to. it should be a
+  ;; CPS value (which is a symbol).
   (<var> value)
   ;; toplevel vars are like pseudo-vars. instead of actually creating a
   ;; variable object, we'll just remember that there *is* a variable
@@ -165,8 +176,8 @@
      (make-letcont names
                    (map parse-cps conts)
                    (parse-cps body)))
-    (('lambda names body)
-     (make-lambda names (parse-cps body)))
+    (('lambda names rest body)
+     (make-lambda names rest (parse-cps body)))
     (('call ('primitive prim) cont args)
      (make-call (make-primitive prim) cont args))
     (('call proc cont args)
@@ -195,8 +206,8 @@
      (list 'letcont names
            (map unparse-cps conts)
            (unparse-cps body)))
-    (($ <lambda> names body)
-     (list 'lambda names (unparse-cps body)))
+    (($ <lambda> names rest body)
+     (list 'lambda names rest (unparse-cps body)))
     (($ <call> ($ <primitive> prim) cont args)
      (list 'call (list 'primitive prim) cont args))
     (($ <call> proc cont args)
@@ -206,3 +217,6 @@
     (($ <if> test consequent alternate)
      (list 'if test consequent alternate))
     (_ (error "couldn't unparse CPS" cps))))
+
+(define (print-cps exp port)
+  (format port "#<cps ~S>" (unparse-cps exp)))
diff --git a/module/language/cps/compile-rtl.scm 
b/module/language/cps/compile-rtl.scm
index 5cac8da..3a06c99 100644
--- a/module/language/cps/compile-rtl.scm
+++ b/module/language/cps/compile-rtl.scm
@@ -1,19 +1,19 @@
 (define-module (language cps compile-rtl)
   #:use-module (language cps)
   #:use-module (language cps primitives)
-  #:use-module (system vm rtl) ;; for assemble-program
   #:use-module (system base syntax) ;; for record-case
   #:use-module (ice-9 match)
   #:use-module (ice-9 q) ;; used in generate-shuffle
+  #:use-module (ice-9 receive)
   #:use-module (srfi srfi-1)
   #:export (cps->rtl allocate-registers-and-labels! with-alloc show-alloc!
-            cps->program generate-suffle))
+            generate-suffle))
 
 ;; currently, the only way we have to run RTL code is to package it up
 ;; into a program and call that program. Therefore, all code that we
 ;; compile will look like a lambda expression, maybe with no arguments.
 
-;; we associate a register number with every CPS variable (which will
+;; we associate a register number with every CPS value (which will
 ;; always be a symbol)
 (define register (make-object-property))
 
@@ -21,6 +21,12 @@
 ;; frame. this holds that information.
 (define call-frame-start (make-object-property))
 
+;; when we have a continuation that can accept any number of values, it
+;; needs to know where to put them on the stack. this holds that
+;; information. TO DO: could this be combined with the previous
+;; property?
+(define rest-args-start (make-object-property))
+
 ;; and every contination gets a label, so we can jump to it. this is
 ;; indexed by the names of the continuations, not the actual lambda objects.
 (define label (make-object-property))
@@ -43,11 +49,10 @@
 ;; "name-defn"? "name->defn"? "definition"? "lookup-defn"?
 (define name-defn (make-object-property))
 
-;; this holds the number of local variable slots needed by every 'lambda'
-;; form, so we can allocate them with the 'nlocals or
-;; 'assert-nargs-ee/nlocals instructions. this is set by
-;; allocate-registers-and-labels!, because it has all the register
-;; information.
+;; this holds the number of registers needed by every 'lambda' form, so we
+;; can allocate them with the reserve-locals or assert-nargs-ee/nlocals
+;; instructions. this is set by allocate-registers-and-labels!, because
+;; it has all the register information.
 (define nlocals (make-object-property))
 
 ;; This function walks some CPS and allocates registers and labels for
@@ -55,29 +60,36 @@
 ;; property for continuations
 (define (allocate-registers-and-labels! cps)
   (define (visit cps counter)
-    ;; counter is the number of local variables we've already allocated.
+    ;; counter is the number of registers we've already allocated.
     (record-case cps
       ;; call is kind of a weird case, because although it doesn't need
       ;; any extra registers, the new frame needs to be on top of the
-      ;; stack. so we save that information in its own property.
+      ;; stack. so we save the end of the stack in its own property.
       ((<call>)
-       (set! (call-frame-start cps) (+ counter))
+       (set! (call-frame-start cps) counter)
        counter)
 
-      ((<lambda> names body)
-       ;; TO DO: record which variables will be closure variables.
+      ((<lambda> names rest body)
+       ;; we can't actually handle continuations with any number of
+       ;; values (except in some special cases), because we wouldn't be
+       ;; able to allocate registers for an subsequent instructions
+       ;; without knowing how many registers this will use. so if we get
+       ;; a rest arg, we remember where the top of the stack is and then
+       ;; emit either a bind-rest or drop-values instruction.
        (let* ((after-names
-               ;; assign register numbers to each argument, starting
-               ;; with 0 and counting up.
+               ;; assign register numbers to each name
                (fold (lambda (name counter)
                        (set! (register name) counter)
                        (1+ counter))
                      counter names))
               (total
                (visit body after-names)))
-         ;; we reserve one more than whatever number of variables we
-         ;; have because we might need an extra space to move variables
-         ;; around. see generate-shuffle below. this doesn't really feel
+         (when rest
+               (set! (rest-args-start rest) total)
+               (set! total (+ total 1)))
+         ;; we reserve one more than whatever number of values we have
+         ;; because we might need an extra space to move values
+         ;; around. see generate-shuffle. this doesn't really feel
          ;; elegant, but I don't have a better solution right now.
          (set! (nlocals cps) (+ total 1))))
       
@@ -117,7 +129,7 @@
        ;; then allocate registers for all of the continuations and the
        ;; body. we need to return the maximum of the register numbers
        ;; used so that whatever procedure we're part of will allocate
-       ;; the right number of local variable slots on the stack.
+       ;; the right number of registers.
        (apply max (visit body counter)
               (map (lambda (c) (visit c counter)) conts)))
       
@@ -161,7 +173,7 @@
                            ;; allocated s.
 
   
-  (define (do-value v) ;; v is a cps-data object
+  (define (do-data v) ;; v is a cps-data object
     (cond ((var? v)
            (list 'var (var-value v)))
           ((toplevel-var? v)
@@ -188,14 +200,15 @@
             (cons* 'call
                    (call-frame-start cps)
                    (with-alloc proc)
-                   (with-alloc cont)
+                   (with-label cont)
                    (map with-alloc args)))
-           ((<lambda> names body)
+           ((<lambda> names rest body)
             `(lambda ,(map with-register names)
+               ,(cons rest (rest-args-start rest))
                ,(with-alloc body)))
            ((<letval> names vals body)
             `(letval ,(map with-register names)
-                     ,(map do-value vals)
+                     ,(map do-data vals)
                      ,(with-alloc body)))
            ((<letcont> names conts body)
             `(letcont ,(map with-label names)
@@ -302,10 +315,12 @@
 ;; of RTL code.
 (define (cps->rtl cps)
   ;; generate-primitive-call: generate a call to primitive prim with the
-  ;; given args, placing the result in register(s) dsts. This is its own
-  ;; function because it is called twice in visit - once in the tail
-  ;; case and once in the non-tail case.
-  (define (generate-primitive-call dsts prim args)
+  ;; given args, placing the result in register(s) dsts. rest is either
+  ;; #f or the location of the rest arguments of the destination
+  ;; continuation (if it has rest arguments). This is its own function
+  ;; because it is called twice in visit - once in the tail case and
+  ;; once in the non-tail case.
+  (define (generate-primitive-call dsts rest prim args)
     ;; the primitives 'ref and 'set are handled differently than the
     ;; others because they need to know whether they're setting a
     ;; toplevel variable or not. I think there's some bad abstraction
@@ -317,33 +332,43 @@
 
     (case prim
       ((ref) (let* ((var-value (car args))
+                    ;; var-value is the value holding the variable
+                    ;; object
                     (var (name-defn var-value))
-                    (dst (car dsts)))
+                    ;; var is the actual variable object
+                    (dst (if (pair? dsts)
+                             (car dsts)
+                             rest)))
                (if (toplevel-var? var)
-                   (let ((var-name (toplevel-var-name var)))
-                     ;; the scope is 'foo because we don't meaningfully
-                     ;; distinguish scopes yet. we should really just
-                     ;; cache the current module once per procedure.
-                     `((cache-current-module! ,dst foo)
-                       (cached-toplevel-ref ,dst foo ,var-name)))
+                   ;; the scope is 'foo because we don't meaningfully
+                   ;; distinguish scopes yet. we should really just
+                   ;; cache the current module once per procedure.
+                   `((cache-current-module! ,dst foo)
+                     (cached-toplevel-ref ,dst foo
+                                          ,(toplevel-var-name var)))
                    `((box-ref ,dst ,(register var-value))))))
       ((set) (let* ((var-value (car args))
+                    (new-value (cadr args))
                     (var (name-defn var-value))
-                    (dst (car dsts)))
+                    (dst (if (pair? dsts)
+                             (car dsts)
+                             rest)))
                (if (toplevel-var? var)
-                   (let ((var-name (toplevel-var-name var)))
-                     `((cache-current-module! ,dst foo)
-                       (cached-toplevel-set! ,(register (cadr args))
-                                             foo ,var-name)
-                       (mov ,dst ,(register (cadr args)))))
+                   `((cache-current-module! ,dst foo)
+                     (cached-toplevel-set! ,(register new-value) foo
+                                           ,(toplevel-var-name var))
+                     (mov ,dst ,(register new-value)))
                    `((box-set!
-                      ,(register (car args))
-                      ,(register (cadr args)))))))
+                      ,(register var-value)
+                      ,(register new-value))
+                     (mov ,dst ,(register new-value))))))
       (else
        (let ((insn (hashq-ref *primitive-insn-table* prim))
              (in-arity (hashq-ref *primitive-in-arity-table* prim))
              (out-arity (hashq-ref *primitive-out-arity-table* prim))
-             (dst (car dsts)))
+             (dst (if (pair? dsts)
+                      (car dsts)
+                      rest)))
          (if (and insn
                   (= in-arity (length args))
                   (= out-arity 1)) ;; we don't support n-ary outputs yet
@@ -375,7 +400,7 @@
             (let ((return-reg
                    (+ 1 (apply max (map register args)))))
               `(,@(generate-primitive-call
-                   (list return-reg) (primitive-name proc) args)
+                   (list return-reg) #f (primitive-name proc) args)
                 (return ,return-reg)))
             
             (let ((num-args (length args)))
@@ -404,6 +429,7 @@
         (if (label cont) ;; a call whose continuation is bound in a
                          ;; letcont form
             (let* ((dsts (map register (lambda-names (name-defn cont))))
+                   (rest (rest-args-start (lambda-rest (name-defn cont))))
                    (return-start (call-frame-start cps))
                    ;; perm is the permutation we have to execute to put
                    ;; the results of the call in their destinations
@@ -413,7 +439,7 @@
                    (perm-label (next-label!)))
               (if (primitive? proc)
                   `(,@(generate-primitive-call
-                       dsts (primitive-name proc) args)
+                       dsts rest (primitive-name proc) args)
                     (br ,(label cont)))
                   `((call ,(call-frame-start cps) ,(register proc)
                           ,(map register args))
@@ -460,16 +486,11 @@
                       `((label ,(label n))
                         ,@(visit (lambda-body c))))
                     names conts)))
-       (($ <lambda> names body)
+       (($ <lambda> names rest body)
         ;; TO DO: save the names of the lambdas
         `((begin-program foo)
           (assert-nargs-ee/locals ,(length names) ,(nlocals cps))
           ,@(visit body)
           (end-program)))))
 
-  (allocate-registers-and-labels! cps)
   (visit cps))
-
-(define (cps->program cps)
-  (assemble-program
-   (cps->rtl cps)))
diff --git a/module/language/cps/spec.scm b/module/language/cps/spec.scm
new file mode 100644
index 0000000..806c339
--- /dev/null
+++ b/module/language/cps/spec.scm
@@ -0,0 +1,24 @@
+(define-module (language cps spec)
+  #:use-module (system base compile)
+  #:use-module (language tree-il compile-cps)
+  #:use-module (language cps compile-rtl)
+  #:use-module (system vm rtl)
+  #:export (cps-compile))
+
+;; since CPS isn't complete yet, we don't want to make it part of the
+;; system compiler graph, so we have our own compile function.
+(define* (cps-compile x #:key (from 'scheme) (to 'value))
+  (cond ((eq? from to) x)
+        ((not (memq to '(scheme tree-il cps rtl value)))
+         (error "Unrecognized language" to))
+        (else
+         (case from
+           ((scheme) (cps-compile (compile x #:to 'tree-il)
+                                  #:from 'tree-il #:to to))
+           ((tree-il) (cps-compile (tree-il->cps x)
+                                   #:from 'cps #:to to))
+           ((cps) (allocate-registers-and-labels! x)
+            (cps-compile (cps->rtl x)
+                         #:from 'rtl #:to to))
+           ((rtl) (assemble-program x))
+           (else (error "Unrecognized language" from))))))
diff --git a/module/language/tree-il/compile-cps.scm 
b/module/language/tree-il/compile-cps.scm
index 150bbc0..09fb0fc 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -36,7 +36,7 @@
                  (val (gensym "val-")))
              (cps-make-letcont
               (list con)
-              (list (cps-make-lambda (list val) (gen-k val)))
+              (list (cps-make-lambda (list val) #f (gen-k val)))
               (visit con tree env))))))
 
   ;; like with-value-names, but takes a list of trees, and applies gen-k
@@ -53,24 +53,24 @@
            env))))
 
   ;; with-variable-boxes generates CPS that makes variable objects for
-  ;; the given variables and then calls 'gen-k' with a new environment
+  ;; the given CPS values and then calls 'gen-k' with a new environment
   ;; in which the given names are mapped to the names of their boxes.
-  (define (with-variable-boxes gen-k vars env)
+  (define (with-variable-boxes gen-k vals env)
     (let ((var-names (sample (lambda () (gensym "var-"))
-                             (length vars))))
+                             (length vals))))
       (cps-make-letval
        var-names
        (map (lambda (var-name val)
               (cps-make-var val))
-            var-names vars)
+            var-names vals)
        (gen-k
         (fold vhash-consq
               env
-              vars var-names)))))
+              vals var-names)))))
   
   ;; visit returns a CPS version of tree which ends by calling
   ;; continuation k. 'env' is a vhash that maps Tree-IL variable gensyms
-  ;; to CPS variable names.
+  ;; to CPS value names.
   (define (visit k tree env)
     (match tree
       ;; note: 1. we only support lambdas with one case right now, and
@@ -79,6 +79,7 @@
       (($ <lambda> src meta
           ($ <lambda-case> src req opt rest kw inits gensyms body alternate))
        (cps-make-lambda gensyms
+                   #f
                    (with-variable-boxes
                     (lambda (env)
                       (visit 'return body env))
@@ -99,8 +100,8 @@
          (cps-make-letcont
           (list con alt)
           (list
-           (cps-make-lambda '() (visit k consequent env))
-           (cps-make-lambda '() (visit k alternate env)))
+           (cps-make-lambda '() #f (visit k consequent env))
+           (cps-make-lambda '() #f (visit k alternate env)))
           (with-value-name
            (lambda (test-val)
              (cps-make-if test-val con alt))
@@ -111,6 +112,23 @@
         (cps-make-primitive 'ref)
         k
         (list (cdr (vhash-assq gensym env)))))
+      (($ <lexical-set> src name gensym exp)
+       (with-value-name
+        (lambda (val-name)
+          (cps-make-call
+           (cps-make-primitive 'set)
+           k
+           (list (cdr (vhash-assq gensym env))
+                 val-name)))
+        exp env))
+      (($ <seq> src head tail)
+       (let ((con (gensym "con-"))
+             (rest (gensym "rest-")))
+         (cps-make-letcont
+          (list con)
+          (list (cps-make-lambda '() rest
+                            (visit k tail env)))
+          (visit con head env))))
       (($ <toplevel-ref> src name)
        (let ((var-name (gensym "var-")))
          (cps-make-letval
diff --git a/test-suite/tests/cps.test b/test-suite/tests/cps.test
index 8620902..6bfb34b 100644
--- a/test-suite/tests/cps.test
+++ b/test-suite/tests/cps.test
@@ -1,44 +1,33 @@
 (use-modules
  (test-suite lib)
- (language cps)
- (language cps compile-rtl)
- (language tree-il compile-cps))
-
-;; a convenient way to write literal CPS code
-(define-syntax-rule (cps x)
-  (cps->program (parse-cps 'x)))
-
-;; by-cps: compile a procedure, but by way of CPS instead of the normal
-;; compiler chain
-(define (by-cps x)
-  (cps->program (tree-il->cps (compile x #:to 'tree-il))))
+ (language cps spec))
 
 (pass-if "return-three"
   (= 3
-     ((by-cps 3))))
+     ((cps-compile 3))))
 
 (define (return-three) 3)
 
 (pass-if "call-arg"
   (= 3
-     ((by-cps '(lambda (x) (x)))
+     ((cps-compile '(lambda (x) (x)))
       return-three)))
 
 (define (add-two x) (+ x 2))
 
 (pass-if "single-value compose"
   (= 5
-     ((by-cps '(lambda (x y) (x (y))))
+     ((cps-compile '(lambda (x y) (x (y))))
       add-two
       return-three)))
 
 (pass-if "identity function"
   (= 3
-     ((by-cps '(lambda (x) x))
+     ((cps-compile '(lambda (x) x))
       3)))
 
 (define if-func
-  (by-cps '(lambda (x) (if x 1 2))))
+  (cps-compile '(lambda (x) (if x 1 2))))
 
 (pass-if "if true"
   (= 1 (if-func #t)))
@@ -49,14 +38,22 @@
 (define *foo* 6)
 (pass-if "toplevel-ref"
   (= 6
-     ((by-cps '(lambda () *foo*)))))
+     ((cps-compile '(lambda () *foo*)))))
 
 (pass-if "toplevel-set"
   (= 12
      (begin
-       ((by-cps '(lambda () (set! *foo* 12))))
+       ((cps-compile '(lambda () (set! *foo* 12))))
        *foo*)))
 
+(pass-if "lexical-set"
+  (= 5
+     ((cps-compile '(lambda (x) (set! x 5))) 3)))
+
+(pass-if "sequences"
+  (= 5
+     ((cps-compile '(lambda (x) (set! x 5) x)) 3)))
+
 (pass-if "addition"
   (= 7
-     ((by-cps '(lambda () (+ 3 4))))))
+     ((cps-compile '(lambda () (+ 3 4))))))


hooks/post-receive
-- 
GNU Guile



reply via email to

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