summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/language/brainfuck/compile-tree-il.scm19
-rw-r--r--module/language/brainfuck/parse.scm13
-rw-r--r--module/language/tree-il/primitives.scm14
-rw-r--r--module/language/tree-il/spec.scm6
-rw-r--r--module/system/base/compile.scm5
-rw-r--r--test-suite/Makefile.am1
-rw-r--r--test-suite/tests/brainfuck.test51
7 files changed, 91 insertions, 18 deletions
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 @@
((<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 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!"))