[Guile-commits] GNU Guile branch, wip-case-lambda, updated. release_1-9-4-17-g8de2de5

[Andy Wingo]

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=8de2de57d6920e22b66cd53ada90b635e895db90

The branch, wip-case-lambda has been updated
       via  8de2de57d6920e22b66cd53ada90b635e895db90 (commit)
      from  c0406dba44d5c2d51c732430699f7304a1b4511f (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 8de2de57d6920e22b66cd53ada90b635e895db90
Author: Andy Wingo <address@hidden>
Date:   Fri Oct 16 17:56:39 2009 +0200

    fix brainfuck for new tree-il, and add tests
    
    * test-suite/Makefile.am:
    * test-suite/tests/brainfuck.test: Add a brainfuck test.
    
    * module/system/base/compile.scm: Also export read-and-compile.
    
    * module/language/tree-il/spec.scm (join): Fix the joiner in the
      0-expression case.
    
    * module/language/tree-il/primitives.scm (+): Recognize (+ x -1) as 1-.
    
    * module/language/brainfuck/parse.scm (read-brainfuck): Return EOF if we
      actually received EOF, and there were no expressions read.
    
    * module/language/brainfuck/compile-tree-il.scm (compile-body): Fix the
      compiler for the new format of "lambda" in tree-il.

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

Summary of changes:
 module/language/brainfuck/compile-tree-il.scm |   19 +++++----
 module/language/brainfuck/parse.scm           |   13 +++++-
 module/language/tree-il/primitives.scm        |   14 ++++--
 module/language/tree-il/spec.scm              |    6 ++-
 module/system/base/compile.scm                |    5 ++-
 test-suite/Makefile.am                        |    1 +
 test-suite/tests/brainfuck.test               |   51 +++++++++++++++++++++++++
 7 files changed, 91 insertions(+), 18 deletions(-)
 create mode 100644 test-suite/tests/brainfuck.test

diff --git a/module/language/brainfuck/compile-tree-il.scm 
b/module/language/brainfuck/compile-tree-il.scm
index 0aaa112..d478aeb 100644
--- a/module/language/brainfuck/compile-tree-il.scm
+++ b/module/language/brainfuck/compile-tree-il.scm
@@ -168,14 +168,17 @@
         ((<bf-loop> . ,body)
          (let ((iterate (gensym)))
            (emit `(letrec (iterate) (,iterate)
-                          ((lambda () () 
-                             (if (apply (primitive =)
-                                        (apply (primitive vector-ref)
-                                               (lexical tape) (lexical 
pointer))
-                                        (const 0))
-                                 (void)
-                                 (begin ,(compile-body body)
-                                        (apply (lexical ,iterate))))))
+                          ((lambda ()
+                             (lambda-case
+                              ((() #f #f #f () #f)
+                               (if (apply (primitive =)
+                                          (apply (primitive vector-ref)
+                                                 (lexical tape) (lexical 
pointer))
+                                          (const 0))
+                                   (void)
+                                   (begin ,(compile-body body)
+                                          (apply (lexical ,iterate)))))
+                              #f)))
                      (apply (lexical ,iterate))))))
 
         (else (error "unknown brainfuck instruction" (car in))))))))
diff --git a/module/language/brainfuck/parse.scm 
b/module/language/brainfuck/parse.scm
index 0a71638..81dbdd9 100644
--- a/module/language/brainfuck/parse.scm
+++ b/module/language/brainfuck/parse.scm
@@ -66,9 +66,16 @@
 (define (read-brainfuck p)
   (let iterate ((parsed '()))
     (let ((chr (read-char p)))
-      (if (or (eof-object? chr) (eq? #\] chr))
-        (reverse-without-nops parsed)
-        (iterate (cons (process-input-char chr p) parsed))))))
+      (cond
+       ((eof-object? chr)
+        (let ((parsed (reverse-without-nops parsed)))
+          (if (null? parsed)
+              chr ;; pass on the EOF object
+              parsed)))
+       ((eqv? chr #\])
+        (reverse-without-nops parsed))
+       (else
+        (iterate (cons (process-input-char chr p) parsed)))))))
 
 
 ; This routine processes a single character of input and builds the
diff --git a/module/language/tree-il/primitives.scm 
b/module/language/tree-il/primitives.scm
index 98633f0..8d93760 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -210,11 +210,15 @@
                  (let ((y (const-exp y)))
                    (and (number? y) (exact? y) (= y 1))))
             (1+ x)
-            (if (and (const? x)
-                     (let ((x (const-exp x)))
-                       (and (number? y) (exact? x) (= x 1))))
-                (1+ y)
-                (+ x y)))
+            (if (and (const? y)
+                 (let ((y (const-exp y)))
+                   (and (number? y) (exact? y) (= y -1))))
+                (1- x)
+                (if (and (const? x)
+                         (let ((x (const-exp x)))
+                           (and (number? y) (exact? x) (= x 1))))
+                    (1+ y)
+                    (+ x y))))
   (x y z . rest) (+ x (+ y z . rest)))
   
 (define-primitive-expander *
diff --git a/module/language/tree-il/spec.scm b/module/language/tree-il/spec.scm
index c47134e..b2ebcfc 100644
--- a/module/language/tree-il/spec.scm
+++ b/module/language/tree-il/spec.scm
@@ -20,6 +20,7 @@
 
 (define-module (language tree-il spec)
   #:use-module (system base language)
+  #:use-module (system base pmatch)
   #:use-module (language glil)
   #:use-module (language tree-il)
   #:use-module (language tree-il compile-glil)
@@ -29,7 +30,10 @@
   (apply write (unparse-tree-il exp) port))
 
 (define (join exps env)
-  (make-sequence #f exps))
+  (pmatch exps
+    (() (make-void #f))
+    ((,x) x)
+    (else (make-sequence #f exps))))
 
 (define-language tree-il
   #:title      "Tree Intermediate Language"
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index 4d1c92f..da3f7cd 100644
--- a/module/system/base/compile.scm
+++ b/module/system/base/compile.scm
@@ -28,7 +28,10 @@
   #:use-module (ice-9 receive)
   #:export (syntax-error 
             *current-language*
-            compiled-file-name compile-file compile-and-load
+            compiled-file-name
+            compile-file
+            compile-and-load
+            read-and-compile
             compile
             decompile)
   #:export-syntax (call-with-compile-error-catch))
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index f47ccba..145975c 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -26,6 +26,7 @@ SCM_TESTS = tests/alist.test                  \
            tests/arbiters.test                 \
            tests/asm-to-bytecode.test          \
            tests/bit-operations.test           \
+           tests/brainfuck.test                \
            tests/bytevectors.test              \
            tests/c-api.test                    \
            tests/chars.test                    \
diff --git a/test-suite/tests/brainfuck.test b/test-suite/tests/brainfuck.test
new file mode 100644
index 0000000..f612fb5
--- /dev/null
+++ b/test-suite/tests/brainfuck.test
@@ -0,0 +1,51 @@
+;;;; test brainfuck compilation -*- scheme -*-
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;; 
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 
USA
+
+(define-module (test-suite tests brainfuck)
+  #:use-module (test-suite lib)
+  #:use-module (system base compile))
+
+;; This program taken from Wikipedia's brainfuck introduction page.
+(define prog "
+   +++ +++ +++ +           initialize counter (cell #0) to 10
+   [                       use loop to set the next four cells to 70/100/30/10
+       > +++ +++ +             add  7 to cell #1
+       > +++ +++ +++ +         add 10 to cell #2 
+       > +++                   add  3 to cell #3
+       > +                     add  1 to cell #4
+       <<< < -                 decrement counter (cell #0)
+   ]                   
+   >++ .                   print 'H'
+   >+.                     print 'e'
+   +++ +++ +.              print 'l'
+   .                       print 'l'
+   +++ .                   print 'o'
+   >++ .                   print ' '
+   <<+ +++ +++ +++ +++ ++. print 'W'
+   >.                      print 'o'
+   +++ .                   print 'r'
+   --- --- .               print 'l'
+   --- --- --.             print 'd'
+   >+.                     print '!'")
+
+(pass-if
+ (equal? (with-output-to-string
+          (lambda ()
+            (call-with-input-string
+             prog
+             (lambda (port)
+               (read-and-compile port #:from 'brainfuck #:to 'value)))))
+         "Hello World!"))


hooks/post-receive
-- 
GNU Guile