brainfuckのコードを自動生成するコンパイラ

S式からbrainfuckのコードを自動生成するプログラムを書いてみました。
コード生成が目的ではなくて単にできるだろうかと気になったのでやってみました。gaucheを使いました。
brainfuck インタプリタをスタックマシンっぽく使って動作します。
変数が使えるところが個人的には面白いかもと思っています。
最適化とか全然考えていないので、大変非効率なコードが出ます。今後これ以上何か改良する予定もありません。

(define vtable `())
(define depth 0)
(define (incr) (set! depth (+ depth 1)))
(define (decr) (set! depth (- depth 1)))
(define (addvar name) (set! vtable (cons `(,name . ,depth) vtable)))
(define (delvar) (set! vtable (cdr vtable)))
(define (findvar name) (cdr (assoc name vtable)))

(define (putn c n)
  (let loop ((i 0))
    (if (< i n)
      (begin
        (display c)
        (loop (+ i 1))
        ))))

(define (set_int n)
  (if (> n 0)
    (if (<= n 20)
        (putn "+" n)
        (begin
          (display ">")
          (putn "+" (quotient n 10))
          (display "[<++++++++++>-]<")
          (putn "+" (remainder n 10))
          ))
    (if (<= -20 n)
      (putn "-" (- n))
      (begin
        (display ">")
        (putn "+" (quotient (- n) 10))
        (display "[<---------->-]<")
        (putn "-" (remainder (- n) 10))
        ))
    ))

(define (emit_int n)
  (begin
    (display ">")
    (set_int n)
    (incr)
    #t
    ))

(define (emit_puts str)
  (begin
    (display ">")
    (incr)
    (let ((n (string-length str)))
    (let loop ((i 0) (v 0))
      (if (< i n)
        (let ((c (string-byte-ref str i)))
          (begin
            (set_int (- c v))
            (display ".")
            (loop (+ i 1) c)
          ))
        )))
    (drop)
    #f
    ))

(define (emit_var name)
  (let ((n (- depth (findvar name))))
    (begin
      (putn "<" n)
      (display "[")
      (putn ">" (+ n 1))
      (display "+>+")
      (putn "<" (+ n 2))
      (display "-]")
      (putn ">" (+ n 2))
      (display "[")
      (putn "<" (+ n 2))
      (display "+")
      (putn ">" (+ n 2))
      (display "-]<")
      (incr)
      #t
      )))

(define (emit_assign name e)
  (let ((n (- depth (findvar name))))
    (begin
      (transl e)
      (decr)
      ; zero-clear
      (putn "<" (+ n 1))
      (display "[-]")
      (putn ">" (+ n 1))
      ; copy value
      (display "[")
      (putn "<" (+ n 1))
      (display "+")
      (putn ">" (+ n 1))
      (display "-]<")
      #f
      )))

(define (drop) (begin (display "[-]<") (decr)))

