module/language/brainfuck/compile-scheme.scm

   1 ;;; Brainfuck for GNU Guile
   2
   3 ;; Copyright (C) 2009, 2013 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        ,@(compile-body (cdr exp))
  59        (write-char #\newline))
  60     env
  61     env))
  62
  63
  64 ;; Compile a list of instructions to get a list of Scheme codes.  As we always
  65 ;; strip off the car of the instructions-list and cons the result onto the
  66 ;; result-list, it will get out in reversed order first; so we have to (reverse)
  67 ;; it on return.
  68
  69 (define (compile-body instructions)
  70   (let iterate ((cur instructions)
  71                 (result '()))
  72     (if (null? cur)
  73       (reverse result)
  74       (let ((compiled (compile-instruction (car cur))))
  75         (iterate (cdr cur) (cons compiled result))))))
  76
  77
  78 ;; Compile a single instruction to Scheme, using the direct representations
  79 ;; all of Brainfuck's instructions have.
  80
  81 (define (compile-instruction ins)
  82   (case (car ins)
  83
  84     ;; Pointer moval >< is done simply by something like:
  85     ;; (set! pointer (+ pointer +-1))
  86     ((<bf-move>)
  87      (let ((dir (cadr ins)))
  88        `(set! pointer (+ pointer ,dir))))
  89
  90     ;; Cell increment +- is done as:
  91     ;; (vector-set! tape pointer (+ (vector-ref tape pointer) +-1))
  92     ((<bf-increment>)
  93      (let ((inc (cadr ins)))
  94        `(vector-set! tape pointer (+ (vector-ref tape pointer) ,inc))))
  95
  96     ;; Output . is done by converting the cell's integer value to a character
  97     ;; first and then printing out this character:
  98     ;; (write-char (integer->char (vector-ref tape pointer)))
  99     ((<bf-print>)
 100      '(write-char (integer->char (vector-ref tape pointer))))
 101
 102     ;; Input , is done similarly, read in a character, get its ASCII code and
 103     ;; store it into the current cell:
 104     ;; (vector-set! tape pointer (char->integer (read-char)))
 105     ((<bf-read>)
 106      '(vector-set! tape pointer (char->integer (read-char))))
 107
 108     ;; For loops [...] we use a named let construction to execute the body until
 109     ;; the current cell gets zero.  The body is compiled via a recursive call
 110     ;; back to (compile-body).
 111     ;; (let iterate ()
 112     ;;   (if (not (= (vector-ref! tape pointer) 0))
 113     ;;     (begin
 114     ;;       <body>
 115     ;;       (iterate))))
 116     ((<bf-loop>)
 117      `(let iterate ()
 118         (if (not (= (vector-ref tape pointer) 0))
 119           (begin
 120             ,@(compile-body (cdr ins))
 121             (iterate)))))
 122
 123     (else (error "unknown brainfuck instruction " (car ins)))))