Commit | Line | Data |
---|---|---|
6370a6ad DK |
1 | ;;; Brainfuck for GNU Guile. |
2 | ||
3 | ;; Copyright (C) 2009 Free Software Foundation, Inc. | |
4 | ||
5 | ;; This program is free software; you can redistribute it and/or modify | |
6 | ;; it under the terms of the GNU General Public License as published by | |
7 | ;; the Free Software Foundation; either version 2, or (at your option) | |
8 | ;; any later version. | |
9 | ;; | |
10 | ;; This program 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 | |
13 | ;; GNU General Public License for more details. | |
14 | ;; | |
15 | ;; You should have received a copy of the GNU General Public License | |
16 | ;; along with this program; see the file COPYING. If not, write to | |
17 | ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
18 | ;; Boston, MA 02111-1307, USA. | |
19 | ||
20 | ;;; Code: | |
21 | ||
22 | (define-module (language brainfuck parse) | |
23 | #:export (read-brainfuck)) | |
24 | ||
25 | (define (read-brainfuck p) | |
26 | `(<brainfuck> ,@(read-body p))) | |
27 | ||
28 | (define (reverse-without-nops lst) | |
29 | (let iterate ((cur lst) | |
30 | (result '())) | |
31 | (if (null? cur) | |
32 | result | |
33 | (let ((head (car cur)) | |
34 | (tail (cdr cur))) | |
35 | (if (eq? (car head) '<bf-nop>) | |
36 | (iterate tail result) | |
37 | (iterate tail (cons head result))))))) | |
38 | ||
39 | (define (read-body p) | |
40 | (let iterate ((parsed '())) | |
41 | (let ((chr (read-char p))) | |
42 | (if (or (eof-object? chr) (eq? #\] chr)) | |
43 | (reverse-without-nops parsed) | |
44 | (iterate (cons (process-input-char chr p) parsed)))))) | |
45 | ||
46 | (define (process-input-char chr p) | |
47 | (case chr | |
48 | ((#\>) '(<bf-move> 1)) | |
49 | ((#\<) '(<bf-move> -1)) | |
50 | ((#\+) '(<bf-increment> 1)) | |
51 | ((#\-) '(<bf-increment> -1)) | |
52 | ((#\.) '(<bf-print>)) | |
53 | ((#\,) '(<bf-read>)) | |
54 | ((#\[) `(<bf-loop> ,@(read-body p))) | |
55 | (else '(<bf-nop>)))) |