diff --git a/module/language/brainfuck/compile-tree-il.scm b/module/language/brainfuck/compile-tree-il.scm index 0aaa11274..d478aebba 100644 --- a/module/language/brainfuck/compile-tree-il.scm +++ b/module/language/brainfuck/compile-tree-il.scm @@ -168,14 +168,17 @@ (( . ,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 0a71638d8..81dbdd94a 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 98633f07a..8d9376042 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 c47134ed8..b2ebcfcab 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 4d1c92fd8..da3f7cd98 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 f47ccbafd..145975c9b 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 000000000..f612fb50a --- /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!"))