From 5c27902e5e01a94b22ebc51288500a3d36253293 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Sun, 21 Jun 2009 14:53:33 +0200
Subject: [PATCH] add brainfuck->tree-il compiler

* module/Makefile.am (BRAINFUCK_LANG_SOURCES): Compile at the end. Add
  compile-tree-il.scm.

* module/language/brainfuck/compile-tree-il.scm: New compiler, compiles
  to tree-il instead of scheme. I thought it would be more illustrative,
  though there are some uncommented bits.

* module/language/brainfuck/parse.scm: Modify not to put a header on the
  scheme representation. After all, we don't put <scheme> before scheme
  code, do we? :)

* module/language/brainfuck/spec.scm: Add tree-il compiler.

* module/language/tree-il.scm: Understand (set! (lexical foo) ...).

* module/system/base/language.scm: Update license. Actually, updates
  licenses on all these.
---
 module/Makefile.am                            |   7 +-
 module/language/brainfuck/compile-tree-il.scm | 153 ++++++++++++++++++
 module/language/brainfuck/parse.scm           |  35 ++--
 module/language/brainfuck/spec.scm            |  26 +--
 module/language/tree-il.scm                   |   3 +
 module/system/base/language.scm               |  24 +--
 6 files changed, 200 insertions(+), 48 deletions(-)
 create mode 100644 module/language/brainfuck/compile-tree-il.scm

diff --git a/module/Makefile.am b/module/Makefile.am
index 10ff5eaa1..a904a8f8e 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -41,7 +41,6 @@ SOURCES =								\
   $(SCHEME_LANG_SOURCES) 						\
   $(TREE_IL_LANG_SOURCES)						\
   $(GHIL_LANG_SOURCES) $(GLIL_LANG_SOURCES)				\
-  $(BRAINFUCK_LANG_SOURCES)						\
   $(ASSEMBLY_LANG_SOURCES) $(BYTECODE_LANG_SOURCES)			\
   $(OBJCODE_LANG_SOURCES) $(VALUE_LANG_SOURCES)				\
 									\
@@ -51,6 +50,7 @@ SOURCES =								\
   $(OOP_SOURCES)							\
   $(SYSTEM_SOURCES)                                                     \
   $(ECMASCRIPT_LANG_SOURCES)						\
+  $(BRAINFUCK_LANG_SOURCES)						\
   $(SCRIPTS_SOURCES)
 
 ## test.scm is not currently installed.
@@ -114,9 +114,10 @@ ECMASCRIPT_LANG_SOURCES =			\
   language/ecmascript/spec.scm
 
 BRAINFUCK_LANG_SOURCES =			\
-  language/brainfuck/spec.scm			\
   language/brainfuck/parse.scm			\
-  language/brainfuck/compile-scheme.scm
+  language/brainfuck/compile-scheme.scm		\
+  language/brainfuck/compile-tree-il.scm	\
+  language/brainfuck/spec.scm
 
 SCRIPTS_SOURCES =				\
   scripts/PROGRAM.scm				\
