Gauche で Brainf*ck を作ってみた。

「Rubyで作る奇妙なプログラミング言語」を参考に Gauche で Brainf*ck を作ってみました。
使い方は、（この方法だと','による入力が無視される）

$ echo "+++++++++[>++++++++>+++++++++++>+++++<<<-]>.>++.+++++++..+++.>-.------------.<++++++++.--------.+++.------.--------.>+."|gosh brain.scm  
Hello, world!

または

$ gosh brain.scm  hello.bf
Hello, world!

です。

#!/usr/bin/env gosh
;;; http://ja.wikipedia.org/wiki/Brainfuck
;;; Brainfuckの言語仕様 
;;;
;;; 処理系には byte型の配列があり、配列の要素はゼロで初期化される。
;;; また、その配列の要素のひとつを指すポインタがあり、ポインタは最初配列の先頭を指している。
;;; 実行可能な命令は次の8つのみである。
;;   1. > ポインタをインクリメントする。ポインタをptrとすると、
;;     C言語の「ptr++;」に相当する。
;;   2. < ポインタをデクリメントする。C言語の「ptr--;」に相当。
;;   3. + ポインタが指す値をインクリメントする。C言語の「(*ptr)++;」に相当。
;;   4. - ポインタが指す値をデクリメントする。C言語の「(*ptr)--;」に相当。
;;   5. . ポインタが指す値を出力する。C言語の「putchar(*ptr);」に相当。
;;   6. , 1バイトを入力してポインタが指す値に代入する。
;;      C言語の「*ptr=getchar();」に相当。
;;   7. [ ポインタが指す値が0なら、対応する ] の直後までジャンプする。
;;      C言語の「while(*ptr){」に相当。
;;   8. ] ポインタが指す値が0でないなら、対応する [ にジャンプする。
;;      C言語の「}」に相当。

(use srfi-1)
(use gauche.interactive)
(use srfi-43) ;;ベクタライブラリ

(define (set-pointer p operator)
  (set! p (operator p 1)))

(define (expand-mem memory pointer)
  (if (>= pointer (vector-length memory))
    (vector-append memory #(0))
    memory))

(define (mem-inc-dec memory pointer operator)
  (vector-set! memory pointer
               (operator (vector-ref memory pointer) 1)))

(define (mk-alist lst)
  (let loop((ls lst) (work '())(box_brackets '())(address 0))
    (cond
      ((null? ls)
        (if (null? work)
          box_brackets
          (error "preliminary stage" "too many '['.")))
      ((eq? (car ls) #\[ )
         (loop (cdr ls)(cons address work) box_brackets (+ address 1)))
      ((eq? (car ls) #\] )
         (loop (cdr ls)
               (cdr
                 (if (null? work)
                   (error "preliminary stage" "too many ']'.")
                   work))
                     ;; ']' のアドレスをキーに '[' のアドレス
               (cons (cons  address (car work))
                     ;; '[' のアドレスをキーに ']'  のアドレス
                     (cons (cons (car work) address)  ;;
                           box_brackets)) 
               (+ address 1)))
      (else 
         (loop (cdr ls) work box_brackets (+ address 1))))))

(define (error pc msg)
  (begin 
    (print "ERORR pc:" pc " msg:" msg)
    (exit 1)))

(define (string->char-number line pc)
  (let ((number (string->number line)))
    (if number
      (cond 
        ((< number 0) 0)
        ((> number 255) 255)
        (else number))
      (error pc "cannot convert into a number."))))

(define (run program-ls)
  (let ((tokens-vector   (list->vector program-ls))
         (bracket-address (alist->tree-map (mk-alist program-ls) = <)))
    (let loop((memory '#(0))(program-counter 0)(pointer 0))
      (if (>= program-counter (vector-length tokens-vector))
        #f
        (let ((token (vector-ref tokens-vector program-counter)))
          (case token
            ((#\>) (set! pointer (+ pointer 1))
                   (set! memory (expand-mem memory pointer)))
            ((#\<) (set! pointer (- pointer 1))
                   (if (< pointer 0) (error (number->string program-counter)
                                            "Cannot move to left.")))
            ((#\+) (mem-inc-dec memory pointer +))
            ((#\-) (mem-inc-dec memory pointer -))
            ((#\.) (display (integer->char (vector-ref memory pointer))))
            ((#\,) (vector-set! memory pointer 
                                (string->char-number (read-line) program-counter)))
            ((#\[) (if (= (vector-ref memory pointer) 0)
                     (set! program-counter
                           (tree-map-get bracket-address program-counter))))
            ((#\]) (unless (= (vector-ref memory pointer) 0)
                     (set! program-counter 
                           (tree-map-get bracket-address program-counter)))))
          ;;(print "s:" token " pc:" program-counter " po:" pointer " m:" memory)
          (loop memory (+ program-counter 1)  pointer ))))))

(define (read-from port)
  (let loop((ls '()) (char (read-char port)))
    (if (eof-object? char)
      (begin
        (close-input-port port)
        (reverse (cdr ls)))
      (loop (cons char ls) (read-char port)))))

(define (main args)
  (run 
    (if (null? (cdr args))
      (read-from (current-input-port))
      (read-from (open-input-file (first *argv*)))))
  0)