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.

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

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

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 *

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"

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

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			\

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!"))