[bpt/guile.git] / module / language / brainfuck / compile-scheme.scm

;;; Brainfuck for GNU Guile

;; Copyright (C) 2009, 2013 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

;;; Code:

(define-module (language brainfuck compile-scheme)
  #:export (compile-scheme))

;; Compilation of Brainfuck to Scheme is pretty straight-forward.  For all of
;; brainfuck's instructions, there are basic representations in Scheme 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 Scheme code like:
;; (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.
;;
;; 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-scheme exp env opts)
  (values
    `(let ((pointer 0)
           (tape (make-vector ,tape-size 0)))
       ,@(compile-body (cdr exp))
       (write-char #\newline))
    env
    env))


;; Compile a list of instructions to get a list of Scheme codes.  As we always
;; strip off the car of the instructions-list and cons the result onto the
;; result-list, it will get out in reversed order first; so we have to (reverse)
;; it on return.

(define (compile-body instructions)
  (let iterate ((cur instructions)
                (result '()))
    (if (null? cur)
      (reverse result)
      (let ((compiled (compile-instruction (car cur))))
        (iterate (cdr cur) (cons compiled result))))))


;; Compile a single instruction to Scheme, using the direct representations
;; all of Brainfuck's instructions have.

(define (compile-instruction ins)
  (case (car ins)

    ;; Pointer moval >< is done simply by something like:
    ;; (set! pointer (+ pointer +-1))
    ((<bf-move>)
     (let ((dir (cadr ins)))
       `(set! pointer (+ pointer ,dir))))

    ;; Cell increment +- is done as:
    ;; (vector-set! tape pointer (+ (vector-ref tape pointer) +-1))
    ((<bf-increment>)
     (let ((inc (cadr ins)))
       `(vector-set! tape pointer (+ (vector-ref tape pointer) ,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>)
     '(write-char (integer->char (vector-ref tape 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>)
     '(vector-set! tape pointer (char->integer (read-char))))

    ;; For loops [...] we use a named let 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>)
     `(let iterate ()
        (if (not (= (vector-ref tape pointer) 0))
          (begin
            ,@(compile-body (cdr ins))
            (iterate)))))

    (else (error "unknown brainfuck instruction " (car ins)))))
Commit	Line	Data
6370a6ad DK	1	;;; Brainfuck for GNU Guile
6370a6ad DK	2
60ce72b9	3	;; Copyright (C) 2009, 2013 Free Software Foundation, Inc.
6370a6ad	4
fe2400b2 AW	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.
6370a6ad	9	;;
fe2400b2	10	;; This library is distributed in the hope that it will be useful,
6370a6ad	11	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
fe2400b2 AW	12	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
fe2400b2 AW	13	;; Lesser General Public License for more details.
6370a6ad	14	;;
fe2400b2 AW	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
6370a6ad DK	18
	19	;;; Code:
	20
	21	(define-module (language brainfuck compile-scheme)
	22	#:export (compile-scheme))
	23
fe2400b2 AW	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.
e63d888e DK	33
e63d888e DK	34
fe2400b2	35	;; Define the length to use for the tape.
e63d888e	36
6370a6ad DK	37	(define tape-size 30000)
6370a6ad DK	38
e63d888e	39
fe2400b2 AW	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.
e63d888e	53
6370a6ad DK	54	(define (compile-scheme exp env opts)
	55	(values
	56	`(let ((pointer 0)
	57	(tape (make-vector ,tape-size 0)))
60ce72b9 AW	58	,@(compile-body (cdr exp))
60ce72b9 AW	59	(write-char #\newline))
6370a6ad DK	60	env
	61	env))
	62
e63d888e	63
fe2400b2 AW	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.
e63d888e	68
6370a6ad DK	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
e63d888e	77
fe2400b2 AW	78	;; Compile a single instruction to Scheme, using the direct representations
fe2400b2 AW	79	;; all of Brainfuck's instructions have.
e63d888e	80
6370a6ad DK	81	(define (compile-instruction ins)
	82	(case (car ins)
	83
fe2400b2 AW	84	;; Pointer moval >< is done simply by something like:
fe2400b2 AW	85	;; (set! pointer (+ pointer +-1))
6370a6ad DK	86	((<bf-move>)
	87	(let ((dir (cadr ins)))
	88	`(set! pointer (+ pointer ,dir))))
	89
fe2400b2 AW	90	;; Cell increment +- is done as:
fe2400b2 AW	91	;; (vector-set! tape pointer (+ (vector-ref tape pointer) +-1))
6370a6ad DK	92	((<bf-increment>)
	93	(let ((inc (cadr ins)))
	94	`(vector-set! tape pointer (+ (vector-ref tape pointer) ,inc))))
	95
fe2400b2 AW	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)))
6370a6ad DK	99	((<bf-print>)
	100	'(write-char (integer->char (vector-ref tape pointer))))
	101
fe2400b2 AW	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)))
6370a6ad DK	105	((<bf-read>)
	106	'(vector-set! tape pointer (char->integer (read-char))))
	107
fe2400b2 AW	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))))
6370a6ad	116	((<bf-loop>)
e63d888e	117	`(let iterate ()
6370a6ad DK	118	(if (not (= (vector-ref tape pointer) 0))
	119	(begin
	120	,@(compile-body (cdr ins))
e63d888e	121	(iterate)))))
6370a6ad DK	122
6370a6ad DK	123	(else (error "unknown brainfuck instruction " (car ins)))))