brainfuck: Renamed source file; added BFEVAL.

Pascal J. Bourguignon [2021-12-04 00:19]
brainfuck: Renamed source file; added BFEVAL.
Filename
small-cl-pgms/brainfuck/bf-test.lisp
small-cl-pgms/brainfuck/bf.lisp
small-cl-pgms/brainfuck/brainfuck-test.lisp
small-cl-pgms/brainfuck/brainfuck.lisp
small-cl-pgms/brainfuck/com.informatimago.small-cl-pgms.brainfuck.asd
small-cl-pgms/brainfuck/com.informatimago.small-cl-pgms.brainfuck.test.asd
diff --git a/small-cl-pgms/brainfuck/bf-test.lisp b/small-cl-pgms/brainfuck/bf-test.lisp
deleted file mode 100644
index 13167df..0000000
--- a/small-cl-pgms/brainfuck/bf-test.lisp
+++ /dev/null
@@ -1,46 +0,0 @@
-;;;; -*- mode:lisp;coding:utf-8 -*-
-;;;;**************************************************************************
-;;;;FILE:               bf-test.lisp
-;;;;LANGUAGE:           Common-Lisp
-;;;;SYSTEM:             Common-Lisp
-;;;;USER-INTERFACE:     NONE
-;;;;DESCRIPTION
-;;;;
-;;;;    Test bf.lisp
-;;;;
-;;;;AUTHORS
-;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
-;;;;MODIFICATIONS
-;;;;    2015-02-23 <PJB> Created.
-;;;;BUGS
-;;;;LEGAL
-;;;;    AGPL3
-;;;;
-;;;;    Copyright Pascal J. Bourguignon 2015 - 2016
-;;;;
-;;;;    This program is free software: you can redistribute it and/or modify
-;;;;    it under the terms of the GNU Affero General Public License as published by
-;;;;    the Free Software Foundation, either version 3 of the License, or
-;;;;    (at your option) any later version.
-;;;;
-;;;;    This program is distributed in the hope that it will be useful,
-;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-;;;;    GNU Affero General Public License for more details.
-;;;;
-;;;;    You should have received a copy of the GNU Affero General Public License
-;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
-;;;;**************************************************************************
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (setf *readtable* (copy-readtable nil)))
-(defpackage "COM.INFORMATIMAGO.SMALL-CL-PGMS.BRAINFUCK.TEST"
-  (:use "COMMON-LISP"
-        "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.SIMPLE-TEST"
-        "COM.INFORMATIMAGO.SMALL-CL-PGMS.BRAINFUCK")
-  (:export "TEST/ALL"))
-(in-package "COM.INFORMATIMAGO.SMALL-CL-PGMS.BRAINFUCK.TEST")
-
-(define-test test/all ()
-  :success)
-
-;;;; THE END ;;;;
diff --git a/small-cl-pgms/brainfuck/bf.lisp b/small-cl-pgms/brainfuck/bf.lisp
deleted file mode 100644
index 9647653..0000000
--- a/small-cl-pgms/brainfuck/bf.lisp
+++ /dev/null
@@ -1,925 +0,0 @@
-;;;; -*- mode:lisp; coding:utf-8 -*-
-;;;;****************************************************************************
-;;;;FILE:               bf.lisp
-;;;;LANGUAGE:           Common-Lisp
-;;;;SYSTEM:             Common-Lisp
-;;;;USER-INTERFACE:     NONE
-;;;;DESCRIPTION
-;;;;
-;;;;    Brainfuck emulator
-;;;;    -1- A Brainfuck Virtual Machine                 COMPLETE
-;;;;    -2- A Brainfuck to Lisp *optimizing* compiler   COMPLETE
-;;;;    -3- Implementing a lisp in Brainfuck            sketches
-;;;;
-;;;;AUTHORS
-;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
-;;;;MODIFICATIONS
-;;;;    2005-09-11 <PJB> Created
-;;;;BUGS
-;;;;LEGAL
-;;;;    AGPL3
-;;;;
-;;;;    Copyright Pascal J. Bourguignon 2005 - 2016
-;;;;
-;;;;    This program is free software: you can redistribute it and/or modify
-;;;;    it under the terms of the GNU Affero General Public License as published by
-;;;;    the Free Software Foundation, either version 3 of the License, or
-;;;;    (at your option) any later version.
-;;;;
-;;;;    This program is distributed in the hope that it will be useful,
-;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-;;;;    GNU Affero General Public License for more details.
-;;;;
-;;;;    You should have received a copy of the GNU Affero General Public License
-;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>
-;;;;****************************************************************************
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (setf *readtable* (copy-readtable nil)))
-(defpackage "COM.INFORMATIMAGO.SMALL-CL-PGMS.BRAINFUCK"
-  (:use "COMMON-LISP")
-  #+mocl (:shadowing-import-from "COM.INFORMATIMAGO.MOCL.KLUDGES.MISSING"
-                                 "*TRACE-OUTPUT*"
-                                 "*LOAD-VERBOSE*"
-                                 "*LOAD-PRINT*"
-                                 "ARRAY-DISPLACEMENT"
-                                 "CHANGE-CLASS"
-                                 "COMPILE"
-                                 "COMPLEX"
-                                 "ENSURE-DIRECTORIES-EXIST"
-                                 "FILE-WRITE-DATE"
-                                 "INVOKE-DEBUGGER" "*DEBUGGER-HOOK*"
-                                 "LOAD"
-                                 "LOGICAL-PATHNAME-TRANSLATIONS"
-                                 "MACHINE-INSTANCE"
-                                 "MACHINE-VERSION"
-                                 "NSET-DIFFERENCE"
-                                 "RENAME-FILE"
-                                 "SUBSTITUTE-IF"
-                                 "TRANSLATE-LOGICAL-PATHNAME"
-                                 "PRINT-NOT-READABLE"
-                                 "PRINT-NOT-READABLE-OBJECT")
-  (:export "BFVM" "MAKE-BFVM" "BFVM-MEM" "BFVM-MC" "BFVM-PGM" "BFVM-PC")
-  (:export "BFLOAD" "BFVM-RUN")
-  (:export "BFCOMPILE-FILE" "BFCOMPILE" "*BFCOMPILE*"))
-(in-package  "COM.INFORMATIMAGO.SMALL-CL-PGMS.BRAINFUCK")
-
-;;;----------------------------------------------------------------------
-;;; -1- A Brainfuck Virtual Machine
-;;;----------------------------------------------------------------------
-
-(defconstant +bfsize+ 30000)
-
-(defstruct bfvm
-  (mem (make-array +bfsize+ :element-type '(unsigned-byte 8) :initial-element 0))
-  (mc 0)
-  (pgm "" :type string)
-  (pc 0))
-
-
-(defun find-matching-close (pgm pc inc opn cls)
-  (incf pc inc)
-  (loop
-     with level = 0
-     until (and (zerop level)
-                (or (< pc 0)
-                    (<= (length pgm) pc)
-                    (char= cls (char pgm pc))))
-     do
-       ;; (print `(level ,level pc ,pc @pc ,(char pgm pc)))
-       (cond ((char= opn (char pgm pc)) (incf level))
-             ((char= cls (char pgm pc)) (decf level)))
-       (incf pc inc)
-     finally (return pc)))
-
-
-(defun bfload (file)
-  "Return a string containing the file"
-  (with-open-file (in file)
-    (let ((pgm (make-string (file-length in))))
-      (subseq pgm 0 (read-sequence pgm in)))))
-
-
-(defun bfvm-run (vm &key verbose)
-  (let* ((mem (bfvm-mem vm))
-         (mc  (bfvm-mc  vm))
-         (pgm (bfvm-pgm vm))
-         (pc  (bfvm-pc  vm))
-         (lpgm (length pgm))
-         (lmem (length mem)))
-    (macrolet ((in-range-p (counter limit) `(< -1 ,counter ,limit)))
-      (unwind-protect
-           (loop while (and (in-range-p pc lpgm) (in-range-p mc lmem)) do
-                (when verbose
-                  (format *trace-output*
-                          "PC:~5,'0D IR:~C M[~5,'0D]:~2,'0X  ~:*~4@A  ~4@A  ~C~%"
-                          pc
-                          (if (char= (char pgm pc) #\newline)
-                              #\space
-                              (char pgm pc))
-                          mc
-                          (aref mem mc)
-                          (if (<= 128 (aref mem mc))
-                              (- (aref mem mc) 256)
-                              (aref mem mc))
-                          (if (graphic-char-p (code-char (aref mem mc)))
-                              (code-char (aref mem mc))
-                              #\space))
-                  (force-output *trace-output*))
-                (case (char pgm pc)
-                  (#\>  (incf mc)
-                        (incf pc))
-                  (#\<  (decf mc)
-                        (incf pc))
-                  (#\+  (setf (aref mem mc) (mod (1+ (aref mem mc)) 256))
-                        (incf pc))
-                  (#\-  (setf (aref mem mc) (mod (1- (aref mem mc)) 256))
-                        (incf pc))
-                  (#\.  (princ (code-char (aref mem mc)))
-                        (incf pc))
-                  (#\,  (setf (aref mem mc) (mod (char-code (read-char)) 256))
-                        (incf pc))
-                  (#\[  (if (zerop (aref mem mc))
-                            (setf pc (find-matching-close pgm pc +1 #\[ #\]))
-                            (incf pc)))
-                  (#\]  (if (zerop (aref mem mc))
-                            (incf pc)
-                            (setf pc (find-matching-close pgm pc -1 #\] #\[))))
-                  (otherwise (incf pc))))
-        (setf (bfvm-mc vm) mc
-              (bfvm-pc vm) pc))))
-  (values))
-
-
-(defun test-vm ()
-  (time (bfvm-run (make-bfvm :pgm (bfload "99botles.bf")) :verbose nil)))
-
-
-
-;;;----------------------------------------------------------------------
-;;; -2- A Brainfuck to Lisp *optimizing* compiler
-;;;----------------------------------------------------------------------
-
-
-(defun bfparse (pgm)
-  (loop
-     with result = '()
-     with stack = '()
-     for ch across pgm
-     do (case ch
-          (#\> (push '(%forward  1) result))
-          (#\< (push '(%backward 1) result))
-          (#\+ (push '(%inc 1 0) result))
-          (#\- (push '(%dec 1 0) result))
-          (#\, (push '(%readc 0) result))
-          (#\. (push '(%princ 0) result))
-          (#\[ (push result stack)
-               (setf result (list '%while-nz)))
-          (#\] (setf result (cons (nreverse result) (pop stack)))))
-     finally (progn (when stack (error "Missing closing brackets"))
-                    (return-from bfparse (nreverse result)))))
-
-
-(defmacro %forward (offset)
-  `(incf mc ,offset))
-
-(defmacro %backward (offset)
-  `(decf mc ,offset))
-
-(defmacro %inc    (value offset)
-  `(setf (aref mem (+ mc ,offset))
-         (mod (+ (aref mem (+ mc ,offset)) ,value) 256)))
-
-(defmacro %dec    (value offset)
-  `(setf (aref mem (+ mc ,offset))
-         (mod (- (aref mem (+ mc ,offset)) ,value) 256)))
-
-(defmacro %readc  (offset)
-  `(setf (aref mem (+ mc ,offset)) (mod (char-code (read-char)) 256)))
-
-(defmacro %princ  (offset)
-  `(princ (code-char (aref mem (+ mc ,offset)))))
-
-(defmacro %while-nz (&body body)
-  (let ((lbeg (gensym "LOOP"))
-        (lend (gensym "ENDL")))
-    `(tagbody (when (zerop (aref mem mc)) (go ,lend))
-        ,lbeg
-        ,@body
-        (unless (zerop (aref mem mc)) (go ,lbeg))
-        ,lend)))
-
-
-(defun bfoptimize-1 (tgm)
-  (cond
-    ((null tgm) tgm)
-    ((equalp (first tgm) '(%while-nz (%dec 1 0)))
-     (cons '(%zero 0) (bfoptimize-1 (rest tgm))))
-    ((and (consp  (first tgm))
-          (member (first (first tgm)) '(%forward %backward %inc %dec))
-          (consp  (second tgm))
-          (eq     (first (first tgm)) (first (second tgm))))
-     (loop
-        for rtgm on (rest tgm)
-        with sum = (second (first tgm))
-        while (and (consp (first rtgm))
-                   (eq (first (first tgm)) (first (first rtgm))))
-        do (incf sum (second (first rtgm)))
-        finally (return (cons (list (first (first tgm)) sum)
-                              (bfoptimize-1 rtgm)))))
-    ((and (consp (first tgm)) (eq (first (first tgm)) '%while-nz))
-     (cons (cons '%while-nz (bfoptimize-1 (rest (first tgm))))
-           (bfoptimize-1 (rest tgm))))
-    (t (cons (first tgm) (bfoptimize-1 (rest tgm))))))
-
-
-(defmacro %zero    (offset)
-  `(setf (aref mem (+ mc ,offset)) 0))
-
-
-(defun bfoptimize-2 (tgm)
-  (cond
-    ((null tgm) tgm)
-    ((equal (first tgm) '(%zero 0))
-     (cond
-       ((and (consp (second tgm))
-             (eq (first  (second tgm)) '%inc))
-        (cons (list '%set (second (second tgm)))     (bfoptimize-2 (cddr tgm))))
-       ((and (consp (second tgm))
-             (eq (first  (second tgm)) '%dec))
-        (cons (list '%set (- (second (second tgm)))) (bfoptimize-2 (cddr tgm))))
-       (t (cons '(%set 0) (bfoptimize-2 (cdr tgm))))))
-    ((and (consp (first tgm))
-          (eq (first (first tgm)) '%dec))
-     (cons (list '%inc (- (second (first tgm))))  (bfoptimize-2 (rest tgm))))
-    ((and (consp (first tgm))
-          (eq (first (first tgm)) '%backward))
-     (cons (list '%offset (- (second (first tgm))))  (bfoptimize-2 (rest tgm))))
-        ((and (consp (first tgm))
-          (eq (first (first tgm)) '%forward))
-     (cons (list '%offset (second (first tgm)))  (bfoptimize-2 (rest tgm))))
-    ((and (consp (first tgm)) (eq (first (first tgm)) '%while-nz))
-     (cons (cons '%while-nz (bfoptimize-2 (rest (first tgm))))
-           (bfoptimize-2 (rest tgm))))
-    (t (cons (first tgm) (bfoptimize-2 (rest tgm))))))
-
-
-(defmacro %set    (value offset)
-  `(setf (aref mem (+ mc ,offset)) (mod ,value 256)))
-
-
-(defmacro %offset (offset)
-  `(incf mc ,offset))
-
-
-
-(defun bfoptimize-3-offset (tgm)
-  (loop
-     with result = '()
-     with offset = 0
-     for item in tgm
-     do (case (first item)
-          ((%offset)
-           (incf offset (second item)))
-          ((%inc %set)
-           (push `(,(first item) ,(second item) ,offset) result))
-          ((%readc %princ)
-           (push `(,(first item) ,(+ (second item) offset)) result))
-          (otherwise (error "unexpected item ~A" item)))
-     finally
-       (unless (zerop offset) (push `(%offset ,offset) result))
-       (return (nreverse result))))
-
-(defun bfoptimize-3 (tgm)
-  (let ((end (position '%while-nz tgm  :key (function first))))
-    (if end
-        (nconc (bfoptimize-3-offset (subseq tgm 0 end))
-               (cons (cons '%while-nz (bfoptimize-3 (rest (elt tgm end))))
-                     (bfoptimize-3 (subseq tgm (1+ end)))))
-        (bfoptimize-3-offset tgm))))
-
-
-;;; Uncomment these macros to trace the compiled forms:
-;;
-;; (defmacro %forward (offset)
-;;   `(progn (incf mc ,offset)
-;;           (print `(forward ,,offset --> mc = ,mc))))
-;;
-;; (defmacro %backward (offset)
-;;   `(progn (decf mc ,offset)
-;;           (print `(backward ,,offset --> mc = ,mc))))
-;;
-;; (defmacro %inc    (value offset)
-;;   `(progn (setf (aref mem (+ mc ,offset))
-;;                 (mod (+ (aref mem (+ mc ,offset)) ,value) 256))
-;;           (print `(inc ,,value ,,offset --> (aref mem ,(+ mc ,offset)) = ,(aref mem (+ mc ,offset))))))
-;;
-;; (defmacro %dec    (value offset)
-;;   `(progn (setf (aref mem (+ mc ,offset))
-;;                 (mod (- (aref mem (+ mc ,offset)) ,value) 256))
-;;           (print `(dec ,,value ,,offset --> (aref mem ,(+ mc ,offset)) = ,(aref mem (+ mc ,offset))))))
-;;
-;; (defmacro %readc  (offset)
-;;   `(progn (setf (aref mem (+ mc ,offset)) (mod (char-code (read-char)) 256))
-;;           (print `(readc ,,offset --> (aref mem ,(+ mc ,offset)) = ,(aref mem (+ mc ,offset))))))
-;;
-;; (defmacro %princ  (offset)
-;;   `(progn (princ (code-char (aref mem (+ mc ,offset))))
-;;           (print `(princ ,,offset --> (aref mem ,(+ mc ,offset)) = ,(aref mem (+ mc ,offset))))))
-;;
-;; (defmacro %while-nz (&body body)
-;;   (let ((lbeg (gensym "LOOP"))
-;;         (lend (gensym "ENDL")))
-;;     `(tagbody
-;;         (print `(while-nz ,',lbeg begin  (aref mem ,mc) = ,(aref mem mc)))
-;;         (when (zerop (aref mem mc)) (go ,lend))
-;;         ,lbeg
-;;         ,@body
-;;         (print `(while-nz ,',lbeg loop  (aref mem ,mc) = ,(aref mem mc)))
-;;         (unless (zerop (aref mem mc)) (go ,lbeg))
-;;         ,lend)))
-;;
-;; (defmacro %zero    (offset)
-;;   `(progn (setf (aref mem (+ mc ,offset)) 0)
-;;           (print `(zero ,offset --> (aref mem ,(+ mc offset)) = ,(aref mem (+ mc offset))))))
-;;
-;; (defmacro %set    (value offset)
-;;   `(progn (setf (aref mem (+ mc ,offset)) (mod ,value 256))
-;;           (print `(set ,,value ,,offset -->  (aref mem ,(+ mc ,offset)) = ,(aref mem (+ mc ,offset))))))
-;;
-;; (defmacro %offset (offset)
-;;   `(progn (incf mc ,offset)
-;;           (print `(offset ,,offset --> mc = ,mc))))
-
-
-
-(defvar *bfcompile* nil
-  "When true, bfcompile compiles also the generated Lisp code.")
-
-
-(defun bfcompile (pgm &key name ((:compile *bfcompile*) *bfcompile*))
-  "
-PGM:    a string containing the source of a Brainfuck program.
-RETURN: a lisp function taking a virtual machine
-        (only the memory and MC register are used),
-        and realizing the same program.
-"
-  (flet ((do-compile (lambda-form) (compile name lambda-form))
-         (do-eval    (lambda-form) (eval (if name
-                                        `(defun ,name (vm) (,lambda-form vm))
-                                        lambda-form))))
-    (funcall (if *bfcompile*
-                 (function do-compile)
-                 (function do-eval))
-             `(lambda (vm)
-                (let ((mem (bfvm-mem vm))
-                      (mc  (bfvm-mc  vm)))
-                  (unwind-protect
-                       (progn
-                         ,@(bfoptimize-3
-                            (bfoptimize-2
-                             (bfoptimize-1
-                              (bfparse pgm)))))
-                    (setf (bfvm-mc vm) mc)))))))
-
-
-(defun bfcompile-file (file &key ((:compile *bfcompile*) *bfcompile*))
-  "Combines bfcompile and bfload."
-  (bfcompile (bfload file) :compile *bfcompile*))
-
-
-(defun test-compiler ()
-  (time (funcall (bfcompile-file "99botles.bf")
-                 (make-bfvm)))
-  (time (funcall (bfcompile-file "99botles.bf" :compile t)
-                 (make-bfvm))))
-
-
-
-
-;;;----------------------------------------------------------------------
-;;; -3- Implementing a lisp in Brainfuck
-;;;----------------------------------------------------------------------
-
-
-;; lisp primitives:
-;;     () eq cons car cdr atom quote cond  lambda
-;;
-;; lisp registers stored in brainfuck memory:
-;;     | 0 , sph , spl , sph , spl | 1 , hph , hpl , hph , hpl |
-;;     | 2 , ach , acl , ach , acl |
-
-
-(defconstant +max-addr+ (1- (truncate +bfsize+ 5)))
-(defconstant +sc+ 1)
-(defconstant +sp+ 2 "stack pointer")
-(defconstant +hp+ 3 "heap  pointer")
-(defconstant +ix+ 4 "")
-(defconstant +ac+ 5 "accumulator a")
-(defconstant +bc+ 6 "accumulator b")
-(defconstant +ts+ 7)
-(defconstant +cn+ 8)
-(defconstant +min-addr+ 9)
-
-
-(defun store-imm-to-car (n)
-  (format nil ">[-]~A>[-]~A<<"
-          (make-string (truncate n 256) :initial-element #\+)
-          (make-string (mod n 256)      :initial-element #\+)))
-(defun store-imm-to-cdr (n)
-  (format nil ">>>[-]~A>[-]~A<<<<"
-          (make-string (truncate n 256) :initial-element #\+)
-          (make-string (mod n 256)      :initial-element #\+)))
-
-(defun move-from-to (from to)
-  (if (< to from)
-      (make-string (* 5 (- from to)) :initial-element #\<)
-      (make-string (* 5 (- to from)) :initial-element #\>)))
-
-;; sp = (car 0) ; initially = 5999 = +max-addr+ =  bfsize/5-1
-;; hp = (cdr 0) ; initially = 2
-;; ac = 1
-
-(defvar *simplify* t)
-
-(defun simplify (bf)
-  ;; delete all occurences of "><" "<>" "+-" "-+"
-  ;;(print `(simplify ,bf))
-  (if *simplify*
-      (loop
-         with changed = t
-         while changed
-         do (labels
-                ((simplify-couple (couple start)
-                   (let ((pos (search couple bf :start2 start)))
-                     (cond
-                       (pos
-                        (loop
-                           with l = (1- pos)
-                           with r = (+ pos (length couple))
-                           while (and (< start l)
-                                      (< r (length bf))
-                                      (char= (char couple 0) (char bf l))
-                                      (char= (char couple (1- (length couple)))
-                                             (char bf r)))
-                           do (setf changed t) (decf l) (incf r)
-                           finally
-                             (incf l)
-                             ;; (print `(delete ,(subseq bf l r)))
-                             ;; (print `(left ,(subseq bf start l)))
-                             (return (concatenate 'string
-                                             (subseq bf start l)
-                                             (simplify-couple couple r)))))
-                       ((zerop start)
-                        ;; (print `(result ,bf))
-                        bf)
-                       (t
-                        ;; (print `(right ,(subseq bf start)))
-                        (subseq bf start))))))
-              (setf changed nil)
-              (setf bf (simplify-couple "<>" 0))
-              (setf bf (simplify-couple "><" 0))
-              (setf bf (simplify-couple "+-" 0))
-              (setf bf (simplify-couple "-+" 0))
-              )
-         finally (return bf))
-      bf))
-
-(defmacro defbf (name args &body body)
-  "
-Defines a lisp function  that will generate brainfuck code translated
-from the body.  The body itself consists in other functions defined
-with defbf, or strings containing brainfuck instructions.
-"
-  (let ((vout (gensym)))
-    `(defun ,name ,args
-       (simplify (with-output-to-string (,vout)
-                   ,@(mapcar (lambda (item) `(princ ,item ,vout)) body))))))
-
-
-(defmacro repeat (repcnt &body body)
-  (let ((vout (gensym)))
-    `(with-output-to-string (,vout)
-       (loop :repeat ,repcnt
-             :do ,@(mapcar (lambda (item) `(princ ,item ,vout)) body)))))
-
-(defmacro while-nz (&body body)
-  (let ((vout (gensym)))
-    `(with-output-to-string (,vout)
-       (princ "[" ,vout)
-       ,@(mapcar (lambda (item) `(princ ,item ,vout)) body)
-       (princ "]" ,vout))))
-
-(defmacro progbf (&body body)
-  (let ((vout (gensym)))
-    `(with-output-to-string (,vout)
-       ,@(mapcar (lambda (item) `(princ ,item ,vout)) body))))
-
-(defmacro letbf (bindings &body body)
-  (let ((vout (gensym)))
-    `(with-output-to-string (,vout)
-       (let ,bindings
-         ,@(mapcar (lambda (item) `(princ ,item ,vout)) body)))))
-
-
-(defbf previous       ()    "<<<<<")
-(defbf next           ()    ">>>>>")
-(defbf rewind         ()    (while-nz (previous)))
-(defbf backward-0     ()    (while-nz (previous)))
-(defbf forward-0      ()    (while-nz (next)))
-(defbf backward-1     ()    "-" (while-nz "+"  (previous) "-") "+")
-(defbf forward-1      ()    "-" (while-nz "+"  (next)     "-") "+")
-(defbf forward-1-set  ()    "-" (while-nz "++" (next)     "-") "+")
-(defbf goto           (dst) (rewind) (move-from-to 0 dst))
-(defbf clear-byte     ()    (while-nz "-"))
-(defbf set-byte       ()    (while-nz "-") "+")
-(defbf clear-cons     ()
-  ">" (clear-byte) ">" (clear-byte) ">" (clear-byte) ">" (clear-byte) "<<<<")
-
-
-(defbf format-memory ()
-  (rewind) (clear-byte)
-  (repeat  +max-addr+ (next) "+")
-  (rewind) (next)
-  (store-imm-to-car 0)          (store-imm-to-car 0) (next)   ; sc
-  (store-imm-to-car +max-addr+) (store-imm-to-cdr 0) (next)   ; sp
-  (store-imm-to-car +min-addr+) (store-imm-to-cdr 0) (next)   ; hp
-  (rewind))
-
-
-(defun dump-memory (vm)
-  (loop
-     with mem = (bfvm-mem vm)
-     for addr to +max-addr+
-     do (when (zerop (mod addr 5)) (format t "~%~4,'0X: " addr))
-     (format t "~2,'0X ~2,'0X~2,'0X ~2,'0X~2,'0X  "
-             (aref mem (+ (* 5 addr) 0))
-             (aref mem (+ (* 5 addr) 1))
-             (aref mem (+ (* 5 addr) 2))
-             (aref mem (+ (* 5 addr) 3))
-             (aref mem (+ (* 5 addr) 4)))
-     finally (format t "~%")))
-
-
-(defbf move-cdr-to-car ()
-  ">>>" (while-nz "-<<+>>") ">" (while-nz "-<<+>>") "<<<<")
-
-
-(defbf copy-reg-byte (src dst)
-  (while-nz "-"
-            (move-from-to src +sc+) "+"  ; copy src to +sc+
-            (move-from-to +sc+ dst) "+"  ; copy src to dst
-            (move-from-to dst src))      ; and back to src
-  (move-from-to src +sc+)
-  (while-nz "-"
-            (move-from-to +sc+ src) "+" ; copy +sc+ to src
-            (move-from-to src +sc+))
-  (move-from-to +sc+ src))
-
-(defbf copy-reg (src dst)
-  (goto +sc+)             (clear-cons)
-  (move-from-to +sc+ dst) (clear-cons)
-  (move-from-to dst src)
-  ">" (copy-reg-byte src dst)
-  ">" (copy-reg-byte src dst)
-  ">" (copy-reg-byte src dst)
-  ">" (copy-reg-byte src dst)
-  "<<<<")                               ; back to src position
-
-
-(defbf null-car (reg)
-  (copy-reg reg +ts+)
-  (goto +ts+)
-  ">"  (while-nz "<"  (clear-byte) ">"  (clear-byte)) ; set mark if nz
-  ">"  (while-nz "<<" (clear-byte) ">>" (clear-byte)) ; set mark if nz
-  "<<" (while-nz ">>+<<-") ; move flag to lsb of car
-  "+") ; set mark
-
-
-(defbf not-null-car (reg)
-  (copy-reg reg +ts+)
-  (goto +ts+)
-  (clear-byte)
-  ">"  (while-nz "<"  (set-byte) ">"  (clear-byte)) ; set mark if nz
-  ">"  (while-nz "<<" (set-byte) ">>" (clear-byte)) ; set mark if nz
-  "<<" (while-nz ">>+<<-") ; move flag to lsb of car
-  "+") ; set mark
-
-
-
-
-(defbf increment-car (reg)
-  (goto reg)
-  ">>+"                                 ; increment lsb of car
-  (while-nz                             ; if lsb is nz
-   "<<" (clear-byte)                    ; clear mark
-   (previous) (goto 1) ">>" (clear-byte))
-  "<<"                                     ; goto mark
-  (previous)                            ; move away from cleared mark
-  (goto reg)                            ; come back
-  ;; mark = 0 <=>  lsb is nz ; mark = 1 <=> lsb is z
-  (while-nz                             ; mark = 1 ==> lsb is z
-   ">+"                                 ; increment msb of car
-   "<" (clear-byte))                    ; clear mark
-  "+")                                  ; set mark
-
-
-(defbf decrement-car (reg)
-  (goto reg)
-  ">>"                                  ; goto lsb of car
-  (while-nz                             ; if lsb is nz
-   "-"                                  ; decrement it
-   "<<" (clear-byte)                    ; clear mark
-   (previous) (goto +sc+) ">>" (clear-byte))
-  "<<"                                    ; goto mark
-  (previous)                            ; move away from cleared mark
-  (goto reg)                            ; come back
-  ;; mark = 0 <=>  lsb was nz ; mark = 1 <=> lsb is z
-  (while-nz                             ; mark = 1 ==> lsb is z
-   ">->-<<"                              ; roll over lsb; decrement msb
-   (clear-byte))                    ; clear mark
-  "+")                                  ; set mark
-
-
-#-(and)
-(defbf goto-indirect (reg)
-  ;; move to address pointed to by (car reg)
-  (copy-reg reg +cn+)
-  (repeat +min-addr+
-          (decrement-car +cn+))
-  (not-null-car +cn+) ; at +ts+
-  ">>"
-  (while-nz
-   "<<" (move-from-to +ts+ +min-addr+)
-   (forward-1)
-   "-"
-   (backward-1)
-   (decrement-car +cn+)
-   (not-null-car +cn+) ; at +ts+
-   ">>")
-  "<<" (move-from-to +ts+ +min-addr+)
-  (forward-1-set))
-
-
-(defbf goto-indirect (reg)
-  ;; move to address pointed to by (car reg)
-  (copy-reg reg +cn+)
-  (repeat +min-addr+
-          (decrement-car +cn+))
-  (goto +cn+)
-  ">>" ;; lsb of cn
-  (while-nz
-   "<<" (move-from-to +cn+ +min-addr+)
-   (forward-1)
-   "-"
-   (backward-1)
-   (goto +cn+) ">>-")
-  "<" ; msb of cn
-  (while-nz
-   "<" (move-from-to +cn+ +min-addr+)
-   (forward-1)
-   (repeat 256 "-" (next))
-   (previous) (backward-1)
-   (goto +cn+) ">-")
-  "<" (move-from-to +cn+ +min-addr+)
-  (forward-1-set) "-")
-
-
-
-(defbf copy-byte-forward (offset)
-  (repeat offset ">")
-  (while-nz
-   (repeat offset "<")
-   (next)
-   (forward-0)
-   (repeat offset ">")
-   "+"
-   (repeat offset "<")
-   (previous)
-   (backward-0)
-   (repeat offset ">")
-   "-")
-  (repeat offset "<"))
-
-
-(defbf copy-byte-backward (offset)
-  (repeat offset ">")
-  (while-nz
-   (repeat offset "<")
-   (previous)
-   (backward-0)
-   (repeat offset ">")
-   "+"
-   (repeat offset "<")
-   (next)
-   (forward-0)
-   (repeat offset ">")
-   "-")
-  (repeat offset "<"))
-
-
-(defbf store-ac (reg)
-  ;; store ac to cons at (car reg)
-  (goto-indirect reg) (clear-cons) "-" ; clear mark
-  (previous)
-  (copy-reg +ac+ +cn+)
-  (goto +cn+) "-" ; clear mark
-  (copy-byte-forward 1)
-  (copy-byte-forward 2)
-  (copy-byte-forward 3)
-  (copy-byte-forward 4)
-  "+" (forward-0) "+") ; set marks.
-
-
-(defbf load-ac (reg)
-  ;; load ac from cons at (car reg)
-  (goto-indirect reg) "-" ; clear mark
-  (previous)
-  (goto +ac+) (clear-cons) "-" ; clear mark
-  (next) (forward-0)
-  (copy-byte-backward 1)
-  (copy-byte-backward 2)
-  (copy-byte-backward 3)
-  (copy-byte-backward 4)
-  (previous)
-  (backward-0)
-  "+" ; set mark
-  (copy-reg +ac+ +cn+)
-  (goto +cn+) "-" ; clear mark
-  (copy-byte-forward 1)
-  (copy-byte-forward 2)
-  (copy-byte-forward 3)
-  (copy-byte-forward 4)
-  "+" (forward-0) "+") ; set marks.
-
-
-(defbf push-ac ()
-  (decrement-car +sp+)
-  (store-ac +sp+))
-
-(defbf pop-ac ()
-  (load-ac +sp+)
-  (increment-car +sp+))
-
-
-
-;;;---------------------------------------------------------------------
-
-(defbf test1 (n a d)
-  (format-memory)
-  (goto +ac+)
-  (store-imm-to-car a)
-  (store-imm-to-cdr d)
-  (goto +cn+)
-  (store-imm-to-car n)
-  (decrement-car +sp+)
-  (decrement-car +sp+)
-  (store-ac +sp+)
-  ;;(repeat n (push-ac))
-  )
-
-
-(defbf test2 ()
-  (format-memory)
-  (goto +ac+)
-  (store-imm-to-car #x0030)
-  (store-imm-to-cdr #xbeef)
-  (goto-indirect +ac+))
-
-
-
-;; (copy-reg +sp+ +cn+)
-;; (repeat +min-addr+
-;;         (decrement-car +cn+))
-;; (not-null-car +cn+)
-;; ">>"
-;; ;;(while-nz
-;; "<<" (move-from-to +ts+ +min-addr+)
-;; (forward-1)
-;; "-"
-;; (backward-1)
-;; (decrement-car +cn+)
-;; (not-null-car +cn+)                     ; at +ts+
-;; ">>"
-;;
-;; "<<" (move-from-to +ts+ +min-addr+)
-;; (forward-1)
-;; "-"
-;; (backward-1)
-;; (decrement-car +cn+)
-;; (not-null-car +cn+)                     ; at +ts+
-;; ">>"
-;; )
-;;
-;; "<<" (move-from-to +ts+ +min-addr+)
-;; (forward-1-set))
-;;
-;;
-;;
-;; (goto-indirect reg) (clear-cons) "-"    ; clear mark
-;; ))
-;; (previous)
-;; (copy-reg +ac+ +cn+)
-;; (goto +cn+) "-"                         ; clear mark
-;; ))
-
-
-#||
-
-(progn (bfcompile '%test1 (test1 3 #xdead #xbeef))
-       (setf vm (make-bfvm)) (%test1 vm) (dump-memory vm))
-
-(progn (bfcompile '%test1 (store-ac +sp+)
-       (setf vm (make-bfvm)) (%test1 vm) (dump-memory vm))
-
-
-||#
-
-(defvar *vm* nil)
-(defun test-lisp/bf-vm ()
-  (progn (setf *vm*  (make-bfvm :pgm (format-memory)))
-         (bfvm-run  *vm* :verbose nil)
-         (dump-memory *vm*)
-         (setf (bfvm-pc *vm*) 0
-               (bfvm-pgm *vm*) (progbf
-                                 (goto +ac+)
-                                 (store-imm-to-car #xdead)
-                                 (store-imm-to-cdr #xbeef)
-                                 (push-ac)
-                                 (goto +ac+)
-                                 (store-imm-to-car #xcafe)
-                                 (store-imm-to-cdr #xbabe)
-                                 (push-ac)))
-         (bfvm-run  *vm* :verbose nil)
-         (dump-memory *vm*)))
-
-
-;; (defun bfeval (sexp env)
-;;   (cond
-;;     ((atom sexp) sexp)
-;;     ((eq (car sexp) 'apply)
-;;      (apply (function bfapply) (mapcar (function bfeval) (cdr sexp))))
-;;     ((eq (car sexp) 'define)
-;;      (
-;; (eval '(apply (lambda ()
-;;                 (define sym definition)
-;;                 (define sym definition)
-;;                 (define sym definition)
-;;                 (sym))) ())
-;;
-;;
-;; (defmacro my-defun (name arg-list &body body)
-;;   `(progn (setf (symbol-function ',name) (lambda  ,arg-list (progn  ,@body)))
-;;           ',name))
-;;
-;;
-;; (defun my-apply (fun &rest effective-arg-list)
-;;   (let* ((lambda-exp      (function-lambda-expression fun))
-;;          (formal-arg-list (cadr lambda-exp))
-;;          (sexp            (caddr lambda-exp)))
-;;     (if (eq 'lambda (car lambda-exp))
-;;         ;; let's skip the argument binding
-;;         (my-eval sexp)
-;;         ;; a primive function
-;;         (funcall (function apply) fun effective-arg-list))));;my-apply
-;;
-;;
-;; (defun symbol-value (symbol env)
-;;   (cond ((null env) :unbound)
-;;         ((eq symbol (car (car env))) (cdr (car env)))
-;;         (t (symbol-value symbol (cdr env)))))
-;;
-;;
-;; (defun my-eval (sexp env)
-;;   (cond
-;;    ((symbolp sexp)          (symbol-value sexp env))
-;;    ((atom    sexp)          sexp)
-;;    ((eq (car sexp) 'quote)  (car (cdr sexp)))
-;;    ((eq (car sexp) 'if)     (if (my-eval (car (cdr sexp)))
-;;                                 (my-eval (car (cdr (cdr sexp))))
-;;                                 (my-eval (car (cdr (cdr (cdr sexp)))))))
-;;    ((setq)   (setf (symbol-value (cadr sexp)) (my-eval (caddr sexp))))
-;;         ((rplaca) (rplaca (my-eval (cadr sexp)) (my-eval (caddr sexp))))
-;;         ((progn)
-;;          (my-eval (cadr sexp))
-;;          (if (cddr sexp) (my-eval (cons 'progn (cddr sexp)))))
-;;         (otherwise
-;;          (my-apply (symbol-function (car sexp))
-;;                 (mapcar (function my-eval) (cdr sexp))))))));;my-eval
-;;
-;;
-;; (my-defun a-fun () (setq x '(1 2 3)) (print x) (rplaca x 0) (print x))
-
-;;  (bfcompile(bfload "99botles.bf") :name '99b)  (|99B| (make-bfvm))
-
-#||
-(test-vm)
-(test-compiler)
-(test-lisp/bf-vm)
-||#
-
-
-
-;; Local Variables:
-;; eval: (cl-indent 'defbf 2)
-;; End:
diff --git a/small-cl-pgms/brainfuck/brainfuck-test.lisp b/small-cl-pgms/brainfuck/brainfuck-test.lisp
new file mode 100644
index 0000000..13167df
--- /dev/null
+++ b/small-cl-pgms/brainfuck/brainfuck-test.lisp
@@ -0,0 +1,46 @@
+;;;; -*- mode:lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE:               bf-test.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    Test bf.lisp
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2015-02-23 <PJB> Created.
+;;;;BUGS
+;;;;LEGAL
+;;;;    AGPL3
+;;;;
+;;;;    Copyright Pascal J. Bourguignon 2015 - 2016
+;;;;
+;;;;    This program is free software: you can redistribute it and/or modify
+;;;;    it under the terms of the GNU Affero General Public License as published by
+;;;;    the Free Software Foundation, either version 3 of the License, or
+;;;;    (at your option) any later version.
+;;;;
+;;;;    This program is distributed in the hope that it will be useful,
+;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;;    GNU Affero General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU Affero General Public License
+;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
+;;;;**************************************************************************
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (setf *readtable* (copy-readtable nil)))
+(defpackage "COM.INFORMATIMAGO.SMALL-CL-PGMS.BRAINFUCK.TEST"
+  (:use "COMMON-LISP"
+        "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.SIMPLE-TEST"
+        "COM.INFORMATIMAGO.SMALL-CL-PGMS.BRAINFUCK")
+  (:export "TEST/ALL"))
+(in-package "COM.INFORMATIMAGO.SMALL-CL-PGMS.BRAINFUCK.TEST")
+
+(define-test test/all ()
+  :success)
+
+;;;; THE END ;;;;
diff --git a/small-cl-pgms/brainfuck/brainfuck.lisp b/small-cl-pgms/brainfuck/brainfuck.lisp
new file mode 100644
index 0000000..792613d
--- /dev/null
+++ b/small-cl-pgms/brainfuck/brainfuck.lisp
@@ -0,0 +1,930 @@
+;;;; -*- mode:lisp; coding:utf-8 -*-
+;;;;****************************************************************************
+;;;;FILE:               bf.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    Brainfuck emulator
+;;;;    -1- A Brainfuck Virtual Machine                 COMPLETE
+;;;;    -2- A Brainfuck to Lisp *optimizing* compiler   COMPLETE
+;;;;    -3- Implementing a lisp in Brainfuck            sketches
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2005-09-11 <PJB> Created
+;;;;BUGS
+;;;;LEGAL
+;;;;    AGPL3
+;;;;
+;;;;    Copyright Pascal J. Bourguignon 2005 - 2016
+;;;;
+;;;;    This program is free software: you can redistribute it and/or modify
+;;;;    it under the terms of the GNU Affero General Public License as published by
+;;;;    the Free Software Foundation, either version 3 of the License, or
+;;;;    (at your option) any later version.
+;;;;
+;;;;    This program is distributed in the hope that it will be useful,
+;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;;    GNU Affero General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU Affero General Public License
+;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>
+;;;;****************************************************************************
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (setf *readtable* (copy-readtable nil)))
+(defpackage "COM.INFORMATIMAGO.SMALL-CL-PGMS.BRAINFUCK"
+  (:use "COMMON-LISP")
+  #+mocl (:shadowing-import-from "COM.INFORMATIMAGO.MOCL.KLUDGES.MISSING"
+                                 "*TRACE-OUTPUT*"
+                                 "*LOAD-VERBOSE*"
+                                 "*LOAD-PRINT*"
+                                 "ARRAY-DISPLACEMENT"
+                                 "CHANGE-CLASS"
+                                 "COMPILE"
+                                 "COMPLEX"
+                                 "ENSURE-DIRECTORIES-EXIST"
+                                 "FILE-WRITE-DATE"
+                                 "INVOKE-DEBUGGER" "*DEBUGGER-HOOK*"
+                                 "LOAD"
+                                 "LOGICAL-PATHNAME-TRANSLATIONS"
+                                 "MACHINE-INSTANCE"
+                                 "MACHINE-VERSION"
+                                 "NSET-DIFFERENCE"
+                                 "RENAME-FILE"
+                                 "SUBSTITUTE-IF"
+                                 "TRANSLATE-LOGICAL-PATHNAME"
+                                 "PRINT-NOT-READABLE"
+                                 "PRINT-NOT-READABLE-OBJECT")
+  (:export "BFVM" "MAKE-BFVM" "BFVM-MEM" "BFVM-MC" "BFVM-PGM" "BFVM-PC")
+  (:export "BFLOAD" "BFVM-RUN")
+  (:export "BFCOMPILE-FILE" "BFCOMPILE" "*BFCOMPILE*")
+  (:export "BFEVAL"))
+(in-package  "COM.INFORMATIMAGO.SMALL-CL-PGMS.BRAINFUCK")
+
+;;;----------------------------------------------------------------------
+;;; -1- A Brainfuck Virtual Machine
+;;;----------------------------------------------------------------------
+
+(defconstant +bfsize+ 30000)
+
+(defstruct bfvm
+  (mem (make-array +bfsize+ :element-type '(unsigned-byte 8) :initial-element 0))
+  (mc 0)
+  (pgm "" :type string)
+  (pc 0))
+
+
+(defun find-matching-close (pgm pc inc opn cls)
+  (incf pc inc)
+  (loop
+     with level = 0
+     until (and (zerop level)
+                (or (< pc 0)
+                    (<= (length pgm) pc)
+                    (char= cls (char pgm pc))))
+     do
+       ;; (print `(level ,level pc ,pc @pc ,(char pgm pc)))
+       (cond ((char= opn (char pgm pc)) (incf level))
+             ((char= cls (char pgm pc)) (decf level)))
+       (incf pc inc)
+     finally (return pc)))
+
+
+(defun bfload (file)
+  "Return a string containing the file"
+  (with-open-file (in file)
+    (let ((pgm (make-string (file-length in))))
+      (subseq pgm 0 (read-sequence pgm in)))))
+
+
+(defun bfvm-run (vm &key verbose)
+  (let* ((mem (bfvm-mem vm))
+         (mc  (bfvm-mc  vm))
+         (pgm (bfvm-pgm vm))
+         (pc  (bfvm-pc  vm))
+         (lpgm (length pgm))
+         (lmem (length mem)))
+    (macrolet ((in-range-p (counter limit) `(< -1 ,counter ,limit)))
+      (unwind-protect
+           (loop while (and (in-range-p pc lpgm) (in-range-p mc lmem)) do
+                (when verbose
+                  (format *trace-output*
+                          "PC:~5,'0D IR:~C M[~5,'0D]:~2,'0X  ~:*~4@A  ~4@A  ~C~%"
+                          pc
+                          (if (char= (char pgm pc) #\newline)
+                              #\space
+                              (char pgm pc))
+                          mc
+                          (aref mem mc)
+                          (if (<= 128 (aref mem mc))
+                              (- (aref mem mc) 256)
+                              (aref mem mc))
+                          (if (graphic-char-p (code-char (aref mem mc)))
+                              (code-char (aref mem mc))
+                              #\space))
+                  (force-output *trace-output*))
+                (case (char pgm pc)
+                  (#\>  (incf mc)
+                        (incf pc))
+                  (#\<  (decf mc)
+                        (incf pc))
+                  (#\+  (setf (aref mem mc) (mod (1+ (aref mem mc)) 256))
+                        (incf pc))
+                  (#\-  (setf (aref mem mc) (mod (1- (aref mem mc)) 256))
+                        (incf pc))
+                  (#\.  (princ (code-char (aref mem mc)))
+                        (incf pc))
+                  (#\,  (setf (aref mem mc) (mod (char-code (read-char)) 256))
+                        (incf pc))
+                  (#\[  (if (zerop (aref mem mc))
+                            (setf pc (find-matching-close pgm pc +1 #\[ #\]))
+                            (incf pc)))
+                  (#\]  (if (zerop (aref mem mc))
+                            (incf pc)
+                            (setf pc (find-matching-close pgm pc -1 #\] #\[))))
+                  (otherwise (incf pc))))
+        (setf (bfvm-mc vm) mc
+              (bfvm-pc vm) pc))))
+  (values))
+
+
+(defun test-vm ()
+  (time (bfvm-run (make-bfvm :pgm (bfload "99botles.bf")) :verbose nil)))
+
+
+
+;;;----------------------------------------------------------------------
+;;; -2- A Brainfuck to Lisp *optimizing* compiler
+;;;----------------------------------------------------------------------
+
+
+(defun bfparse (pgm)
+  (loop
+     with result = '()
+     with stack = '()
+     for ch across pgm
+     do (case ch
+          (#\> (push '(%forward  1) result))
+          (#\< (push '(%backward 1) result))
+          (#\+ (push '(%inc 1 0) result))
+          (#\- (push '(%dec 1 0) result))
+          (#\, (push '(%readc 0) result))
+          (#\. (push '(%princ 0) result))
+          (#\[ (push result stack)
+               (setf result (list '%while-nz)))
+          (#\] (setf result (cons (nreverse result) (pop stack)))))
+     finally (progn (when stack (error "Missing closing brackets"))
+                    (return-from bfparse (nreverse result)))))
+
+
+(defmacro %forward (offset)
+  `(incf mc ,offset))
+
+(defmacro %backward (offset)
+  `(decf mc ,offset))
+
+(defmacro %inc    (value offset)
+  `(setf (aref mem (+ mc ,offset))
+         (mod (+ (aref mem (+ mc ,offset)) ,value) 256)))
+
+(defmacro %dec    (value offset)
+  `(setf (aref mem (+ mc ,offset))
+         (mod (- (aref mem (+ mc ,offset)) ,value) 256)))
+
+(defmacro %readc  (offset)
+  `(setf (aref mem (+ mc ,offset)) (mod (char-code (read-char)) 256)))
+
+(defmacro %princ  (offset)
+  `(princ (code-char (aref mem (+ mc ,offset)))))
+
+(defmacro %while-nz (&body body)
+  (let ((lbeg (gensym "LOOP"))
+        (lend (gensym "ENDL")))
+    `(tagbody (when (zerop (aref mem mc)) (go ,lend))
+        ,lbeg
+        ,@body
+        (unless (zerop (aref mem mc)) (go ,lbeg))
+        ,lend)))
+
+
+(defun bfoptimize-1 (tgm)
+  (cond
+    ((null tgm) tgm)
+    ((equalp (first tgm) '(%while-nz (%dec 1 0)))
+     (cons '(%zero 0) (bfoptimize-1 (rest tgm))))
+    ((and (consp  (first tgm))
+          (member (first (first tgm)) '(%forward %backward %inc %dec))
+          (consp  (second tgm))
+          (eq     (first (first tgm)) (first (second tgm))))
+     (loop
+        for rtgm on (rest tgm)
+        with sum = (second (first tgm))
+        while (and (consp (first rtgm))
+                   (eq (first (first tgm)) (first (first rtgm))))
+        do (incf sum (second (first rtgm)))
+        finally (return (cons (list (first (first tgm)) sum)
+                              (bfoptimize-1 rtgm)))))
+    ((and (consp (first tgm)) (eq (first (first tgm)) '%while-nz))
+     (cons (cons '%while-nz (bfoptimize-1 (rest (first tgm))))
+           (bfoptimize-1 (rest tgm))))
+    (t (cons (first tgm) (bfoptimize-1 (rest tgm))))))
+
+
+(defmacro %zero    (offset)
+  `(setf (aref mem (+ mc ,offset)) 0))
+
+
+(defun bfoptimize-2 (tgm)
+  (cond
+    ((null tgm) tgm)
+    ((equal (first tgm) '(%zero 0))
+     (cond
+       ((and (consp (second tgm))
+             (eq (first  (second tgm)) '%inc))
+        (cons (list '%set (second (second tgm)))     (bfoptimize-2 (cddr tgm))))
+       ((and (consp (second tgm))
+             (eq (first  (second tgm)) '%dec))
+        (cons (list '%set (- (second (second tgm)))) (bfoptimize-2 (cddr tgm))))
+       (t (cons '(%set 0) (bfoptimize-2 (cdr tgm))))))
+    ((and (consp (first tgm))
+          (eq (first (first tgm)) '%dec))
+     (cons (list '%inc (- (second (first tgm))))  (bfoptimize-2 (rest tgm))))
+    ((and (consp (first tgm))
+          (eq (first (first tgm)) '%backward))
+     (cons (list '%offset (- (second (first tgm))))  (bfoptimize-2 (rest tgm))))
+        ((and (consp (first tgm))
+          (eq (first (first tgm)) '%forward))
+     (cons (list '%offset (second (first tgm)))  (bfoptimize-2 (rest tgm))))
+    ((and (consp (first tgm)) (eq (first (first tgm)) '%while-nz))
+     (cons (cons '%while-nz (bfoptimize-2 (rest (first tgm))))
+           (bfoptimize-2 (rest tgm))))
+    (t (cons (first tgm) (bfoptimize-2 (rest tgm))))))
+
+
+(defmacro %set    (value offset)
+  `(setf (aref mem (+ mc ,offset)) (mod ,value 256)))
+
+
+(defmacro %offset (offset)
+  `(incf mc ,offset))
+
+
+
+(defun bfoptimize-3-offset (tgm)
+  (loop
+     with result = '()
+     with offset = 0
+     for item in tgm
+     do (case (first item)
+          ((%offset)
+           (incf offset (second item)))
+          ((%inc %set)
+           (push `(,(first item) ,(second item) ,offset) result))
+          ((%readc %princ)
+           (push `(,(first item) ,(+ (second item) offset)) result))
+          (otherwise (error "unexpected item ~A" item)))
+     finally
+       (unless (zerop offset) (push `(%offset ,offset) result))
+       (return (nreverse result))))
+
+(defun bfoptimize-3 (tgm)
+  (let ((end (position '%while-nz tgm  :key (function first))))
+    (if end
+        (nconc (bfoptimize-3-offset (subseq tgm 0 end))
+               (cons (cons '%while-nz (bfoptimize-3 (rest (elt tgm end))))
+                     (bfoptimize-3 (subseq tgm (1+ end)))))
+        (bfoptimize-3-offset tgm))))
+
+
+;;; Uncomment these macros to trace the compiled forms:
+;;
+;; (defmacro %forward (offset)
+;;   `(progn (incf mc ,offset)
+;;           (print `(forward ,,offset --> mc = ,mc))))
+;;
+;; (defmacro %backward (offset)
+;;   `(progn (decf mc ,offset)
+;;           (print `(backward ,,offset --> mc = ,mc))))
+;;
+;; (defmacro %inc    (value offset)
+;;   `(progn (setf (aref mem (+ mc ,offset))
+;;                 (mod (+ (aref mem (+ mc ,offset)) ,value) 256))
+;;           (print `(inc ,,value ,,offset --> (aref mem ,(+ mc ,offset)) = ,(aref mem (+ mc ,offset))))))
+;;
+;; (defmacro %dec    (value offset)
+;;   `(progn (setf (aref mem (+ mc ,offset))
+;;                 (mod (- (aref mem (+ mc ,offset)) ,value) 256))
+;;           (print `(dec ,,value ,,offset --> (aref mem ,(+ mc ,offset)) = ,(aref mem (+ mc ,offset))))))
+;;
+;; (defmacro %readc  (offset)
+;;   `(progn (setf (aref mem (+ mc ,offset)) (mod (char-code (read-char)) 256))
+;;           (print `(readc ,,offset --> (aref mem ,(+ mc ,offset)) = ,(aref mem (+ mc ,offset))))))
+;;
+;; (defmacro %princ  (offset)
+;;   `(progn (princ (code-char (aref mem (+ mc ,offset))))
+;;           (print `(princ ,,offset --> (aref mem ,(+ mc ,offset)) = ,(aref mem (+ mc ,offset))))))
+;;
+;; (defmacro %while-nz (&body body)
+;;   (let ((lbeg (gensym "LOOP"))
+;;         (lend (gensym "ENDL")))
+;;     `(tagbody
+;;         (print `(while-nz ,',lbeg begin  (aref mem ,mc) = ,(aref mem mc)))
+;;         (when (zerop (aref mem mc)) (go ,lend))
+;;         ,lbeg
+;;         ,@body
+;;         (print `(while-nz ,',lbeg loop  (aref mem ,mc) = ,(aref mem mc)))
+;;         (unless (zerop (aref mem mc)) (go ,lbeg))
+;;         ,lend)))
+;;
+;; (defmacro %zero    (offset)
+;;   `(progn (setf (aref mem (+ mc ,offset)) 0)
+;;           (print `(zero ,offset --> (aref mem ,(+ mc offset)) = ,(aref mem (+ mc offset))))))
+;;
+;; (defmacro %set    (value offset)
+;;   `(progn (setf (aref mem (+ mc ,offset)) (mod ,value 256))
+;;           (print `(set ,,value ,,offset -->  (aref mem ,(+ mc ,offset)) = ,(aref mem (+ mc ,offset))))))
+;;
+;; (defmacro %offset (offset)
+;;   `(progn (incf mc ,offset)
+;;           (print `(offset ,,offset --> mc = ,mc))))
+
+
+
+(defvar *bfcompile* nil
+  "When true, bfcompile compiles also the generated Lisp code.")
+
+
+(defun bfcompile (pgm &key name ((:compile *bfcompile*) *bfcompile*))
+  "
+PGM:    a string containing the source of a Brainfuck program.
+RETURN: a lisp function taking a virtual machine
+        (only the memory and MC register are used),
+        and realizing the same program.
+"
+  (flet ((do-compile (lambda-form) (compile name lambda-form))
+         (do-eval    (lambda-form) (eval (if name
+                                        `(defun ,name (vm) (,lambda-form vm))
+                                        lambda-form))))
+    (funcall (if *bfcompile*
+                 (function do-compile)
+                 (function do-eval))
+             `(lambda (vm)
+                (let ((mem (bfvm-mem vm))
+                      (mc  (bfvm-mc  vm)))
+                  (unwind-protect
+                       (progn
+                         ,@(bfoptimize-3
+                            (bfoptimize-2
+                             (bfoptimize-1
+                              (bfparse pgm)))))
+                    (setf (bfvm-mc vm) mc)))))))
+
+
+(defun bfcompile-file (file &key ((:compile *bfcompile*) *bfcompile*))
+  "Combines bfcompile and bfload."
+  (bfcompile (bfload file) :compile *bfcompile*))
+
+
+(defun test-compiler ()
+  (time (funcall (bfcompile-file "99botles.bf")
+                 (make-bfvm)))
+  (time (funcall (bfcompile-file "99botles.bf" :compile t)
+                 (make-bfvm))))
+
+
+
+
+;;;----------------------------------------------------------------------
+;;; -3- Implementing a lisp in Brainfuck
+;;;----------------------------------------------------------------------
+
+
+;; lisp primitives:
+;;     () eq cons car cdr atom quote cond  lambda
+;;
+;; lisp registers stored in brainfuck memory:
+;;     | 0 , sph , spl , sph , spl | 1 , hph , hpl , hph , hpl |
+;;     | 2 , ach , acl , ach , acl |
+
+
+(defconstant +max-addr+ (1- (truncate +bfsize+ 5)))
+(defconstant +sc+ 1)
+(defconstant +sp+ 2 "stack pointer")
+(defconstant +hp+ 3 "heap  pointer")
+(defconstant +ix+ 4 "")
+(defconstant +ac+ 5 "accumulator a")
+(defconstant +bc+ 6 "accumulator b")
+(defconstant +ts+ 7)
+(defconstant +cn+ 8)
+(defconstant +min-addr+ 9)
+
+
+(defun store-imm-to-car (n)
+  (format nil ">[-]~A>[-]~A<<"
+          (make-string (truncate n 256) :initial-element #\+)
+          (make-string (mod n 256)      :initial-element #\+)))
+(defun store-imm-to-cdr (n)
+  (format nil ">>>[-]~A>[-]~A<<<<"
+          (make-string (truncate n 256) :initial-element #\+)
+          (make-string (mod n 256)      :initial-element #\+)))
+
+(defun move-from-to (from to)
+  (if (< to from)
+      (make-string (* 5 (- from to)) :initial-element #\<)
+      (make-string (* 5 (- to from)) :initial-element #\>)))
+
+;; sp = (car 0) ; initially = 5999 = +max-addr+ =  bfsize/5-1
+;; hp = (cdr 0) ; initially = 2
+;; ac = 1
+
+(defvar *simplify* t)
+
+(defun simplify (bf)
+  ;; delete all occurences of "><" "<>" "+-" "-+"
+  ;;(print `(simplify ,bf))
+  (if *simplify*
+      (loop
+         with changed = t
+         while changed
+         do (labels
+                ((simplify-couple (couple start)
+                   (let ((pos (search couple bf :start2 start)))
+                     (cond
+                       (pos
+                        (loop
+                           with l = (1- pos)
+                           with r = (+ pos (length couple))
+                           while (and (< start l)
+                                      (< r (length bf))
+                                      (char= (char couple 0) (char bf l))
+                                      (char= (char couple (1- (length couple)))
+                                             (char bf r)))
+                           do (setf changed t) (decf l) (incf r)
+                           finally
+                             (incf l)
+                             ;; (print `(delete ,(subseq bf l r)))
+                             ;; (print `(left ,(subseq bf start l)))
+                             (return (concatenate 'string
+                                             (subseq bf start l)
+                                             (simplify-couple couple r)))))
+                       ((zerop start)
+                        ;; (print `(result ,bf))
+                        bf)
+                       (t
+                        ;; (print `(right ,(subseq bf start)))
+                        (subseq bf start))))))
+              (setf changed nil)
+              (setf bf (simplify-couple "<>" 0))
+              (setf bf (simplify-couple "><" 0))
+              (setf bf (simplify-couple "+-" 0))
+              (setf bf (simplify-couple "-+" 0))
+              )
+         finally (return bf))
+      bf))
+
+(defmacro defbf (name args &body body)
+  "
+Defines a lisp function  that will generate brainfuck code translated
+from the body.  The body itself consists in other functions defined
+with defbf, or strings containing brainfuck instructions.
+"
+  (let ((vout (gensym)))
+    `(defun ,name ,args
+       (simplify (with-output-to-string (,vout)
+                   ,@(mapcar (lambda (item) `(princ ,item ,vout)) body))))))
+
+
+(defmacro repeat (repcnt &body body)
+  (let ((vout (gensym)))
+    `(with-output-to-string (,vout)
+       (loop :repeat ,repcnt
+             :do ,@(mapcar (lambda (item) `(princ ,item ,vout)) body)))))
+
+(defmacro while-nz (&body body)
+  (let ((vout (gensym)))
+    `(with-output-to-string (,vout)
+       (princ "[" ,vout)
+       ,@(mapcar (lambda (item) `(princ ,item ,vout)) body)
+       (princ "]" ,vout))))
+
+(defmacro progbf (&body body)
+  (let ((vout (gensym)))
+    `(with-output-to-string (,vout)
+       ,@(mapcar (lambda (item) `(princ ,item ,vout)) body))))
+
+(defmacro letbf (bindings &body body)
+  (let ((vout (gensym)))
+    `(with-output-to-string (,vout)
+       (let ,bindings
+         ,@(mapcar (lambda (item) `(princ ,item ,vout)) body)))))
+
+
+(defbf previous       ()    "<<<<<")
+(defbf next           ()    ">>>>>")
+(defbf rewind         ()    (while-nz (previous)))
+(defbf backward-0     ()    (while-nz (previous)))
+(defbf forward-0      ()    (while-nz (next)))
+(defbf backward-1     ()    "-" (while-nz "+"  (previous) "-") "+")
+(defbf forward-1      ()    "-" (while-nz "+"  (next)     "-") "+")
+(defbf forward-1-set  ()    "-" (while-nz "++" (next)     "-") "+")
+(defbf goto           (dst) (rewind) (move-from-to 0 dst))
+(defbf clear-byte     ()    (while-nz "-"))
+(defbf set-byte       ()    (while-nz "-") "+")
+(defbf clear-cons     ()
+  ">" (clear-byte) ">" (clear-byte) ">" (clear-byte) ">" (clear-byte) "<<<<")
+
+
+(defbf format-memory ()
+  (rewind) (clear-byte)
+  (repeat  +max-addr+ (next) "+")
+  (rewind) (next)
+  (store-imm-to-car 0)          (store-imm-to-car 0) (next)   ; sc
+  (store-imm-to-car +max-addr+) (store-imm-to-cdr 0) (next)   ; sp
+  (store-imm-to-car +min-addr+) (store-imm-to-cdr 0) (next)   ; hp
+  (rewind))
+
+
+(defun dump-memory (vm)
+  (loop
+     with mem = (bfvm-mem vm)
+     for addr to +max-addr+
+     do (when (zerop (mod addr 5)) (format t "~%~4,'0X: " addr))
+     (format t "~2,'0X ~2,'0X~2,'0X ~2,'0X~2,'0X  "
+             (aref mem (+ (* 5 addr) 0))
+             (aref mem (+ (* 5 addr) 1))
+             (aref mem (+ (* 5 addr) 2))
+             (aref mem (+ (* 5 addr) 3))
+             (aref mem (+ (* 5 addr) 4)))
+     finally (format t "~%")))
+
+
+(defbf move-cdr-to-car ()
+  ">>>" (while-nz "-<<+>>") ">" (while-nz "-<<+>>") "<<<<")
+
+
+(defbf copy-reg-byte (src dst)
+  (while-nz "-"
+            (move-from-to src +sc+) "+"  ; copy src to +sc+
+            (move-from-to +sc+ dst) "+"  ; copy src to dst
+            (move-from-to dst src))      ; and back to src
+  (move-from-to src +sc+)
+  (while-nz "-"
+            (move-from-to +sc+ src) "+" ; copy +sc+ to src
+            (move-from-to src +sc+))
+  (move-from-to +sc+ src))
+
+(defbf copy-reg (src dst)
+  (goto +sc+)             (clear-cons)
+  (move-from-to +sc+ dst) (clear-cons)
+  (move-from-to dst src)
+  ">" (copy-reg-byte src dst)
+  ">" (copy-reg-byte src dst)
+  ">" (copy-reg-byte src dst)
+  ">" (copy-reg-byte src dst)
+  "<<<<")                               ; back to src position
+
+
+(defbf null-car (reg)
+  (copy-reg reg +ts+)
+  (goto +ts+)
+  ">"  (while-nz "<"  (clear-byte) ">"  (clear-byte)) ; set mark if nz
+  ">"  (while-nz "<<" (clear-byte) ">>" (clear-byte)) ; set mark if nz
+  "<<" (while-nz ">>+<<-") ; move flag to lsb of car
+  "+") ; set mark
+
+
+(defbf not-null-car (reg)
+  (copy-reg reg +ts+)
+  (goto +ts+)
+  (clear-byte)
+  ">"  (while-nz "<"  (set-byte) ">"  (clear-byte)) ; set mark if nz
+  ">"  (while-nz "<<" (set-byte) ">>" (clear-byte)) ; set mark if nz
+  "<<" (while-nz ">>+<<-") ; move flag to lsb of car
+  "+") ; set mark
+
+
+
+
+(defbf increment-car (reg)
+  (goto reg)
+  ">>+"                                 ; increment lsb of car
+  (while-nz                             ; if lsb is nz
+   "<<" (clear-byte)                    ; clear mark
+   (previous) (goto 1) ">>" (clear-byte))
+  "<<"                                     ; goto mark
+  (previous)                            ; move away from cleared mark
+  (goto reg)                            ; come back
+  ;; mark = 0 <=>  lsb is nz ; mark = 1 <=> lsb is z
+  (while-nz                             ; mark = 1 ==> lsb is z
+   ">+"                                 ; increment msb of car
+   "<" (clear-byte))                    ; clear mark
+  "+")                                  ; set mark
+
+
+(defbf decrement-car (reg)
+  (goto reg)
+  ">>"                                  ; goto lsb of car
+  (while-nz                             ; if lsb is nz
+   "-"                                  ; decrement it
+   "<<" (clear-byte)                    ; clear mark
+   (previous) (goto +sc+) ">>" (clear-byte))
+  "<<"                                    ; goto mark
+  (previous)                            ; move away from cleared mark
+  (goto reg)                            ; come back
+  ;; mark = 0 <=>  lsb was nz ; mark = 1 <=> lsb is z
+  (while-nz                             ; mark = 1 ==> lsb is z
+   ">->-<<"                              ; roll over lsb; decrement msb
+   (clear-byte))                    ; clear mark
+  "+")                                  ; set mark
+
+
+#-(and)
+(defbf goto-indirect (reg)
+  ;; move to address pointed to by (car reg)
+  (copy-reg reg +cn+)
+  (repeat +min-addr+
+          (decrement-car +cn+))
+  (not-null-car +cn+) ; at +ts+
+  ">>"
+  (while-nz
+   "<<" (move-from-to +ts+ +min-addr+)
+   (forward-1)
+   "-"
+   (backward-1)
+   (decrement-car +cn+)
+   (not-null-car +cn+) ; at +ts+
+   ">>")
+  "<<" (move-from-to +ts+ +min-addr+)
+  (forward-1-set))
+
+
+(defbf goto-indirect (reg)
+  ;; move to address pointed to by (car reg)
+  (copy-reg reg +cn+)
+  (repeat +min-addr+
+          (decrement-car +cn+))
+  (goto +cn+)
+  ">>" ;; lsb of cn
+  (while-nz
+   "<<" (move-from-to +cn+ +min-addr+)
+   (forward-1)
+   "-"
+   (backward-1)
+   (goto +cn+) ">>-")
+  "<" ; msb of cn
+  (while-nz
+   "<" (move-from-to +cn+ +min-addr+)
+   (forward-1)
+   (repeat 256 "-" (next))
+   (previous) (backward-1)
+   (goto +cn+) ">-")
+  "<" (move-from-to +cn+ +min-addr+)
+  (forward-1-set) "-")
+
+
+
+(defbf copy-byte-forward (offset)
+  (repeat offset ">")
+  (while-nz
+   (repeat offset "<")
+   (next)
+   (forward-0)
+   (repeat offset ">")
+   "+"
+   (repeat offset "<")
+   (previous)
+   (backward-0)
+   (repeat offset ">")
+   "-")
+  (repeat offset "<"))
+
+
+(defbf copy-byte-backward (offset)
+  (repeat offset ">")
+  (while-nz
+   (repeat offset "<")
+   (previous)
+   (backward-0)
+   (repeat offset ">")
+   "+"
+   (repeat offset "<")
+   (next)
+   (forward-0)
+   (repeat offset ">")
+   "-")
+  (repeat offset "<"))
+
+
+(defbf store-ac (reg)
+  ;; store ac to cons at (car reg)
+  (goto-indirect reg) (clear-cons) "-" ; clear mark
+  (previous)
+  (copy-reg +ac+ +cn+)
+  (goto +cn+) "-" ; clear mark
+  (copy-byte-forward 1)
+  (copy-byte-forward 2)
+  (copy-byte-forward 3)
+  (copy-byte-forward 4)
+  "+" (forward-0) "+") ; set marks.
+
+
+(defbf load-ac (reg)
+  ;; load ac from cons at (car reg)
+  (goto-indirect reg) "-" ; clear mark
+  (previous)
+  (goto +ac+) (clear-cons) "-" ; clear mark
+  (next) (forward-0)
+  (copy-byte-backward 1)
+  (copy-byte-backward 2)
+  (copy-byte-backward 3)
+  (copy-byte-backward 4)
+  (previous)
+  (backward-0)
+  "+" ; set mark
+  (copy-reg +ac+ +cn+)
+  (goto +cn+) "-" ; clear mark
+  (copy-byte-forward 1)
+  (copy-byte-forward 2)
+  (copy-byte-forward 3)
+  (copy-byte-forward 4)
+  "+" (forward-0) "+") ; set marks.
+
+
+(defbf push-ac ()
+  (decrement-car +sp+)
+  (store-ac +sp+))
+
+(defbf pop-ac ()
+  (load-ac +sp+)
+  (increment-car +sp+))
+
+
+
+;;;---------------------------------------------------------------------
+
+(defbf test1 (n a d)
+  (format-memory)
+  (goto +ac+)
+  (store-imm-to-car a)
+  (store-imm-to-cdr d)
+  (goto +cn+)
+  (store-imm-to-car n)
+  (decrement-car +sp+)
+  (decrement-car +sp+)
+  (store-ac +sp+)
+  ;;(repeat n (push-ac))
+  )
+
+
+(defbf test2 ()
+  (format-memory)
+  (goto +ac+)
+  (store-imm-to-car #x0030)
+  (store-imm-to-cdr #xbeef)
+  (goto-indirect +ac+))
+
+
+
+;; (copy-reg +sp+ +cn+)
+;; (repeat +min-addr+
+;;         (decrement-car +cn+))
+;; (not-null-car +cn+)
+;; ">>"
+;; ;;(while-nz
+;; "<<" (move-from-to +ts+ +min-addr+)
+;; (forward-1)
+;; "-"
+;; (backward-1)
+;; (decrement-car +cn+)
+;; (not-null-car +cn+)                     ; at +ts+
+;; ">>"
+;;
+;; "<<" (move-from-to +ts+ +min-addr+)
+;; (forward-1)
+;; "-"
+;; (backward-1)
+;; (decrement-car +cn+)
+;; (not-null-car +cn+)                     ; at +ts+
+;; ">>"
+;; )
+;;
+;; "<<" (move-from-to +ts+ +min-addr+)
+;; (forward-1-set))
+;;
+;;
+;;
+;; (goto-indirect reg) (clear-cons) "-"    ; clear mark
+;; ))
+;; (previous)
+;; (copy-reg +ac+ +cn+)
+;; (goto +cn+) "-"                         ; clear mark
+;; ))
+
+
+#||
+
+(progn (bfcompile '%test1 (test1 3 #xdead #xbeef))
+       (setf vm (make-bfvm)) (%test1 vm) (dump-memory vm))
+
+(progn (bfcompile '%test1 (store-ac +sp+)
+       (setf vm (make-bfvm)) (%test1 vm) (dump-memory vm))
+
+
+||#
+
+(defvar *vm* nil)
+(defun test-lisp/bf-vm ()
+  (progn (setf *vm*  (make-bfvm :pgm (format-memory)))
+         (bfvm-run  *vm* :verbose nil)
+         (dump-memory *vm*)
+         (setf (bfvm-pc *vm*) 0
+               (bfvm-pgm *vm*) (progbf
+                                 (goto +ac+)
+                                 (store-imm-to-car #xdead)
+                                 (store-imm-to-cdr #xbeef)
+                                 (push-ac)
+                                 (goto +ac+)
+                                 (store-imm-to-car #xcafe)
+                                 (store-imm-to-cdr #xbabe)
+                                 (push-ac)))
+         (bfvm-run  *vm* :verbose nil)
+         (dump-memory *vm*)))
+
+
+;; (defun bfeval (sexp env)
+;;   (cond
+;;     ((atom sexp) sexp)
+;;     ((eq (car sexp) 'apply)
+;;      (apply (function bfapply) (mapcar (function bfeval) (cdr sexp))))
+;;     ((eq (car sexp) 'define)
+;;      (
+;; (eval '(apply (lambda ()
+;;                 (define sym definition)
+;;                 (define sym definition)
+;;                 (define sym definition)
+;;                 (sym))) ())
+;;
+;;
+;; (defmacro my-defun (name arg-list &body body)
+;;   `(progn (setf (symbol-function ',name) (lambda  ,arg-list (progn  ,@body)))
+;;           ',name))
+;;
+;;
+;; (defun my-apply (fun &rest effective-arg-list)
+;;   (let* ((lambda-exp      (function-lambda-expression fun))
+;;          (formal-arg-list (cadr lambda-exp))
+;;          (sexp            (caddr lambda-exp)))
+;;     (if (eq 'lambda (car lambda-exp))
+;;         ;; let's skip the argument binding
+;;         (my-eval sexp)
+;;         ;; a primive function
+;;         (funcall (function apply) fun effective-arg-list))));;my-apply
+;;
+;;
+;; (defun symbol-value (symbol env)
+;;   (cond ((null env) :unbound)
+;;         ((eq symbol (car (car env))) (cdr (car env)))
+;;         (t (symbol-value symbol (cdr env)))))
+;;
+;;
+;; (defun my-eval (sexp env)
+;;   (cond
+;;    ((symbolp sexp)          (symbol-value sexp env))
+;;    ((atom    sexp)          sexp)
+;;    ((eq (car sexp) 'quote)  (car (cdr sexp)))
+;;    ((eq (car sexp) 'if)     (if (my-eval (car (cdr sexp)))
+;;                                 (my-eval (car (cdr (cdr sexp))))
+;;                                 (my-eval (car (cdr (cdr (cdr sexp)))))))
+;;    ((setq)   (setf (symbol-value (cadr sexp)) (my-eval (caddr sexp))))
+;;         ((rplaca) (rplaca (my-eval (cadr sexp)) (my-eval (caddr sexp))))
+;;         ((progn)
+;;          (my-eval (cadr sexp))
+;;          (if (cddr sexp) (my-eval (cons 'progn (cddr sexp)))))
+;;         (otherwise
+;;          (my-apply (symbol-function (car sexp))
+;;                 (mapcar (function my-eval) (cdr sexp))))))));;my-eval
+;;
+;;
+;; (my-defun a-fun () (setq x '(1 2 3)) (print x) (rplaca x 0) (print x))
+
+;;  (bfcompile(bfload "99botles.bf") :name '99b)  (|99B| (make-bfvm))
+
+#||
+(test-vm)
+(test-compiler)
+(test-lisp/bf-vm)
+||#
+
+(defun bfeval (bfcode)
+  (check-type bfcode string)
+  (funcall (com.informatimago.small-cl-pgms.brainfuck:bfcompile bfcode)
+           (com.informatimago.small-cl-pgms.brainfuck:make-bfvm)))
+
+
+;; Local Variables:
+;; eval: (cl-indent 'defbf 2)
+;; End:
diff --git a/small-cl-pgms/brainfuck/com.informatimago.small-cl-pgms.brainfuck.asd b/small-cl-pgms/brainfuck/com.informatimago.small-cl-pgms.brainfuck.asd
index 9e8b995..33479b2 100644
--- a/small-cl-pgms/brainfuck/com.informatimago.small-cl-pgms.brainfuck.asd
+++ b/small-cl-pgms/brainfuck/com.informatimago.small-cl-pgms.brainfuck.asd
@@ -38,7 +38,7 @@
   :version "1.2.0"
   :license "GPL3"
   :depends-on ()
-  :components ((:file "bf"))
+  :components ((:file "brainfuck"))
   #+adsf3 :in-order-to #+adsf3 ((asdf:test-op (asdf:test-op "com.informatimago.small-cl-pgms.bf.test"))))

 ;;;; THE END ;;;;
diff --git a/small-cl-pgms/brainfuck/com.informatimago.small-cl-pgms.brainfuck.test.asd b/small-cl-pgms/brainfuck/com.informatimago.small-cl-pgms.brainfuck.test.asd
index bc1bf27..d9567b8 100644
--- a/small-cl-pgms/brainfuck/com.informatimago.small-cl-pgms.brainfuck.test.asd
+++ b/small-cl-pgms/brainfuck/com.informatimago.small-cl-pgms.brainfuck.test.asd
@@ -57,7 +57,7 @@
   #+asdf-unicode :encoding #+asdf-unicode :utf-8
   :depends-on     ("com.informatimago.common-lisp.cesarum"
                    "com.informatimago.small-cl-pgms.brainfuck")
-  :components     ((:file "bf-test" :depends-on ()))
+  :components     ((:file "brainfuck-test" :depends-on ()))
   #+asdf3 :perform #+asdf3 (asdf:test-op
                             (operation system)
                             (declare (ignore operation system))
ViewGit