diff --git a/module/language/brainfuck/compile-tree-il.scm b/module/language/brainfuck/compile-tree-il.scm
new file mode 100644
index 000000000..c9916310c
--- /dev/null
+++ b/module/language/brainfuck/compile-tree-il.scm
@@ -0,0 +1,153 @@
+;;; Brainfuck for GNU Guile
+
+;; Copyright (C) 2009 Free Software Foundation, Inc.
+
+;; 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
+
+;;; Commentary:
+
+;; Brainfuck is a simple language that mostly mimics the operations of a
+;; Turing machine. This file implements a compiler from Brainfuck to
+;; Guile's Tree-IL.
+
+;;; Code:
+
+(define-module (language brainfuck compile-tree-il)
+  #:use-module (system base pmatch)
+  #:use-module (language tree-il)
+  #:export (compile-tree-il))
+
+;; Compilation of Brainfuck is pretty straight-forward. For all of
+;; brainfuck's instructions, there are basic representations in Tree-IL
+;; we only have to generate.
+;;
+;; Brainfuck's pointer and data-tape are stored in the variables pointer and
+;; tape, where tape is a vector of integer values initially set to zero.  Pointer
+;; starts out at position 0.
+;; Our tape is thus of finite length, with an address range of 0..n for
+;; some defined upper bound n depending on the length of our tape.
+
+
+;; Define the length to use for the tape.
+
+(define tape-size 30000)
+
+
+;; This compiles a whole brainfuck program. This constructs a Tree-IL
+;; code equivalent to Scheme code like this:
+;;
+;; (let ((pointer 0)
+;;       (tape (make-vector tape-size 0)))
+;;   (begin
+;;     <body>
+;;     (write-char #\newline)))
+;;
+;; So first the pointer and tape variables are set up correctly, then the
+;; program's body is executed in this context, and finally we output an
+;; additional newline character in case the program does not output one.
+;;
+;; Note that we're generating the S-expression representation of
+;; Tree-IL, then using parse-tree-il to turn it into the actual Tree-IL
+;; data structures. This makes the compiler more pleasant to look at,
+;; but we do lose is the ability to propagate source information. Since
+;; Brainfuck is so obtuse anyway, this shouldn't matter ;-)
+;;
+;; TODO: Find out and explain the details about env, the three return values and
+;; how to use the options.  Implement options to set the tape-size, maybe.
+
+(define (compile-tree-il exp env opts)
+  (values
+   (parse-tree-il
+    `(let (pointer tape) (pointer tape)
+          ((const 0)
+           (apply (primitive make-vector) (const ,tape-size) (const 0)))
+       ,(compile-body exp)))
+   env
+   env))
+
+
+;; Compile a list of instructions to a Tree-IL expression.
+
+(define (compile-body instructions)
+  (let lp ((in instructions) (out '()))
+    (define (emit x)
+      (lp (cdr in) (cons x out)))
+    (cond
+     ((null? in)
+      ;; No more input, build our output.
+       (cond
+        ((null? out) '(void)) ; no output
+        ((null? (cdr out)) (car out)) ; single expression
+        (else `(begin ,@(reverse out))))  ; sequence
+       )
+     (else
+      (pmatch (car in)
+
+        ;; Pointer moves >< are done simply by something like:
+        ;;   (set! pointer (+ pointer +-1))
+        ((<bf-move> ,dir)
+         (emit `(set! (lexical pointer)
+                      (apply (primitive +) (lexical pointer) (const ,dir)))))
+
+        ;; Cell increment +- is done as:
+        ;;   (vector-set! tape pointer (+ (vector-ref tape pointer) +-1))
+        ((<bf-increment> ,inc) 
+         (emit `(apply (primitive vector-set!) (lexical tape) (lexical pointer)
+                       (apply (primitive +)
+                              (apply (primitive vector-ref)
+                                     (lexical tape) (lexical pointer))
+                              (const ,inc)))))
+
+        ;; Output . is done by converting the cell's integer value to a
+        ;; character first and then printing out this character:
+        ;;   (write-char (integer->char (vector-ref tape pointer)))
+        ((<bf-print>) 
+         (emit `(apply (primitive write-char)
+                       (apply (primitive integer->char)
+                              (apply (primitive vector-ref)
+                                     (lexical tape) (lexical pointer))))))
+
+        ;; Input , is done similarly, read in a character, get its ASCII
+        ;; code and store it into the current cell:
+        ;;   (vector-set! tape pointer (char->integer (read-char)))
+        ((<bf-read>) 
+         (emit `(apply (primitive vector-set!)
+                       (lexical tape) (lexical pointer)
+                       (apply (primitive char->integer)
+                              (apply (primitive read-char))))))
+
+        ;; For loops [...] we use a letrec construction to execute the body until
+        ;; the current cell gets zero.  The body is compiled via a recursive call
+        ;; back to (compile-body).
+        ;;   (let iterate ()
+        ;;     (if (not (= (vector-ref! tape pointer) 0))
+        ;;         (begin
+        ;;          <body>
+        ;;          (iterate))))
+        ((<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))))))
+                     (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 54dbaeecc..0a71638d8 100644
--- a/module/language/brainfuck/parse.scm
+++ b/module/language/brainfuck/parse.scm
@@ -2,20 +2,20 @@
 
 ;; Copyright (C) 2009 Free Software Foundation, Inc.
 
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
+;; 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 program is distributed in the hope that it will be useful,
+;; 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 General Public License for more details.
+;; 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 General Public License
-;; along with this program; see the file COPYING.  If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; 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
 
 ;;; Code:
 
@@ -35,13 +35,6 @@
 ; object.
 
 
-; Read a brainfuck program from an input port.  We construct the <brainfuck>
-; program and read in the instructions using (read-body).
-
-(define (read-brainfuck p)
-  `(<brainfuck> ,@(read-body p)))
-
-
 ; While reading a number of instructions in sequence, all of them are cons'ed
 ; onto a list of instructions; thus this list gets out in reverse order.
 ; Additionally, for "comment characters" (everything not an instruction) we
@@ -70,7 +63,7 @@
 ; For instance, the basic program so just echo one character would be:
 ; ,.]
 
-(define (read-body p)
+(define (read-brainfuck p)
   (let iterate ((parsed '()))
     (let ((chr (read-char p)))
       (if (or (eof-object? chr) (eq? #\] chr))
@@ -80,7 +73,7 @@
 
 ; This routine processes a single character of input and builds the
 ; corresponding instruction.  Loop bodies are read by recursively calling
-; back (read-body).
+; back (read-brainfuck).
 ;
 ; For the poiner movement commands >< and the cell increment/decrement +-
 ; commands, we only use one instruction form each and specify the direction of
@@ -94,5 +87,5 @@
     ((#\-) '(<bf-increment> -1))
     ((#\.) '(<bf-print>))
     ((#\,) '(<bf-read>))
-    ((#\[) `(<bf-loop> ,@(read-body p)))
+    ((#\[) `(<bf-loop> ,@(read-brainfuck p)))
     (else '(<bf-nop>))))
diff --git a/module/language/brainfuck/spec.scm b/module/language/brainfuck/spec.scm
index a303984b2..a4ba60f82 100644
--- a/module/language/brainfuck/spec.scm
+++ b/module/language/brainfuck/spec.scm
@@ -2,24 +2,25 @@
 
 ;; Copyright (C) 2009 Free Software Foundation, Inc.
 
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
+;; 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 program is distributed in the hope that it will be useful,
+;; 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 General Public License for more details.
+;; 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 General Public License
-;; along with this program; see the file COPYING.  If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; 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
 
 ;;; Code:
 
 (define-module (language brainfuck spec)
+  #:use-module (language brainfuck compile-tree-il)
   #:use-module (language brainfuck compile-scheme)
   #:use-module (language brainfuck parse)
   #:use-module (system base language)
@@ -37,6 +38,7 @@
   #:title	"Guile Brainfuck"
   #:version	"1.0"
   #:reader	(lambda () (read-brainfuck (current-input-port)))
-  #:compilers	`((scheme . ,compile-scheme))
+  #:compilers	`((tree-il . ,compile-tree-il)
+                  (scheme . ,compile-scheme))
   #:printer	write
   )
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index da483b3cc..0f8448a44 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -94,6 +94,9 @@
      ((lexical ,name ,sym) (guard (symbol? name) (symbol? sym))
       (make-lexical-ref loc name sym))
 
+     ((set! (lexical ,name) ,exp) (guard (symbol? name))
+      (make-lexical-set loc name name (retrans exp)))
+
      ((set! (lexical ,name ,sym) ,exp) (guard (symbol? name) (symbol? sym))
       (make-lexical-set loc name sym (retrans exp)))
 
diff --git a/module/system/base/language.scm b/module/system/base/language.scm
index 8ae4d9667..3670c53d9 100644
--- a/module/system/base/language.scm
+++ b/module/system/base/language.scm
@@ -1,21 +1,21 @@
 ;;; Multi-language support
 
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
 
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
+;; 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 program is distributed in the hope that it will be useful,
+;; 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 General Public License for more details.
+;; 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 General Public License
-;; along with this program; see the file COPYING.  If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; 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
 
 ;;; Code:
 
-- 
2.20.1