Brainf*ck interpreter written in newLISP

brainfuck.lsp

#!/usr/bin/newlisp

;; @module brainfuck.lsp
;; @description Brainf*ck Interpreter
;; @version 1.0 - first commit
;; @version 1.1 - speedup by using array. doc changes.
;; @author KOBAYASHI Shigeru <shigeru.kb[at]gmail.com>, 2009-2011
;; @license MIT licence
;; @location https://gist.github.com/242690
;;
;; This file is @link http://en.wikipedia.org/wiki/Brainfuck Brainfuck interpreter
;; written in newLISP. Works newlisp v.10.2.8 (or lator).
;;
;; <h3>command-line options</h3>
;; see details `newlisp brainfuck.lsp -help'
;;
;; @example
;; eval FILENAME with memsize=30000
;; $ newlisp brainfuck.lsp -memsize 30000 -eval-file FILENAME
;;
;; eval FILENAME from standard-input
;; $ cat FILENAME | newlisp brainfuck.lsp -
;;
;; eval from URL-FILE
;; $ newlisp brainfuck.lsp -eval-file http://localhost/bf-source.b
;;
;; convert FILENAME to C program
;; $ newlisp brainfuck.lsp -bfc FILENAME > foo.c
;;
;; print "Hello World!"
;; $ newlisp brainfuck.lsp -hello
;;
;; read and print loop
;; $ newlisp brainfuck.lsp -eval ",[.,]"


;;; Code:

(context 'Brainfuck)

(setf stdin 0 stdout 1 stderr 2)

(define (make-vector size)
  (array size '(0))
  ;(dup 0 size)
)

(setf memsize 512)
(setf memory (make-vector memsize))

(define (trim-comment src)
  (replace "[^[]+,.<>[-]]" src "" 0))

(define (Brainfuck:eval src)
  (setf src (trim-comment src))
  (let ((ptr 0) (i 0)
        (srclen (length src)))
    (setf memory (make-vector memsize))
    (catch
        (while (< i srclen)
          ;; (begin (! "tput clear") (println (i src)) (sleep 25))
          (case (src i)
            (">" (++ ptr))
            ("<" (-- ptr))
            ("+" (++ (memory ptr)))
            ("-" (-- (memory ptr)))
            ("." (write-char stdout (memory ptr)))
            ("," (setf (memory ptr) (or (read-char stdin)
                                        (throw 'eof))))
            ("[" (when (= (memory ptr) 0)
                   (let ((level 1))
                     (while (!= level 0)
                       (++ i)
                       (case (src i)
                         ("[" (++ level))
                         ("]" (-- level)))))))
            ("]" (when (!= (memory ptr) 0)
                   (let ((level 1))
                     (while (!= level 0)
                       (-- i)
                       (case (src i)
                         ("[" (-- level))
                         ("]" (++ level))))))))
          (++ i))))
  true)

(define (bfc src-text)
  (let ((buffer "")
        (-> (lambda ()
              (write-line buffer (apply string (args))))))
    ;; (-> "/* " src-text "*/")
    (-> "#include <stdio.h>")
    (-> "int main() {")
    (-> "  char mem[" memsize "]={0};")
    (-> "  char *p=mem;")
    (dostring (c src-text)
      (case (char c)
        (">" (-> "++p;"))
        ("<" (-> "--p;"))
        ("+" (-> "++*p;"))
        ("-" (-> "--*p;"))
        ("." (-> "putchar(*p);"))
        ("," (-> "*p = getchar();"))
        ("[" (-> "while (*p) {"))
        ("]" (-> "}"))))
    (-> "  return 0;")
    (-> "}")
    buffer))

;(define (bfc-optimize src-text) )

(define (eval-file filename)
  (Brainfuck:eval (read-file! filename)))

(define (bfc-file filename)
  (bfc (read-file! filename)))

(define (eval-stream (fd stdin))
  (Brainfuck:eval (echo fd "")))

(define (hello)
  (Brainfuck:eval [text]
// print "Hello World!"
++++++++++[>+++++++>++++++++++>+++>+<<<<-]>++.>+.+
++++++..+++.>++.<<+++++++++++++++.>.+++.------.---
-----.>+.>.
[/text]))

;;; Utility functions

(define (read-file! filename)
  (or (read-file filename)
      ;; :if-does-not-exist
      (throw-error (cons filename (sys-error)))))

(define (echo in (out stdout))
  (while (read-line in)
    (write-line out))
  (cond ((string? out) out)
        ("else" true)))

;;; Call interactively

(signal 2 exit)                         ; SIGINT (Ctrl-C)

;;;###Usage
(setf help-text [text]
Brainf*ck interpreter for newLISP
Useage: newlisp brainfuck.lsp [option]... [file]...

Options:
  -memsize MEMSIZE              set internal memory size MEMSIZE
  -eval TEXT                    eval TEXT directly
  -eval-file FILENAME           eval from FILENAME
  -                             eval from standard intput
  -bfc FILENAME                 convert FILENAME to C program
  -cc FILENAME                  same as `-bfc' and execute it [for debug]
  -help                         display this message
[/text])

(dolist (arg $main-args)
  (case arg
    ("-memsize" (setf memsize (or (int (main-args (+ $idx 1))) memsize)))
    ("-eval" (Brainfuck:eval (main-args (+ $idx 1)))
             (exit))
    ("-eval-file" (eval-file (main-args (+ $idx 1)))
                  (exit))
    ("-bfc" (print (bfc-file (main-args (+ $idx 1))))
            (exit))
    ("-" (eval-stream stdin)
         (exit))
    ("-hello" (hello)
              (exit))
    ("-cc" (let (cfile "bfc.c")
             (and (write-file cfile (bfc-file (main-args (+ $idx 1))))
                  (! (println
                      (case ostype
                        ("Win32" ; require mingw-gcc
                         (setq cfile (real-path cfile))
                         (format {gcc "%s" && a.exe && del a.exe "%s"} cfile cfile))
                        (true
                         (format {gcc "%s" && ./a.out && rm a.out "%s"} cfile cfile))))))
             (exit)))
    ("-help" (print help-text)
             (exit))
    ))

(context MAIN)
;;; EOF