module/language/brainfuck/compile-scheme.scm

   1 ;;; Brainfuck for GNU Guile
   2
   3 ;; Copyright (C) 2009 Free Software Foundation, Inc.
   4
   5 ;; This library is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the GNU Lesser General Public
   7 ;; License as published by the Free Software Foundation; either
   8 ;; version 3 of the License, or (at your option) any later version.
   9 ;;
  10 ;; This library is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;; Lesser General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU Lesser General Public
  16 ;; License along with this library; if not, write to the Free Software
  17 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 ;;; Code:
  20
  21 (define-module (language brainfuck compile-scheme)
  22   #:export (compile-scheme))
  23
  24 ;; Compilation of Brainfuck to Scheme is pretty straight-forward.  For all of
  25 ;; brainfuck's instructions, there are basic representations in Scheme we
  26 ;; only have to generate.
  27 ;;
  28 ;; Brainfuck's pointer and data-tape are stored in the variables pointer and
  29 ;; tape, where tape is a vector of integer values initially set to zero.  Pointer
  30 ;; starts out at position 0.
  31 ;; Our tape is thus of finite length, with an address range of 0..n for
  32 ;; some defined upper bound n depending on the length of our tape.
  33
  34
  35 ;; Define the length to use for the tape.
  36
  37 (define tape-size 30000)
  38
  39
  40 ;; This compiles a whole brainfuck program.  This constructs a Scheme code like:
  41 ;; (let ((pointer 0)
  42 ;;       (tape (make-vector tape-size 0)))
  43 ;;   (begin
  44 ;;     <body>
  45 ;;     (write-char #\newline)))
  46 ;;
  47 ;; So first the pointer and tape variables are set up correctly, then the
  48 ;; program's body is executed in this context, and finally we output an
  49 ;; additional newline character in case the program does not output one.
  50 ;;
  51 ;; TODO: Find out and explain the details about env, the three return values and
  52 ;; how to use the options.  Implement options to set the tape-size, maybe.
  53
  54 (define (compile-scheme exp env opts)
  55   (values
  56     `(let ((pointer 0)
  57            (tape (make-vector ,tape-size 0)))
  58        ,@(if (not (eq? '<brainfuck> (car exp)))
  59            (error "expected brainfuck program")
  60            `(begin
  61               ,@(compile-body (cdr exp))
  62               (write-char #\newline))))
  63     env
  64     env))
  65
  66
  67 ;; Compile a list of instructions to get a list of Scheme codes.  As we always
  68 ;; strip off the car of the instructions-list and cons the result onto the
  69 ;; result-list, it will get out in reversed order first; so we have to (reverse)
  70 ;; it on return.
  71
  72 (define (compile-body instructions)
  73   (let iterate ((cur instructions)
  74                 (result '()))
  75     (if (null? cur)
  76       (reverse result)
  77       (let ((compiled (compile-instruction (car cur))))
  78         (iterate (cdr cur) (cons compiled result))))))
  79
  80
  81 ;; Compile a single instruction to Scheme, using the direct representations
  82 ;; all of Brainfuck's instructions have.
  83
  84 (define (compile-instruction ins)
  85   (case (car ins)
  86
  87     ;; Pointer moval >< is done simply by something like:
  88     ;; (set! pointer (+ pointer +-1))
  89     ((<bf-move>)
  90      (let ((dir (cadr ins)))
  91        `(set! pointer (+ pointer ,dir))))
  92
  93     ;; Cell increment +- is done as:
  94     ;; (vector-set! tape pointer (+ (vector-ref tape pointer) +-1))
  95     ((<bf-increment>)
  96      (let ((inc (cadr ins)))
  97        `(vector-set! tape pointer (+ (vector-ref tape pointer) ,inc))))
  98
  99     ;; Output . is done by converting the cell's integer value to a character
 100     ;; first and then printing out this character:
 101     ;; (write-char (integer->char (vector-ref tape pointer)))
 102     ((<bf-print>)
 103      '(write-char (integer->char (vector-ref tape pointer))))
 104
 105     ;; Input , is done similarly, read in a character, get its ASCII code and
 106     ;; store it into the current cell:
 107     ;; (vector-set! tape pointer (char->integer (read-char)))
 108     ((<bf-read>)
 109      '(vector-set! tape pointer (char->integer (read-char))))
 110
 111     ;; For loops [...] we use a named let construction to execute the body until
 112     ;; the current cell gets zero.  The body is compiled via a recursive call
 113     ;; back to (compile-body).
 114     ;; (let iterate ()
 115     ;;   (if (not (= (vector-ref! tape pointer) 0))
 116     ;;     (begin
 117     ;;       <body>
 118     ;;       (iterate))))
 119     ((<bf-loop>)
 120      `(let iterate ()
 121         (if (not (= (vector-ref tape pointer) 0))
 122           (begin
 123             ,@(compile-body (cdr ins))
 124             (iterate)))))
 125
 126     (else (error "unknown brainfuck instruction " (car ins)))))