Brainfuck in Gauche

bfi.scm

; $Id: bfi.scm,v 1.5 2002/10/09 04:52:50 skimu Exp $
;;;
;;;  Brainfuck
;;;

; The Language (from http://www.muppetlabs.com/~breadbox/bf/)

; A Brainfuck program has an implicit byte pointer, called "the pointer",
; which is free to move around within an array of 30000 bytes, initially 
; all set to zero. The pointer itself is initialized to point to the 
; beginning of this array. 

; The Brainfuck programming language consists of eight commands, each of 
; which is represented as a single character. 

; >     Increment the pointer.
; <     Decrement the pointer.
; +	Increment the byte at the pointer.
; -	Decrement the byte at the pointer.
; .	Output the byte at the pointer.
; ,	Input a byte and store it in the byte at the pointer.
; [	Jump past the matching ] if the byte at the pointer is zero.
; ]	Jump to the matching [.

;;;
;;;
;;;
(use gauche.sequence)

(define a (make-vector 30000 0))  ; the array
(define p 0)                      ; the pointer

(define iport #f)

(define (bfi codes)
  (if (null? codes)
      0
      (begin
	(if (pair? (car codes))
	    (do () ((= (ref a p) 0) #t)
	      (bfi (car codes)))
	    (case (car codes)
	      ((#\+) (inc! (ref a p)))
	      ((#\-) (dec! (ref a p)))
	      ((#\<) (dec! p))
	      ((#\>) (inc! p))
	      ((#\.) (write-byte (ref a p)) (flush))
	      ((#\,) (set! (ref a p) (read-byte iport)))
	      (else
	       (errorf "Unknown command `~a'~%" (car codes)))))
	(bfi (cdr codes)))))

(define (parse codes)
  (let ((c (read-char)))
    (if (eof-object? c) (reverse codes)
	(case c
	  ((#\+ #\- #\< #\> #\. #\,)
	   (parse (cons c codes)))
	  ((#\[)
	   (parse  (cons (parse '()) codes)))
	  ((#\])
	   (reverse codes))
	  (else		  ; just ignore unknown word (may be comments)
           (parse codes))))))

(define (run-string str)
  (with-input-from-string str
    (lambda ()
      (vector-fill! a 0)
      (set! p 0)
      (bfi (parse '())))))

(define (main args)
  (with-error-handler 
   (lambda (e) (format (current-error-port) "~%ERROR: ~a~%" (slot-ref e 'message)))
   (lambda ()
     (if (null? (cdr args))
	 (bfi (parse '()))
	 (begin
	   (set! iport (current-input-port))
	   (with-input-from-file (cadr args)
	     (lambda ()
	       (bfi (parse '())))))))))

;;;
;;;  Debug utilities
;;;

(define (peek beg end)
  (newline)
  (do ((i beg (+ i 1)))
      ((>= i end) #t)
    (format #t "~5,,,,5S " (integer->char (ref a i))))
  (newline)
  (do ((i beg (+ i 1)))
      ((>= i end) #t)
    (format #t "~5D " (ref a i)))
  (newline))

(define (p10) (peek 0 10))
(define (p1)  (peek 0  1))

;;;
;;; Example
;;;

;;(run-string "
;;  >+++++++++[<++++++++>-]<.>+++++++[<++++>-]<+.+++++++..+++.[-]>++++++++[<++++>-]
;;  <.>+++++++++++[<+++++>-]<.>++++++++[<+++>-]<.+++.------.--------.[-]>++++++++[
;;  <++++>-]<+.[-]++++++++++.
;;")
;; -| Hello World!
;; -> #t


;;; EOF