brainfuck->scheme

1 files changed, 78 insertions, 0 deletions

diff --git a/bf2s.scm b/bf2s.scm
new file mode 100644
index 0000000..60def3e
--- /dev/null
+++ b/bf2s.scm
@@ -0,0 +1,78 @@
+;;; Brainfuck->Scheme compiler.
+;;; 
+;;; Copyright 2024 Peter McGoron
+;;; 
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;; 
+;;;     http://www.apache.org/licenses/LICENSE-2.0
+;;; 
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+;;; Turn a reversed list of Scheme commands into a thunk.
+(define (assemble-function ins)
+  `(lambda ()
+     ,@(reverse ins)))
+
+;;; Compile all brainfuck instructions in LST, coming after the Scheme
+;;; commands in INS.
+(define (compile lst ins)
+  (if (null? lst)
+      (assemble-function ins)
+      (case (car lst)
+        ((#\>) (compile (cdr lst)
+                        (cons '(set! dptr (+ dptr 1)) ins)))
+        ((#\<) (compile (cdr lst)
+                        (cons '(set! dptr (- dptr 1)) ins)))
+        ((#\+) (compile (cdr lst)
+                        (cons
+                         '(vector-set! data dptr
+                                       (+ (vector-ref data dptr) 1))
+                         ins)))
+        ((#\-) (compile (cdr lst)
+                        (cons
+                         '(vector-set! data dptr
+                                       (- (vector-ref data dptr) 1))
+                         ins)))
+        ((#\.) (compile (cdr lst)
+                        (cons '(display (integer->char (vector-ref data dptr))) ins)))
+        ((#\,) (compile (cdr lst)
+                        (cons '(vector-set! data dptr
+                                            (char->integer (read-char))) ins)))
+        ((#\[) (let ((rest (compile (cdr lst) '())))
+                 (if (not (pair? rest))
+                     (error "unmatched [")
+                     (let ((between (car rest))
+                           (after-uncompiled (cdr rest)))
+                       (compile after-uncompiled
+                                (cons `(letrec ((between ,between))
+                                         (if (not (zero? (vector-ref data dptr)))
+                                             (between)))
+                                      ins))))))
+        ((#\]) (cons (assemble-function
+                      (cons '(if (not (zero? (vector-ref data dptr)))
+                                 (between))
+                            ins))
+                     (cdr lst)))
+        (else (compile (cdr lst) ins)))))
+
+(define (brainfuck->scheme str)
+  `(lambda (data dptr)
+     (,(compile (string->list str) '()))))
+
+(define (brainfuck->scheme-from-file filename)
+  (brainfuck->scheme
+   (call-with-port (open-input-file filename)
+     (lambda (port)
+       (let loop ((str ""))
+         (if (eof-object? (peek-char port))
+             str
+             (loop (string-append str (read-line port)))))))))
+
+(define (execute scheme)
+  ((eval scheme) (make-vector 4096) 0))