Interpretador de COW em Chicken Scheme

Dando seqüência à série implementações de interpretadores de linguagens que não servem para nada (iniciada com um interpretador de assembly), a seguir está a implementação de um interpretador para a linguagem COW em Chicken Scheme.

Da página da linguagem:

The COW programming language was designed with the bovine in mind. Given that cows have somewhat limited vocabulary skills, it seemed natural to incorporate only the words they know into the language. As a result, all instructions are some variation on "moo" which just so happens to be the only word they really understand.

Abaixo estão o código da implementação e um programa exemplo:

(use srfi-1)

(define *memory* (make-vector 1 0))
(define *program* #f)
(define *ip* 0) ;; instruction pointer
(define *mp* 0) ;; memory pointer
(define *register* #f)
(define instructions
  '(("moo" . 0) ("mOo" . 1) ("moO" . 2) ("mOO" . 3) ("Moo" . 4)
    ("MOo" . 5) ("MoO" . 6) ("MOO" . 7) ("OOO" . 8) ("MMM" . 9)
    ("OOM" . 10) ("oom" . 11)))

(define (sanitize-code code)
  ;; removes non-cow instructions and returns a list containing valid cow code
  (map string->symbol
       (filter (cut alist-ref <> instructions equal?)
               (flatten (map string-split code)))))

(define (get-address snippet from to)
  (let ((scope 0)
        (address #f))
    (let loop ((code snippet))
      (if (and (null? code) (not address))
          (terminate)
          (let* ((current-instr (car code))
                 (instr (cdr current-instr))
                 (pos (car current-instr)))
            (cond ((eq? instr from)
                   (set! scope (add1 scope))
                   (loop (cdr code)))
                  ((and (not (zero? scope)) (eq? instr to))
                   (set! scope (sub1 scope))
                   (loop (cdr code)))
                  ((and (zero? scope) (eq? instr to)) pos)
                  (else (loop (cdr code)))))))))

(define (MOO-address)
  (get-address (reverse (take *program* (sub1 *ip*))) 'moo 'MOO))

(define (moo-address)
  (get-address (drop *program* (+ 2 *ip*)) 'MOO 'moo))

(define (mem-get) (vector-ref *memory* *mp*))

(define (maybe-resize-mem!)
  (let ((vlen (vector-length *memory*)))
    (when (>= (add1 *mp*) vlen)
      (set! *memory* (vector-resize *memory* (add1 vlen) 0)))))

(define (mem-set! val)
  (maybe-resize-mem!)
  (vector-set! *memory* *mp* val))

(define (terminate #!optional (exit-code 0))
  (print "Terminating.")
  (exit exit-code))

(define (moo-interpreter file)
  (let* ((sane-code (sanitize-code (read-lines file)))
         (program-len (length sane-code))
         (debug? (getenv "COWDEBUG")))
    (set! *program* (map cons (iota program-len) sane-code))
    (when debug? (display "prog> ") (pp *program*))
    (let loop ()
      (when debug?
        (print "-----------------------------------")
        (print *program*)
        (display "mem> ") (pp *memory*)
        (print "*mp*> " *mp*)
        (print "*ip*> " *ip*)
        (print "*register*>  " *register*))
      (when (> *ip* program-len) (terminate))
        (if (null? *program*)
            (terminate)
            (let* ((current-instr (alist-ref *ip* *program*))
                   ;; special-instr => instructions that modify *ip*
                   (special-instrs '(MOO mOO moo))
                   (special-instr? (memq current-instr special-instrs)))
              (when (eq? current-instr 'mOO)
                (unless (memq (mem-get) (map cdr instructions))
                  (terminate))
                (set! current-instr (alist-ref (mem-get) *program*))
                (set! special-instr? (memq current-instr special-instrs)))
              (when debug?
                (display "current-instr> ")
                (display (if special-instr? "(*) " ""))
                (pp  current-instr))
              (case current-instr
                ((moo) (set! *ip* (MOO-address)))
                ((mOo) (maybe-resize-mem!) (set! *mp* (sub1 *mp*)))
                ((moO) (maybe-resize-mem!) (set! *mp* (add1 *mp*)))
                ((Moo) (if (zero? (mem-get))
                           (mem-set! (string->number (->string (read-line))))
                           (print (integer->char (mem-get)))))
                ((MOo) (mem-set! (sub1 (mem-get))))
                ((MoO) (mem-set! (add1 (mem-get))))
                ((MOO) (if (zero? (mem-get))
                           (set! *ip* (add1 (moo-address)))
                           (set! *ip* (add1 *ip*))))
                ((OOO) (mem-set! 0))
                ((MMM) (if *register*
                           (begin (mem-set! *register*)
                                  (set! *register* #f))
                           (set! *register* (mem-get))))
                ((OOM) (print (mem-get)))
                ((oom) (mem-set! (string->number (read-line)))))
              (unless special-instr? (set! *ip* (add1 *ip*)))))
        (loop))))

(define (usage #!optional (exit-code 0))
  (print "Usage: " (program-name) " <input file>")
  (exit exit-code))

(let ((args (command-line-arguments)))
  (if (null? args)
      (usage 1)
      (let ((file (car args)))
        (if (file-exists? (car args))
            (moo-interpreter file)
            (begin
              (print file ": not found.")
              (exit 1))))))

Obs.: se a variável COWDEBUG estiver definida no ambiente, o interpretador exibe informações para depuração.

Aqui está a implementação de um gerador da série de Fibonacci em COW (um dos exemplos disponibilizados no site da linguagem):

MoO
moO
MoO
mOo
[[ main loop ]]
MOO
[[ print first number ]]
OOM
[[ temp copy of first number ]]
MMM
moO
moO
MMM
mOo
mOo
[[ store second number off in the first position now ]]
moO
MMM
mOo
MMM
[[ move back to temp number ]]
moO
moO
[[ use temp to add to first and store in second in loop ]]
MOO
MOo
mOo
MoO
moO
moo
mOo
mOo
moo

Executando este exemplo com o interpretador, temos:

$ csi -s cow.scm fib.cow
1
1
2
3
5
8
13
21
34
55
89
144
233
377
610
987
1597
2584
4181
6765
10946
17711
28657
...

Algum voluntário para implementar as Distributed Digestion eXtentions? :-)