(define (transl expr)
  (cond
    ((integer? expr) (emit_int expr))
    ((char? expr)    (emit_int (char->integer expr)))
    ((eq? `get expr) (begin (display ">,") (incr) #t))
    ((symbol? expr)  (emit_var expr))
    ((eq? `put (car expr)) (begin (transl (cadr expr)) (display ".") (drop) #f))
    ((eq? `puts (car expr)) (emit_puts (cadr expr)))
    ((eq? `puti (car expr))
     (transl `(let v ,(cadr expr) (let x v
       (do
         (if (> x 100) (do (put (+ #\0 (/ v 100)) (set v (% v 100)))))
         (if (> x 10)  (do (put (+ #\0 (/ v 10)) (set v (% v 10)))))
         (put (+ #\0 v))
         )))))
    ((eq? `+ (car expr))
     (begin
       (transl (cadr expr))
       (transl (caddr expr))
       (display "[<+>-]<")
       (decr)
       #t
       ))
    ((eq? `- (car expr))
     (begin
       (transl (cadr expr))
       (transl (caddr expr))
       (display "[<->-]<")
       (decr)
       #t
       ))
    ((eq? `* (car expr))
     (transl `(let v 0 (let a ,(cadr expr) (let b ,(caddr expr)
       (do (while (!= b 0) (do (set v (+ v a)) (set b (- b 1)))) v))))))
    ((eq? `/ (car expr))
     (transl `(let v 0 (let a ,(cadr expr) (let b ,(caddr expr)
       (do (while (> a b) (do (set v (+ v 1)) (set a (- a b)))) v))))))
    ((eq? `% (car expr))
     (transl `(let a ,(cadr expr) (let b ,(caddr expr)
       (do (while (> a b) (set a (- a b))) a)))))
    ((eq? `sub (car expr))
     (begin
       (transl (cadr expr))
       (transl (caddr expr))
       (display "[<[>>+>+<<<-]>>>[<<<+>>>-]<[[-]<<->>]<-]<")
       (decr)
       #t
       ))
    ((eq? `!= (car expr)) (transl `(- ,(cadr expr) ,(caddr expr))))
    ((eq? `== (car expr))
     (begin
       (transl `(- ,(cadr expr) ,(caddr expr))))
       (emit_int 1)
       (display "<[>[-]<-]>[<+>-]<")
       (decr)
       )
    ((eq? `> (car expr)) (transl `(sub ,(cadr expr) ,(caddr expr))))
    ((eq? `< (car expr)) (transl `(sub ,(caddr expr) ,(cadr expr))))
    ((eq? `>= (car expr)) (transl `(sub (+ ,(cadr expr) 1) ,(caddr expr))))
    ((eq? `<= (car expr)) (transl `(sub (+ ,(caddr expr) 1) ,(cadr expr))))
    ((eq? `do (car expr))
     (let loop ((e (cdr expr)) (r #f))
       (if (pair? e)
         (begin
           (if r (drop))
           (loop (cdr e) (transl (car e)))
           )
         r)))
    ((eq? `while (car expr))
     (begin
       (transl (cadr expr))
       (display "[")
       (if (transl (caddr expr)) (drop))
       (drop)
       (transl (cadr expr))
       (display "]")
       (drop)
       #f
       ))
    ((eq? `if (car expr))
     (if (null? (cdddr expr))
       (transl `(if-nonzero ,(cadr expr) (caddr expr)))
       (transl `(let c ,(cadr expr) (do (if-nonzero c ,(caddr expr)) (if-zero c ,(cadddr expr)))))
       ))
    ((eq? `if-nonzero (car expr))
     (begin
       (transl (cadr expr))
       (display "[[-]")
       (if (transl (caddr expr)) (drop))
       (display "]")
       (drop)
       #f
       ))
    ((eq? `if-zero (car expr))
     (begin
       (transl (cadr expr))
       (emit_int 1)
       (display "<[>[-]<-]>[<+>-]<")
       (decr)
       (display "[[-]")
       (if (transl (caddr expr)) (drop))
       (display "]")
       (drop)
       #f
       ))
    ((eq? `let (car expr))
     (transl (caddr expr))
     (addvar (cadr expr))
     (if (transl (cadddr expr))
       (display "<[-]>[<+>-]<")
       )
     (delvar)
     #t
     )
    ((eq? `set (car expr)) (emit_assign (cadr expr) (caddr expr)))
    ))

(define (compile expr) (begin (transl expr) (display "\n")))

使い方

% gosh
gosh> (load "./bfgen.scm")
#t

表示

gosh> (compile `(put #\x))
>>++++++++++++[<++++++++++>-]<.[-]<
#<undef>
gosh> (compile `(puts "hello world"))
>>++++++++++[<++++++++++>-]<++++.---.+++++++..+++.>+++++++[<---------->-]<---------.>++++++++[<++++++++++>-]<+++++++.--------.+++.------.--------.[-]<
#<undef>

入力

gosh> (compile `(put get))
>,.[-]<
#<undef>

四則演算(+,-,*,/,%)。乗算は加算、除算は減算で実装しているのでめちゃくちゃ遅いです。

gosh> (compile `(put (+ #\0 3)))
>>++++[<++++++++++>-]<++++++++>+++[<+>-]<.[-]<
#<undef>

制御構造(do,if,while)。比較演算(==,!=,<,>,<=,>=)も用意しています。

gosh> (compile `(do (puts "hello") (puts " ") (puts "world")))
>>++++++++++[<++++++++++>-]<++++.---.+++++++..+++.[-]<>>+++[<++++++++++>-]<++.[-]<>>+++++++++++[<++++++++++>-]<+++++++++.--------.+++.------.--------.[-]<
#<undef>
gosh> (compile `(if (< 0 1) (puts "foo") (puts "bar")))
>+>[<[>>+>+<<<-]>>>[<<<+>>>-]<[[-]<<->>]<-]<[>+>+<<-]>>[<<+>>-]<[[-]>>++++++++++[<++++++++++>-]<++.+++++++++..[-]<][-]<[>+>+<<-]>>[<<+>>-]<>+<[>[-]<-]>[<+>-]<[[-]>>+++++++++[<++++++++++>-]<++++++++.-.+++++++++++++++++.[-]<][-]<
#<undef>
gosh> (compile `(while 1 (puts "foo")))
>+[>>++++++++++[<++++++++++>-]<++.+++++++++..[-]<[-]<>+][-]<
#<undef>

変数(定義はlet，破壊的代入はset)

gosh> (compile `(let x 1 (set x (+ x 1) (put #\0 x))))
>+[>+>+<<-]>>[<<+>>-]<>+[<+>-]<<[-]>[<+>-]<
#<undef>

以上を使うと例えばHello Worldを10行表示するコードとかをこんな感じで自動生成できます。

gosh> (compile `(let i 0 (while (< i 10) (do (puts "Hello World\n") (set i (+ i 1))))))
>>++++++++++<[>>+>+<<<-]>>>[<<<+>>>-]<[<[>>+>+<<<-]>>>[<<<+>>>-]<[[-]<<->>]<-]<[>>+++++++[<++++++++++>-]<++.>++[<++++++++++>-]<+++++++++.+++++++..+++.>+++++++[<---------->-]<---------.>+++++[<++++++++++>-]<+++++.>++[<++++++++++>-]<++++.+++.------.--------.>+++++++++[<---------->-]<.[-]<<[>>+>+<<<-]>>>[<<<+>>>-]<>+[<+>-]<<<[-]>>[<<+>>-]<[-]<>++++++++++<[>>+>+<<<-]>>>[<<<+>>>-]<[<[>>+>+<<<-]>>>[<<<+>>>-]<[[-]<<->>]<-]<][-]<
#<undef>

fizzbuzzとかも書けると思うけど数値の表示で100での除算とかが発生するから、遅すぎて使い物にならなそうです。