Merged small-cl-pgms in here.

Pascal J. Bourguignon [2012-04-14 23:28]
Merged small-cl-pgms in here.
Filename
small-cl-pgms/Makefile
small-cl-pgms/aim-8/aim-8.aim-8
small-cl-pgms/aim-8/aim-8.html
small-cl-pgms/aim-8/aim-8.lisp
small-cl-pgms/aim-8/aim-8.txt
small-cl-pgms/aim-8/aim-8.txt.gz
small-cl-pgms/aim-8/diff.m
small-cl-pgms/aim-8/examples.aim-8
small-cl-pgms/aim-8/index.html
small-cl-pgms/author-signature.lisp
small-cl-pgms/basic/basic.lisp
small-cl-pgms/basic/index.html
small-cl-pgms/basic/test-gosub-read.basic
small-cl-pgms/basic/test1.basic
small-cl-pgms/basic/test2.basic
small-cl-pgms/brainfuck/99botles.bf
small-cl-pgms/brainfuck/bf.lisp
small-cl-pgms/brainfuck/index.html
small-cl-pgms/brainfuck/simple-cl.lisp
small-cl-pgms/brainfuck/simple-symbol.lisp
small-cl-pgms/clisp-fork/count-fork.c
small-cl-pgms/clisp-fork/count-fork.lisp
small-cl-pgms/cube.lisp
small-cl-pgms/douze.lisp
small-cl-pgms/example-soft-opcodes.lisp
small-cl-pgms/geek-day/Makefile
small-cl-pgms/geek-day/README
small-cl-pgms/geek-day/geek-day.gif
small-cl-pgms/geek-day/geek-day.lisp
small-cl-pgms/ibcl/ibcl-bootstrap.lisp
small-cl-pgms/ibcl/ibcl.lisp
small-cl-pgms/ibcl/index.html
small-cl-pgms/index.html
small-cl-pgms/index.lisp
small-cl-pgms/init.lisp
small-cl-pgms/life.lisp
small-cl-pgms/m-expression/index.html
small-cl-pgms/m-expression/m-expression.lisp
small-cl-pgms/miscellaneous/clisp-server.lisp
small-cl-pgms/playtomo-stonedge/index.html
small-cl-pgms/playtomo-stonedge/playtomo-stonedge.lisp
small-cl-pgms/puzzle.lisp
small-cl-pgms/quine.lisp
small-cl-pgms/rdp/com.informatimago.rdp.asd
small-cl-pgms/rdp/com.informatimago.rdp.basic.asd
small-cl-pgms/rdp/com.informatimago.rdp.basic.example.asd
small-cl-pgms/rdp/com.informatimago.rdp.example.asd
small-cl-pgms/rdp/example-basic-dribble.txt
small-cl-pgms/rdp/example-basic.lisp
small-cl-pgms/rdp/example-lisp-dribble.txt
small-cl-pgms/rdp/example-lisp.lisp
small-cl-pgms/rdp/index.html
small-cl-pgms/rdp/movie-shell.lisp
small-cl-pgms/rdp/rdp-basic-gen.lisp
small-cl-pgms/rdp/rdp.lisp
small-cl-pgms/rdp/scratch.lisp
small-cl-pgms/rpsls/index.html
small-cl-pgms/rpsls/rpcls.txt
small-cl-pgms/rpsls/rpsls-25.jpg
small-cl-pgms/rpsls/rpsls.lisp
small-cl-pgms/sedit/index.html
small-cl-pgms/sedit/sedit.lisp
small-cl-pgms/solitaire.lisp
small-cl-pgms/wang.html
diff --git a/small-cl-pgms/Makefile b/small-cl-pgms/Makefile
new file mode 100644
index 0000000..376159b
--- /dev/null
+++ b/small-cl-pgms/Makefile
@@ -0,0 +1,17 @@
+all:generate
+
+generate:index.html access-rights clean
+
+index.html:init.lisp index.lisp Makefile
+	clisp -norc -q -ansi  -E iso-8859-1  -x '(prog1 (values) (setf *load-verbose* nil) (load "init.lisp") (load "index.lisp"))'|tr -d '\015'|sed -e 's/^;.*//' -e '/^NIL$$/d' > index.html
+
+access-rights:
+	publish .
+
+clean:
+	-rm -rf  *~
+cleanall:clean
+	-rm -rf index.html
+
+#(with-open-file (*STANDARD-OUTPUT* "index.html" :direction :output :if-exists :supersede :if-does-not-exist :create)
+#### Makefile                         --                     --          ####
diff --git a/small-cl-pgms/aim-8/aim-8.aim-8 b/small-cl-pgms/aim-8/aim-8.aim-8
new file mode 100644
index 0000000..2cb2302
--- /dev/null
+++ b/small-cl-pgms/aim-8/aim-8.aim-8
@@ -0,0 +1,175 @@
+;;;; -*- mode: Lisp -*-
+;;;;****************************************************************************
+;;;;FILE:               aim-8.aim-8
+;;;;LANGUAGE:           AIM-8 LISP
+;;;;SYSTEM:             AIM-8 LISP
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    Implements the LISP described in AIM-8 in AIM-8 LISP
+;;;;    Usage: At the AIM-8> prompt:
+;;;;      (LOAD (QUOTE "aim-8.aim-8"))
+;;;;      (REPL)
+;;;;    The AIM-8 evaluation algorithm is pure substitution, no binding!
+;;;;    Therefore (read) is called every time it's _used_:
+;;;;    you need to enter the same sexp several times to get it processed!
+;;;;
+;;;;      (EVAL (QUOTE (FF1 (QUOTE ((())()()((A)B C)))))
+;;;;            (QUOTE ((FF1 LAMBDA (X) (COND ((OR (NULL X) (ATOM X)) X)
+;;;;                                 (T (COND ((FF1 (FIRST X)) (FF1 (FIRST X)))
+;;;;                                          (T (FF1 (REST X)))))))))
+;;;;   Note: Since this implements an substitution interpreter on an interpreter
+;;;;   on a lisp system, it usually quite slow to compute the result of non
+;;;;   trivial functions.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2004-10-24 <PJB> Created;
+;;;;BUGS
+;;;;LEGAL
+;;;;    GPL
+;;;;
+;;;;    Copyright Pascal Bourguignon 2004 - 2004
+;;;;
+;;;;    This program is free software; you can redistribute it and/or
+;;;;    modify it under the terms of the GNU General Public License
+;;;;    as published by the Free Software Foundation; either version
+;;;;    2 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 General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU General Public
+;;;;    License along with this program; if not, write to the Free
+;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;;    Boston, MA 02111-1307 USA
+;;;;****************************************************************************
+
+;; NOTE: These functions are defined in the AIM-8/Common-Lisp environment
+;;       and don't appear in the AIM-8/AIM-8 environment.
+;;       With (repl), you start with an empty environment...
+
+
+(DEFINE NIL ())
+(DEFINE F   ())
+(DEFINE T   T)
+(DEFINE AND     (LAMBDA (A B) (COND (A (COND (B T) (T NIL))) (T NIL))))
+(DEFINE OR      (LAMBDA (A B) (COND (A T) (B T) (T NIL))))
+(DEFINE NOT     (LAMBDA (A)   (COND (A NIL) (T T))))
+
+(DEFINE MAPLIST
+        (LAMBDA (X F)
+          (COND ((NULL X) NIL)
+                (T (COMBINE (F X) (MAPLIST (REST X) F))))))
+
+(DEFINE SUBST
+        (LAMBDA (X Y A)
+          (COND ((NULL A) NIL)
+                ((ATOM A) (COND ((EQ Y A) X) (T A)))
+                (T (COMBINE (SUBST X Y (FIRST A))
+                            (SUBST X Y (REST A)))))))
+
+(DEFINE SUBSQ
+        (LAMBDA (X Y Z)
+          (COND ((NULL Z) NIL)
+                ((ATOM Z) (COND ((EQ Y Z) X)  (T Z)))
+                ((EQ (FIRST Z) (QUOTE QUOTE)) Z)
+                (T (COMBINE (SUBSQ X Y (FIRST Z)) (SUBSQ X Y (REST Z)))))))
+
+
+(DEFINE EVCON
+        (LAMBDA (C ENV)
+          (COND ((EVAL (FIRST (FIRST C)) ENV)
+                 (EVAL (FIRST (REST (FIRST C))) ENV))
+                (T (EVCON (REST C) ENV)))))
+
+
+(DEFINE EVLAM
+        (LAMBDA  (VARS EXP ARGS ENV)
+          (COND ((NULL VARS) (EVAL EXP ENV))
+                (T (EVLAM (REST VARS) (SUBSQ (FIRST ARGS) (FIRST VARS) EXP)
+                          (REST ARGS) ENV)))))
+
+
+(DEFINE APPLY (LAMBDA (F ARGS ENV) (EVAL (COMBINE F ARGS) ENV)))
+
+
+(DEFINE ASSOC
+        (LAMBDA (ITEM LIST)
+          (COND ((NULL LIST) LIST)
+                ((EQ ITEM (first (first LIST))) (first LIST))
+                (T (ASSOC ITEM (rest LIST))))))
+
+
+(DEFINE APPEND
+        (LAMBDA (L1 L2)
+          (COND ((NULL L2) L1)
+                ((NULL L1) L2)
+                (T (COMBINE (FIRST L1) (APPEND (REST L1) L2))))))
+
+(DEFINE LIST1 (LAMBDA (ON)       (COMBINE ON NIL)))
+(DEFINE LIST2 (LAMBDA (ON TW)    (COMBINE ON (COMBINE TW NIL))))
+(DEFINE LIST3 (LAMBDA (ON TW TH) (COMBINE ON (COMBINE TW (COMBINE TH NIL)))))
+
+(DEFINE GET (LAMBDA (NAME ENV) (rest (ASSOC NAME ENV))))
+(DEFINE SET (LAMBDA (NAME VALUE ENV) (COMBINE (COMBINE NAME VALUE) ENV)))
+(DEFINE BOUNDP (LAMBDA (NAME ENV) (ASSOC NAME ENV)))
+
+(DEFINE ERROR  (LAMBDA (MESSAGE VALUES) (COMBINE (QUOTE :ERROR)
+                                            (APPEND MESSAGE VALUES))))
+
+
+(DEFINE
+ EVAL
+ (LAMBDA (E ENV)
+   (print (list3 (quote eval) e env))
+   (COND
+     ((ATOM E) (COND ((BOUNDP E ENV) (GET E ENV))
+                     (T (ERROR (LIST1 (QUOTE :UNDEFINED))
+                               (LIST1 E)))))
+     ((EQ (FIRST E) (QUOTE NULL))    (NULL  (EVAL (FIRST (REST E)) ENV)))
+     ((EQ (FIRST E) (QUOTE ATOM))    (ATOM  (EVAL (FIRST (REST E)) ENV)))
+     ((EQ (FIRST E) (QUOTE QUOTE))   (FIRST (REST E)))
+     ((EQ (FIRST E) (QUOTE EQ))      (EQ    (EVAL (FIRST (REST E)) ENV)
+                                            (EVAL (FIRST (REST (REST E))) ENV)))
+     ((EQ (FIRST E) (QUOTE COMBINE)) (COMBINE (EVAL (FIRST (REST E)) ENV)
+                                            (EVAL (FIRST (REST (REST E))) ENV)))
+     ((EQ (FIRST E) (QUOTE FIRST))   (FIRST (EVAL (FIRST (REST E)) ENV)))
+     ((EQ (FIRST E) (QUOTE REST))    (REST  (EVAL (FIRST (REST E)) ENV)))
+     ((EQ (FIRST E) (QUOTE COND))    (EVCON (REST E)))
+     ((EQ (FIRST E) (QUOTE LOAD))    (LOAD  (EVAL (FIRST (REST E)) ENV)))
+     ((EQ (FIRST E) (QUOTE PRINT))   (PRINT (EVAL (FIRST (REST E)) ENV)))
+     ((EQ (FIRST E) (QUOTE READ))    (READ))
+     ((ATOM (FIRST E))
+      (COND ((BOUNDP (FIRST E) env) (APPLY (GET (FIRST E) ENV) (REST E) ENV))
+            (T (ERROR (LIST1 (QUOTE :UNDEFINED))
+                      (LIST1 (FIRST E))))))
+     ((EQ (FIRST (FIRST E)) (QUOTE LAMBDA))
+      (EVLAM (FIRST (REST (FIRST E)))
+             (FIRST (REST (REST (FIRST E))))
+             (REST E) ENV))
+     ((EQ (FIRST (FIRST E)) (QUOTE LABEL))
+      (EVAL (COMBINE (SUBST (FIRST E)
+                         (FIRST (REST (FIRST E)))
+                         (FIRST (REST (REST (FIRST E)))))
+                  (REST E)) ENV))
+     (T (ERROR (LIST1 (QUOTE :INVALID))
+               (LIST1 (FIRST E)))))))
+
+(DEFINE REPL
+         (LAMBDA (INPUT ENV)
+           (COND
+             ((NULL INPUT) NIL)
+             (T ((LAMBDA (SEXP INPUT ENV)
+                   (COND
+                     ((AND (NOT (ATOM SEXP)) (EQ (FIRST SEXP) (QUOTE DEFINE)))
+                      (REPL INPUT (SET (FIRST (REST SEXP))
+                                       (FIRST (REST (REST SEXP))) ENV)))
+                     (T
+                      (COMBINE (EVAL SEXP ENV) (REPL INPUT ENV)))))
+                 (FIRST INPUT) (REST INPUT) ENV)))))
+
+;;;; aim-8.aim-8                      --                     --          ;;;;
diff --git a/small-cl-pgms/aim-8/aim-8.html b/small-cl-pgms/aim-8/aim-8.html
new file mode 100644
index 0000000..b815878
--- /dev/null
+++ b/small-cl-pgms/aim-8/aim-8.html
@@ -0,0 +1,779 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">
+
+<HTML>
+ <HEAD>
+  <link rel="icon"          href="/favicon.ico" type="image/x-icon">
+  <link rel="shortcut icon" href="/favicon.ico" type="image/x-icon">
+  <link rel="stylesheet"    href="default.css"  type="text/css">
+
+  <TITLE>RECURSIVE FUNCTIONS OF SYMBOLIC EXPRESSIONS
+         AND THEIR COMPUTATION BY MACHINE</TITLE>
+  <META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=utf-8">
+  <META HTTP-EQUIV="Description"
+        NAME="description" CONTENT="AIM-8">
+  <META NAME="author"      CONTENT="John McCarthy">
+  <META NAME="keywords"    CONTENT="LISP, AIM-8, AI Memo-8, John McCarthy,recursive function, symbolic expression, computation, turing machine, lambda calculus, computer history, programming language history">
+ </HEAD>
+
+ <BODY>
+<!--TOP-BEGIN-->
+<!-- This section is automatically generated by html-update, -->
+<!-- from data in 'node.el'.    Please, do not edit it here. -->
+<DIV CLASS="TOP">
+
+</DIV>
+<!--TOP-END-->
+<!--MENU-BEGIN-->
+<!-- This section is automatically generated by html-update, -->
+<!-- from data in 'node.el'.    Please, do not edit it here. -->
+<DIV CLASS="MENU"><HR><P>|
+ <A HREF="../../../../toc.html">Contents</a> |
+ <A HREF="../../../../index.html">Home</a> |
+ <A HREF="index.html">Previous</a> |
+ <A HREF="index.html">Up</a> |
+ <A HREF="../m-expression/index.html">Next</a> |
+</P><HR></DIV>
+<!--MENU-END-->
+
+<p>Here is a transcription into machine readable form of the
+original <a href="ftp://publications.ai.mit.edu/ai-publications/pdf/AIM-008.pdf">
+AI Memo 8, AIM-008.pdf</a></p>
+<p>Also available as <a href="aim-8.txt.gz">compressed text file (utf-8)</a>.</p>
+
+<PRE><BIG>
+<HR>
+                                    March 23, 1959
+
+Artificial intelligence Project---RLE and MIT Computation Center
+
+                         Memo 8
+
+RECURSIVE FUNCTIONS OF SYMBOLIC EXPRESSIONS AND THEIR COMPUTATION
+
+                       BY MACHINE
+
+                     by J. McCarthy
+
+                   An Error in Memo 8
+
+
+     The definition of eval given on page 15 has two errors,
+one of which is typographical and the other conceptual.  The
+typographical error is in the definition of evcon where
+"1⟶" and "T⟶" should be interchanged.
+     The second error is in evlam.  The program as it stands
+will not work if a quoted expressoin contains a symbol which
+also acts as a variable bound by the lambda.  This can be
+corrected by using insteaad of subst in evlam a function subsq
+defined by
+     subsq=λ[[x;y;z];[null[z]⟶⋀;atom[z]⟶
+[y=z⟶x;l⟶z];first[z]=QUOTE⟶z;l⟶
+ combine[subsq[x;y;first[z]];subsq[x;y;rest[x]]]]]
+<HR>
+                                    March 4, 1959
+
+Artificial intelligence Project---RLE and MIT Computation Center
+
+                         Memo 8
+
+RECURSIVE FUNCTIONS OF SYMBOLIC EXPRESSIONS AND THEIR COMPUTATION
+
+                       BY MACHINE
+
+                     by J. McCarthy
+
+     The attached paper is a description of the LISP system
+starting with the machine-independent system of recursive
+functions of symbolic expressions.  This seems to be a better
+point of view for looking at the system than the original
+programming approach.  After revision, the paper will be sub-
+mitted for publication in a logic or computing journal.
+     This memorandum contains only the machine independent
+parts of the system.  The representation of S-expressions in
+the computer and the system for representing S-functions by
+computer subroutines will be added.
+
+<HR>
+                          -1-
+
+RECURSIVE FUNCTIONS OF SYMBOLIC EXPRESSIONS AND THEIR
+              COMPUTATION BY MACHINE
+       by J. McCarthy, MIT Computation Center
+
+1.    Introduction
+      A programming system called LISP (for LISt Processor)
+has been developed for the IBM 704 computer by the Artificial
+Intelligence Group at MIT.  The system was designed to facili-
+tate experiments with a proposed system called the Advice Taker
+whereby a machine could be instructed in declarative as well
+as imperative sentences and could exhibit "common sense" in
+carrying out its instructions.  The original proposal for the
+Advice Taker is contained in reference 1.  The main require-
+ment was a programming system for manipulating    expressions
+representing formalized declarative and imperative sentences
+so that the ADvice Taker system could make deductions.
+     The development of the LISP system went through several
+stages of simplification in the course of its development and
+was eventually seen to be based on a scheme for representing
+the partial recursive functions of a certain class of symbolic
+expressions.  This representation is independent of the IBM 704
+or any other electronic computer and it now seems expedient
+to expound the system starting with the class of expressions
+called S-expressions and the functions called S-functions.
+     In this paper, we first describe the class of S-expressions
+and S-functions.  Then we describe the representation of
+S-functions by S-expressions which enables us to prove that
+all computable partial functions have been obtained, to obtain
+a universal S-function, and to exhibit a set of questions
+about S-expressions which cannot be decided by an S-function.
+We describe the representation of the system in the IBM 704,
+including the representation of S-expressions by list structures
+similar to those used by Newell, Simon, and Shaw (see refer-
+ence 2), and the representation of S-functions by subroutines.
+Finally, we give some applications to symbolic calculations
+including analytic differentiation, proof checking, and
+compiling including a description of the present status of
+the LISP compiler itself which is being written in the system.
+     Although we have not carried out the development of
+<HR>
+                          -2-
+
+recursive function theory in terms of S-functions and their
+representation by S-expressions beyond the simplest theorems,
+it seems that formulation of this theory in terms of S-func-
+tions has important advantages.  Devices such as Gödel number-
+ing are unnecessary and so is the construction of particular
+Turing machines.  (These constructions are all artificial in
+terms of what is intended to be accomplished by them).  The
+advantage stems from the fact that functions of symbolic
+expressoins are easily and briefly described as S-expressions
+and the representation of S-functions by S-expressions is
+trivial.  Moreover, in a large class of cases the S-expression
+representations of S-functions translate directly into effi-
+cient machine programs for the computation of the functions.
+Although, the functions described in the manner of this paper
+include all computable functions of S-expressions, describe
+many important processes in a very convenient way, and compile
+into fast running programs for carrying out the processes;
+there are other kinds of processes whose description by S-func-
+tions is inconvenient and for which the S-functions once found
+do not naturally compile into efficient programs.  For this
+reason, the LISP system includes the possibility of combining
+S-functions into Fortran or IAL-like programs.  Even this
+will not provide the flexibility of description of processes
+hoped for from the Advice Taker system which is beyond the
+scope of this paper.
+
+2.   Recursive Functions of Symbolic Expressions
+     In this section we define the S-expressions and the
+S-functions.  (Actually they are partial functions.  The
+distinction between a partial function and a function that
+the former need not be defined for all arguments because, for
+example, the computation process defining it may not terminate.)
+
+     2.1. S-expressions
+     The expression with which we shall deal are formed
+using the special characters "," and "("  and  ")" and an
+infinite set of distinguishable atomic symbols p₁,p₂,p₃,....
+<HR>
+                          -3-
+
+     The S-expressions are formed according to the following
+recursive rules.
+          1.   The atomic symbols p₁ p₂ etc are S-expressions.
+          2.   A null expression ⋀ is also admitted.
+          3.   If e is an S-expression so is  (e).
+          4.   If e₁ and (e₂) are S-expressions so is (e₁,e₂).
+     In what follows we shall use sequences of capital Latin
+letters as atomic symbols.  Since we never juxatpose them with-
+out intervening commas they cannot cause confusion by running
+together.  Some examples of S-expressions are;
+          AB
+          (AB,A)
+          (AB,A,,C,)
+          ((AB,C),A,(BC,(B,B)))
+     2.2  Elementary functions and predicates
+     The functions we shall need are built up from certain
+elementary ones according to certain recursive rules.
+     There are three elementary predicates:
+     1.   null[e]
+          null[e] is true if and only if S-expression e is the
+null expression ⋀.  (We shall use square brackets and semi-colons
+for writing functions of S-expressions since parentheses and
+commas have been pre-empted.  When writing about functions in
+general we may continue to use parentheses and commas.)
+     2.   atom[e]
+          atom[e] is true if and only if the S-expression is
+an atomic symbol.
+     3.   p₁=p₂
+          p₁=p₂ is defined only when p₁ and p₂ are both atomic
+symbols in which case it is true if and only if they are the
+same symbol.  This predicate expresses the distinguishability
+of the symbols.
+     There are three basic functions of S-expressions whose
+values are S-expressions.
+     4.   first[e]
+          first[e] is defined for S-expressions which are
+neither null nor atomic.  If e has the form (e₁,e₂) where e₁
+is an expression, then first[e]=e₁.  If e has the form (e₁)
+wehre e₁ is an S-expression again we have first[e]=e₁.
+<HR>
+                          -4-
+
+          Some examples are:
+          first[(A,B)]=A
+          first[A] is undefined
+          first[(A)]=A
+          first[((A,B),C,D)]=(A,B)
+     5.   rest[e]
+          rest[e] is also defined for S-expressions which are
+neither null nor atomic.  If e has the form (e₁,e₂) where e₁
+is an S-expression, then rest[e]=(e₂).  If e has the form (e₁)
+wehre e₁ is an S-expression we have rest[e]=⋀.
+          Some examples are:
+          rest[(A,B)]=(B)
+          rest[(A)]=⋀
+          rest[(A,B,C)]=(B,C)
+     6.   combine[e₁;e₂]
+          combine[e₁;e₂] is defined when e₂ is not atomic.
+                When e₂  has the form (e₃), then combine[e₁;e₂]=(e₁,e₃)
+     When e₂ is ⋀ we have combine[e₁;e₂]=(e₁).
+          Some examples are:
+          combine[A;⋀]=(A)
+          combine[(A,B);(B,C)]=((A,B),B,C)
+     The functions first, rest and combine are related by the
+relations
+          first[combine[e₁;e₂]]=e₁
+          rest[combine[e₁;e₂]]=e₂
+          combine[first[e];rest[e]]=e
+whenever all the quantities involved are defined.
+
+     2.3  Functional Expressions and Functions formed from the
+     elementary functions by composition.
+          Additional functions may be obtained by composing the
+elementary functions of the preceding section.  These functions
+are decribed by expressions in the meta-language which should
+not be confused with the S-expressions being manipulated.  For
+example, the expression first[rest[e]] debute the second sub-
+expression of the S-expression e, e.g. first[rest[(A,B,C)]]=B.
+In general compositions of first and rest give sub-expressions of
+an S-expression in a given position within the expression and
+<HR>
+                          -5-
+
+compositions of combine form S-expressions from their sub-
+expressions.  For example, combine[x;combine[y;combine[z,⋀]]]
+forms as sequence of three ters from the terms, e.g. combine
+[A;combine[(B,C);combine[A,⋀]]]=(A,(B,C),A).
+     In order to be able to name compositions of functions and
+not merely functional expressions (forms) we use the Church
+λ-notation.  If ℰ is a functional expression and x₁,...,xn are
+variables which may occur in ℰ, then λ[[x₁,...,xn],] denotes
+the function of n variables that maps x₁,...,xn into ℰ.  For
+example, λ[[x],first[rest[x]]] is the function which selects the
+second element of a list and we have λ[[x],first[rest[x]]][(A,
+[B,C],A)]=[B,C].  λ[[x];[A,B]] is the constant function that
+maps every S-expression into [A,B].
+     The variables occuring in the list of a λ-expression are
+bound and replacing such a variable throughout a λ-expression
+by a new variable does not change the function represented.
+Thus λ[[x,y], combine[x,combine[y,⋀]]] is the same function as
+λ[[u,v], combine[u,combine[v,⋀]]] but different from λ[[y,x],
+combine[x,combine[y,⋀]]].
+     If some of the variables in a functional expressoin or
+form are bound by λ's and others are not, we get a function
+dependent on parameters or from another point of view a form
+whose value is a function when values have been assigned to
+the variables.
+     2.4  Conditional Expressions
+     Let p₁,p₂,...,pk be expressions representing propositions
+and let e₁,...,ek be arbitrary expressions.   The expression
+[p₁⟶e₁,...pk⟶ek] is called a conditional expression and its
+value is determined from the values assigned to the variables
+occuring in it as follows:  If the value of p₁ is not defined
+neither is that of the conditional expression.  If p₁ is defined
+and true the value of the conditional expression is that of e₁
+if the latter is defined and otherwise is undefined.  If p₁ is
+defined and false, then the value of [p₁⟶e₁,...,pk⟶ek] is that
+of [p₂⟶e₂,...pk⟶ek].  Finally if pk is false the value of
+[pk⟶ek] is undefined.
+     An example of a conditional expression is [null[x]⟶⋀;
+atom[x]⟶⋀;1⟶first[x]].  The "1" occuring in the above
+expression is the propositional constant "truth".  We also use
+<HR>
+                          -6-
+
+"0" for the propositional constant "falsehood".  When used as then
+last proposition in a conditional expression "1" may be read
+"in all remaining cases".  The expression given is a sort of
+extension of the expressoin first[x] which is defined for all
+S-expressions.  We could define a corresponding function by
+first_a=λ[[x]; [null[x]⟶⋀;atom[x]⟶⋀;1⟶first[x]]].
+     It is very important to note that for a conditional
+expressoin to be defined it is not necessary for all of its
+sub-expressions to be defined.  If p₁ is defined and true and
+e₁ is defined, the conditional expression [p₁⟶e₁,...,pk⟶ek]
+is defined even if none of the other p's or e's is defined.
+If p₁ is defined and false, p₂ is defined and true and e₂ is
+defined, the expression is defined even if e₁ and all the other
+p's and e's are undefined.
+     The propositional connectives ∧ and ∨ and ∼ may be defined
+in terms of conditional expressions.  We have p₁∧p₂=[p₁⟶[p₂
+⟶1,1⟶0],1⟶0] and p₁∨p₂=[p₁⟶1,p₂⟶1,1⟶0] and ∼p=[p⟶0,1⟶1]
+There is a slight difference between the connecetives defined
+this way and the ordinary connectives.  Suppose that p₁ is
+defined and true but p₂ is undefined.  Then p₁∨p₂ is defined
+and true but p₂∨p₁ is undefined.
+     2.5  Recursive Function Definitions
+     The functions which can be obtained from the elementary
+functions and predicates by composition and conditional expres-
+sions form a limited class. As we have decribed them they are
+not defined for all S-expressions but if we modified the
+definitions of the elementary functions so that the undefined
+cases are defined in some trivial way, as in the example of the
+pervious section, the would be always defined.
+     Additional functions may be defined by writing definitions
+of the form,
+     f=λ[[x₁,...,xn],ℰ] where the expression ℰ may contain the
+symbol f itself.  A function f defined in this way is to be
+computed for a given argument is to be computed by substitution
+of the argument into the expression and attempting to evaluate
+the resulting expression.  When a conditional expression is
+encountered we evaluate p's until we find a true p and then
+evaluate the corresponding e.  No attempt is made
+<HR>
+                          -7-
+
+to evaluate later p's or any e except the one corresponding
+to the first e.  It may happen that in evaluating for given
+values of the variables it is unnecessary to evaluate any
+expression involving the defined function f.  In this case,
+the evaluation may be completed and the function defined for
+this argument.  If expressions involving f do have to be
+evaluated we substitute the arguments of f and again proceed
+to evaluate.  The process may or may not terminate.  For
+those arguments for which the process does terminate the
+function is defined.
+     We shall illustrate this concept by several examples:
+     1.  Our first example is a function which gives the
+first symbol of an expression:
+We defined
+     ff=λ[[x];[null[x]∨atom[x]⟶x;1⟶ff[first[x]]]]
+Let us trace the computation of ff[(((A),B),C)].  We have
+ff[(((A),B),C)]=[null[(((A),B),C)]∨atom[(((A),B),C)]⟶x;
+     1⟶ff[first[(((A),B),C)]]]]
+          =ff[((A),B)]
+          =[null[((A),B)]∨atom[((A),B)]⟶((A),B);1⟶ff[first[((A),B)]]]
+          =ff[(A)]
+          =[null[(A)]∨atom[(A)]⟶(A);1⟶ff[first[(A)]]]
+          =ff[A]
+          =[null[A]∨atom[A]⟶A;1⟶ff[first[A]]]
+          =A
+*    Note that it does not matter that first A occuring in the
+next to last step is undefined.
+     2.   The second example is a function which gives the result
+of substituting the expression x for the symbol y in the expres-
+sion s.  We define
+     subst=λ[[x;y;s];[null[s]⟶⋀;atom[s]⟶[y=s⟶x;1⟶s];1⟶
+          combine[subst[x;y;first[s]];subst[x;y;rest[s]]]]]
+     We shall illustrate teh application of this definition by
+computing subst[(A,B);X;((X,A),C)].  In order to make the tracing
+shorter we shall give the situation at each recursion and leave
+it to the reader to substitute the definition of each subst
+expression and to check the determination of which case of the
+<HR>
+                          -8-
+
+conditional is applicable.  We have
+     subst[(A,B);X;((X,A),C)]=
+     =combine[subst[(A,B);X;(X,A)];subst[(A,B);X;(C)]]
+     =combine[combine[subst[(A,B);X;X];subst[(A,B);X;(A)]];combine[
+          subst[(A,B);X;C];subst[(A,B);X;⋀]]]
+     =combine[combine[(A,B);combine[subst[(A,B);X;A];subst[(A,B)
+          ;X;⋀]]];combine[C;⋀]]
+     =combine[combine[(A,B);combine[A;⋀]];(C)]
+     =(((A,B),A),C)
+     2.6  Functions with Functions as arguments
+     If we allow variables representing functions to occur in
+expressions and create functions by incorporating these variables
+as arguments of λ's we can define certain functions more concisely
+than without this facility.  However, as we shall show later no
+additional S-function become definable.
+     As an example of this facility we define a function maplist [x,f]
+     where x is an S-expression and f is a function from S-expres-
+sions to S-expressions.  We have
+maplist=λ[[x,f];[null[x]⟶⋀;1⟶combine[f[x];maplist[rest[x];f]]]]
+     The usefulness of maplist is illustrated byb formulas for
+the partial derivative with respect to x of expressions involving
+sums and products of x and other variables.  The S-expressions
+we shall differentiate are formed as follow:
+1.   An atomic symbol is an allowed expression.
+2.   If e₁;e₂;...;en are allowed expressions so are (PLUS,e₁,
+...,en) and (TIMES,e₁,...,en) and represent the sum and product
+respectively of e₁;...;en
+     This is essentially the Polish notation for functions except
+that the inclusion of parentheses and commas allows functions of
+variable numbers of arguments.  An example of an allowed
+expression is
+     (TIMES,X,(PLUS,X,A),Y)
+the conventional algebraic notation for which is X(X+A)Y
+     Our differentiation formula is
+     diff=λ[[y;x];[atom[y]⟶[y=x]⟶ONE;1⟶ZERO];
+first[y]=PLUS⟶combine[PLUS;maplist[rest[y];λ[[z];diff[
+first[z];x]]]];first[y]=TIMES⟶combine[PLUS;maplist[
+rest[y];λ[[z];combine[TIMES;maplist[rest[y];λ[[w];[z≠w
+⟶first[w];1⟶diff[first[w];x]]]]]]]]]
+<HR>
+                          -9-
+
+     The derivative of the above expression computed by this
+formula is
+(PLUS,(TIMES,ONE,(PLUS,ONE,ZERO),Y),(TIMES,X,(PLUS,ONE,ZERO),Y),
+     (TIMES,X,(PLUS,X,ZERO),ZERO))
+     2.7  Labelled Expressions
+     The λ-notation used for naming functions is inadequate
+for naming recursive functions.  For example, if the function
+named as the second argument of a maplist is to be allowed to
+be recursive an additional notation is required.
+     We define label[s;e] where  s  is a symbol and  e  is an
+expression to be the same as the exression  e  except that
+if  s  occurs as a sub-expression of  e  it is understood to
+refer to the exression  e.  The symbol  s  is bound in label
+[s;e]  and has no significance outside this expression.  Label
+acts as a quantifier with respect to its first argument but a
+quantifier of a different sort from λ.  As an example
+     label[subst;λ[[x;y;s];[null[s]⟶⋀;atom[s]⟶
+          [y=s⟶x;1⟶s];1⟶combine[subst[x;y;first[s]];
+               subst[x;y;rest[s]]]]]]
+is a name suitable for inclusion in a maplist of the substitu-
+tion function mentioned earlier.
+     2.8  Computable Functions
+     In this section we shall show that all functions compu-
+table by Turing machine are expressable as S-functions.  If,
+as we contend, S-functions are a more suitable device for
+developing a theory of computability than Turing machines,
+the proof in this section is out of place and should be re-
+placed by a plausibility argument similar to what is called
+"Turing's thesis" to the effect that S-functions satisfy our
+intuitive notion of effectively computable functions.  The
+reader unfamiliar with Turing machines should skip this section.
+     Nevertheless, Turing machines are well entrenched at present
+so we shall content ourselves with showing that any function
+computable by turing machine is an S-function.  This is done
+as follows:
+     1.   We give a way of describing the instantaneous con-
+figurations of a Turing machine calculation by an S-expression.
+This S-expression must describe the turing machine, its
+<HR>
+                          -10-
+
+internal state, the tape, and the square on the tape being
+read.
+     2.   We give an S-function succ whose arguments is an
+instantaneous configuration and whose value is the immediately
+succeeding configuration if there is one and otherwise is 0.
+     3.   We construct from succ another S-function, turing,
+whose arguments are a Turing machine, with a canonical initial
+state and an initial tape in a standard position and whose
+value is defined exactly when the corresponding Turing machine
+calculation terminates and in that case is the final tape.
+     We shall consider Turing machines as given by sets of
+quintuples.  Each quintuple consists of a state,
+a symbol read, a symbol to be printed, a direction of motion
+and a new state.  The states are represented by a finite set
+of symbols, the symbols which may occur by another finite set
+of symbols (it doesn't matter whether these sets overlap) and
+the two directions by the symbols "L" and "R".  A quintuple is
+then represented by an S-expression (st,sy,nsy,dir,nst).
+The Turing machine is represented by an S-expression. (ist,
+blank,quin1,...quink) were ist represents the canonical
+initial state, blank is the symbol used for a blank square
+(squares beyond the region explicitly represented in the
+S-expression for a tape are assumed to be blank and are read
+that way when reached).  As an example, we give the representa-
+tion of a Turing machine which moves to the right on a tape
+and computes the parity of the number of 1's on the tape ignoring
+0's and stopping when it comes to a blank square:
+(0,B,(0,0,B,R,0),(0,1,B,R,1),(0,B,0,R,2),(1,0,B,R,1),(1,1,B,R,0),
+(1,B,1,R,2))
+The machine is assumed to stop if there is no quintuple with a
+given symbol state pair so that the above machine stops as soon
+as it enters state 2.
+     A Turing machine tape is represented by an S-expression as
+follows:  The symbols on the squares to the right of the scanned
+square are given in a list v, the symbols to the left of the
+scanned square in a list u and the scanned symbol as a quantity w.
+These care combined in a list (w,u,v).  This the tape ...bb1101⓪10b...
+is represented by the expression
+     (0,(1,0,1,b,b),(1,1,0,b))
+<HR>
+                          -11-
+
+     We adjoin the state to this triplet to make a quadruplet
+(s,w,u,v) which describes the instantaneous configuration of a
+machine.
+     The function succ[m;c] whose arguments are a Turing machine
+m  and  a configuration  c  has as value the immediately suc-
+ceeding configuration of  c  provided the state-symbol pair is
+listed among the quintuplets of  m  and otherwise has value zero.
+     succ is defined with the aid of auxiliary functions.  The
+first of these  find[st;sy;qs] given the triplet (nsy;dir;nst)
+which consists of the last 3 terms of the quintuplet of  m  which
+contains  (st,sy)  as its first two elements.  The recursive
+definition is simplified by defining find [st;sy;qs] where
+qs=rest[rest[m]] since qs then represents the list of quintuplets
+of  m.  We have find[st;sy;qs]=[null[qs]⟶0;first[first[qs]]
+=st∧first[rest[first[qs]]]=sy⟶rest[rest[first[qs]]];1⟶find
+[st;sy;rest[qs]]]
+     The new auxiliary function is move[m;nsy;tape;dir] which
+gives a new tape triplet obtained by writing nsy  on the scanned
+square of tape, and moving in the direction dir.
+move[m;nsy;tape;dir]=[dir=L⟶combine[[
+null[first[rest[tape]]]⟶first[rest[m]];1⟶first[first[rest[tape]]]
+];combine[[null[first[rest[tape]]]⟶⋀;1⟶
+rest[first[rest[tape]]]];combine[combine[nsy;
+first[rest[rest[tape]]]];⋀]]];dir=R⟶
+combine[[null[first[rest[rest[tape]]]]⟶
+first[rest[m]];1⟶first[first[rest[rest[tape]]]]];
+combine[combine[nsy;first[rest[tape]]];
+combine[[null[first[rest[rest[tape]]]]⟶⋀;1⟶
+rest[first[rest[rest[tape]]]]];⋀]]]]
+     The reader should not be alarmed at the monstrous size of
+the last formula.  It rises mainly from the compositions of first
+and rest required to select the proper elements of the structure
+representing the tape. Later we shall descrirbe ways of writing
+such expressions more concisely.
+     We now have
+succ[m;c]=[find[first[c];first[rest[c]];rest[rest[m]]]
+=0⟶0;1⟶combine[first[rest[rest[find[
+  first[c];first[rest[c]];rest[rest[m]]]]]];
+move[m;first[find[first[c];first[rest[c]];
+rest[rest[m]]]];rest[c];first[rest[find[
+first[c];first[rest[c]];rest[rest[m]]]]]]]]
+<HR>
+                          -12-
+
+     Finally we define
+turing[m;tape]=tu[m;combine[first[m];tape]]
+where
+tu[m;c]=[succ[m;c]=0⟶rest[c];1⟶tu[m;succ[m;c]]]
+     We reiterate that these definitions can be greatly shortened
+by some devices that will be discussed in the sections on the
+machines  computation of S-functions.
+<HR>
+                          -13-
+
+3.   Lisp Self-applied
+     The S-functions have been described by a class of expres-
+sions which has been informally introduced.  Let us call these
+expressions F-expressions.  If we provide a way of translating
+F-expressions into S-expressions, we can use S-functions to
+represent certain functions and predicates of S-expressions.
+     First we shall describe this translation.
+     3.1  Representation of S-functions as S-expressions.
+     The representation is determined by the following rules.
+     1.  Constant S-expressions can occur as parts of the
+F-expressions representing S-functions.  An S-expression ℰ is
+represented by the S-expression.  (QUOTE,ℰ)
+     2.  Variables and function names which were represented
+by strings of lower case letters are represented by the cor-
+responding strings of the corresponding upper case letters.
+Thus we have FIRST, REST and COMBINE, and we shall use X,Y
+etc. for variables.
+     3.  A form is represented by an S-expression whose first
+term is the name of the main function and whose remaining terms
+are the argumetns of the function.  Thus combin[first[x];
+rest[x]] is represented by (COMBINE,(FIRST,X),(REST,X))
+     4.  The null S-expression ⋀ is named NIL.
+     5.  The truth values  1  and 0  are denoted by T and F.
+         The conditional expressoin
+     write[p₁⟶e₁,p₂⟶e₂,...pk⟶ek]
+is repersented by
+          (COND,(p₁,e₁),(p₂,e₂),...(pk,ek))
+     6.  λ[[x;..;s];ℰ] is represented by (LAMBDA,(X,...,S),ℰ)
+     7.  label[α;ℰ] is represented by (LABEL,α,ℰ)
+     8.  x=y is represented by (EQ,X,Y)
+     With these conventions the substitution function mentioned
+earlier whose F-expression is
+     label[subst;λ[[x;y;s];[null[s]⟶⋀;atom[s]⟶
+          [y=s⟶x;1⟶s];1⟶combine[subst[x;y;first[s]];
+               subst[x;y;rest[s]]]]]]
+is represented by the S-expression.
+          (LABEL,SUBST,(LAMBDA,(X,Y,Z),(COND,((NULL,
+               Z),NIL),((ATOM,Z),(COND)((EQ,Y,Z),X),(1,Z))),
+                    (1,(COMBINE,(SUBST,X,Y,(FIRST,Z)),
+                         (SUBST,X,Y,(REST,Z))))))
+<HR>
+                          -14-
+
+     This notation is rather formidable for a human to read,
+and when we come to the computer form of the system we will
+see how it can be made easier by adding some features to the
+read and print routines without changing the internal compu-
+tation processes.
+     3.2.  A Function of S-expressions which is not an S-function.
+     It was mentioned in section 2.5 that an S-function is not
+defined for values of its arguments for which the process of
+evaluation does not terminate.  It is easy to give examples
+of S-functions which are defined for all arguments, or examples
+which are defined for no arguments, or examples which are
+defined for some arguments.  It would be nicie to be able to
+determine whether a given S-function is defined for given
+arguments.  Consider, then, the function def[f;s] whose value
+is 1 if the S-function whose corresponding S-expression is  f
+is defined for the list of arguments  s  and is zero otherwise.
+     We assert that def[f,s] is not an S-function.  (If we
+assume Turing machine theory this is an obvious consequence
+of the results of section 2.8, but in support of the contentions
+that S-functions are a good vehicule for expounding the theory
+of recursive functions we give a separate proof).
+
+Theorem:  def[f;s] is not an S-function.
+Proof:    Suppose the contrary.  Consider the function
+g=λ[[f];[∼def[f;f]⟶1;1⟶first[⋀]]]
+     If def were an S-function g would also be an S-function.
+For any S-function  u  with S-expression  u' g[u'] is 1 if u[u']
+undefined and is undefined otherwise.
+Consider now g[g'] where g' is an S-expression for g.  Assume
+first that g[g'] were defined.  This is precisely the condi-
+tion that g' be the kind of S-expression for which  g  is
+undefined.  Contrawise, were g[g'] undefined  g'  would be the
+kind of S-expression for which  g  is defined.
+     Thus our assumption that def[f;s] is an S-function leads
+to a contradiction.
+     The proof is the same as the corresponding proof in
+Turing machine theory.  The simplicity of the rules by which
+S-functions are represented as S-expressions makes the develop-
+ment from scratch simplier, however.
+<HR>
+                          -15-
+
+     3.3  The Universal S-Function, Apply
+     There is an S-function apply such that if  f  is an
+S-expression for an S-function φ and args is a list of the
+form (arg1,...,arg n) where arg1,---,arg n are arbitrary
+S-expressions then apply[f,args] and φ[arg1;...;argn]
+are defined for the same values of arg1,...arg n and are
+equal when defined.
+     apply is defined by
+     apply[f;args]=eval[combine[f;args]]
+     eval is defined by
+eval[e]=[
+first[e]=NULL⟶[null[eval[first[rest[e]]]]⟶T;1⟶F]
+first[e]=ATOM⟶[atom[eval[first[rest[e]]]]⟶T;1⟶F]
+first[e]=EQ⟶eval[first[rest[e]]]=eval[first[rest[rest[e]]]]⟶T;
+     1⟶F]
+first[e]=QUOTE⟶first[rest[e]];
+first[e]=FIRST⟶first[eval[first[rest[e]]]];
+first[e]=REST⟶rest[eval[first[rest[e]]]];
+first[e]=COMBINE⟶combine[eval[first[rest[e]]];eval[first[rest[rest
+     [e]]]]];
+first[e]=COND⟶evcon[rest[e]];
+first[first[e]]=LAMBDA⟶evlam[first[rest[first[e]]];first[rest[rest
+    [first[e]]]];rest[e]];
+first[first[e]]=LABEL⟶eval[combine[subst[first[e];first[rest
+    [first[e]]];first[rest[rest[first[e]]]]];rest[e]]]]
+where: evcon[c]=[eval[first[first[c]]]=1⟶eval[first[rest[first[c]]]];
+           T⟶evcon[rest[c]]]
+and
+evlam[vars;exp;args]=[null[vars]⟶eval[exp];1⟶evlam[
+    rest[vars];subst[first[args];first[vars];exp];rest[args]]]
+    The proof of the above assertion is by induction on the
+subexpressions of  e.  The process described by the above
+functions is exactly the process used in the hand-worked
+examples of section 2.5.
+<HR>
+                          -16-
+
+4.   Variants of Lisp
+     There are a number of ways of defining functions of
+symbolic expressions which are quite similar to the system
+we have adopted.  Each of them involves three basic functions,
+conditional expressions and recursive function definitions,
+but the class of expressions corresponding to S-expressions
+differs and sod o the precise definitions of the functions.
+We shall describe two fo these variants.
+     4.1  Linear Lisp
+          The L-expressions are defined as follows:
+     1.   A finite list of characters is admited.
+     2.   Any string of admited characters in an L-expres-
+sion.  This includes the null string denoted by ⋀
+     There are three functions of strings
+     1.   first[x] is the first character of the string x.
+          first[⋀] is undefined.
+     For example, first [ABC]=A.
+     2.   rest[x] is the string of characters remaining when
+the first character of the string is deleted.
+          rest[⋀] is undefined.
+          For example, rest[ABC]=BC
+     3.   combine[x;y] is the string formed by prefixing the
+character  x  to the string  y.
+          For example, combine[A;BC]=ABC
+     There are three predicates on strings
+     1.   char[x],  x is a single character
+     2.   null[x],  x is the null string
+     3.   x=y,      defined for  x  and  y characters.
+     The advantage of linear Lisp is that no cahracters are
+given special roles as are parentheses and comma in Lisp.
+This permits computations with any notation which can be
+written linearly.  The disadvantage of linear Lisp is that
+the extraction of sub-expressions is a fairly involed rather
+than an elementary operation.  It is not hard to write in
+linear lisp functions corresponding to the basic functions of
+Lisp so that mathematically linear Lisp includes Lisp.  This
+turns otu to be the most convenient way of programming more
+complicated manipulations.  However, it tunrs out that if the
+functions are to be represented by computer routines Lisp is
+essentially faster.
+<HR>
+                          -17-
+
+     4.2  Binary Lisp
+     The unsymmetrical status of  first  and  rest  may be a
+source of uneasiness.  If we admit only two element lists
+then we can define
+     first[(e₁,e₂)]=e₁
+     rest[(e₁,e₂)]=e₂
+     combine[e₁;e₂]=(e₁,e₂)
+     We need only two predicates, equality for symbols and
+atom.  The null list can be dispensed with.  This system is
+easier until we try to represent functions by expressions which
+is, after all, the principal application; moreover, in order
+to apply the system to itself we need to be abel to write
+functions.
+<HR>
+</BIG></PRE>
+
+<!--MENU-BEGIN-->
+<!-- This section is automatically generated by html-update, -->
+<!-- from data in 'node.el'.    Please, do not edit it here. -->
+<DIV CLASS="MENU"><HR><P>|
+ <A HREF="../../../../toc.html">Contents</a> |
+ <A HREF="../../../../index.html">Home</a> |
+ <A HREF="index.html">Previous</a> |
+ <A HREF="index.html">Up</a> |
+ <A HREF="../m-expression/index.html">Next</a> |
+</P><HR></DIV>
+<!--MENU-END-->
+<!--BOTTOM-BEGIN-->
+<!-- This section is automatically generated by html-update, -->
+<!-- from data in 'node.el'.    Please, do not edit it here. -->
+<DIV CLASS="BOTTOM">
+<hr><code><small>
+ | <a href="http://www.informatimago.com//develop/lisp/small-cl-pgms/aim-8/aim-8.html">Mirror on informatimago.com</a>
+ | <a href="http://informatimago.free.fr/i//develop/lisp/small-cl-pgms/aim-8/aim-8.html">Mirror on free.fr</a>
+ | </small></code>
+
+<BR><SMALL>Last update : <!--MODIFICATION-DATE--> 2011-01-19 02:07:15
+     by : <!--MODIFICATION-AUTEUR--> Pascal J. Bourguignon
+    </SMALL>
+<BR><SMALL>
+      <a href="http://validator.w3.org/check?uri=referer"><img
+          src="http://www.w3.org/Icons/valid-html401"
+          alt="Valid HTML 4.01!" height="31" width="88"></a>
+   </SMALL>
+</DIV>
+<!--BOTTOM-END-->
+</BODY>
+</HTML>
+
diff --git a/small-cl-pgms/aim-8/aim-8.lisp b/small-cl-pgms/aim-8/aim-8.lisp
new file mode 100644
index 0000000..5c60c23
--- /dev/null
+++ b/small-cl-pgms/aim-8/aim-8.lisp
@@ -0,0 +1,207 @@
+;;;;****************************************************************************
+;;;;FILE:               aim-8.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    Implements the LISP described in AIM-8 in Common-Lisp.
+;;;;    Usage:  (load "aim-8.lisp")
+;;;;            (aim-8:repl)
+;;;;    Then at the aim-8 prompt, you have LISP, plus:
+;;;;       (DEFINE name sexp)     corresponding to =
+;;;;       (RELOAD)               to reload aim-8 if you edit it.
+;;;;       (DUMP-ENVIRONMENT)     to dump the defined symbols.
+;;;;       (LOAD "path")          to load an aim-8 source. Try "aim-8.aim-8".
+;;;;
+;;;;     AIM-8 -- 4 MARCH 1959 -- J. MCCARTHY
+;;;;     With an addendum dated 23 MARCH 1959
+;;;;     ftp://publications.ai.mit.edu/ai-publications/pdf/AIM-008.pdf
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2004-10-24 <PJB> Created.
+;;;;BUGS
+;;;;LEGAL
+;;;;    GPL
+;;;;
+;;;;    Copyright Pascal Bourguignon 2004 - 2004
+;;;;
+;;;;    This program is free software; you can redistribute it and/or
+;;;;    modify it under the terms of the GNU General Public License
+;;;;    as published by the Free Software Foundation; either version
+;;;;    2 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 General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU General Public
+;;;;    License along with this program; if not, write to the Free
+;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;;    Boston, MA 02111-1307 USA
+;;;;****************************************************************************
+
+(DEFPACKAGE "AIM-8"
+  (:USE "COMMON-LISP")
+  (:EXPORT "REPL")
+  (:DOCUMENTATION
+   "Implements the lisp of AIM-8 -- 4 MARCH 1959 -- J. MCCARTHY
+With an addendum dated 23 MARCH 1959
+ftp://publications.ai.mit.edu/ai-publications/pdf/AIM-008.pdf"))
+(IN-PACKAGE "AIM-8")
+
+
+(DEFPARAMETER *ENVIRONMENT* (MAKE-HASH-TABLE :TEST (FUNCTION EQ)))
+(DEFMACRO DEF     (NAME)       `(GETHASH ,NAME *ENVIRONMENT*))
+(DEFUN   %BOUNDP  (NAME) (MULTIPLE-VALUE-BIND (VAL BND) (DEF NAME)
+                          (DECLARE (IGNORE VAL)) BND))
+(DEFMACRO DEFINE  (NAME VALUE) `(SETF (GETHASH ',NAME *ENVIRONMENT*) ',VALUE))
+(DEFUN   FDEFINE  (NAME VALUE)  (SETF (GETHASH NAME *ENVIRONMENT*) VALUE))
+
+(DEFINE NIL ())
+(DEFINE F   ())
+(DEFINE T   T)
+(DEFINE AND     (LAMBDA (A B) (COND (A (COND (B T) (T NIL))) (T NIL))))
+(DEFINE OR      (LAMBDA (A B) (COND (A T) (B T) (T NIL))))
+(DEFINE NOT     (LAMBDA (A)   (COND (A NIL) (T T))))
+(DEFINE MAPLIST
+        (LAMBDA (X F)
+          (COND ((NULL X) NIL)
+                (T (COMBINE (F X) (MAPLIST (REST X) F))))))
+(DEFINE SUBST
+        (LAMBDA (X Y A)
+          (COND ((NULL A) NIL)
+                ((ATOM A) (COND ((EQ Y A) X) (T A)))
+                (T (COMBINE (SUBST X Y (FIRST A))
+                            (SUBST X Y (REST A))))
+                )))
+
+
+(DEFUN %SUBST (X Y A)
+  (COND ((NULL A) NIL)
+        ((ATOM A) (COND ((EQ Y A) X) (T A)))
+        (T (CONS (%SUBST X Y (FIRST A)) (%SUBST X Y (REST A))))))
+
+
+(DEFUN %SUBSQ (X Y Z)
+  (COND ((NULL Z) NIL)
+        ((ATOM Z) (COND ((EQ Y Z) X)  (T Z)))
+        ((EQ (FIRST Z) 'QUOTE) Z)
+        (T (CONS (%SUBSQ X Y (FIRST Z)) (%SUBSQ X Y (REST Z))))))
+
+
+(DEFUN %EVCON (C)
+  (COND ((%EVAL (FIRST (FIRST C))) (%EVAL (FIRST (REST (FIRST C)))))
+        (T (%EVCON (REST C)))))
+
+
+(DEFUN %EVLAM (VARS EXP ARGS)
+  (COND ((NULL VARS) (%EVAL EXP))
+        (T (%EVLAM (REST VARS) (%SUBSQ (FIRST ARGS) (FIRST VARS) EXP)
+                   (REST ARGS)))))
+
+
+(DEFUN %APPLY (F ARGS) (%EVAL (CONS F ARGS)))
+
+
+(DEFUN %EVAL (E)
+  (COND
+    ;; begin extensions:
+    ((ATOM E) (COND ((%BOUNDP E) (DEF E))
+                    (T (ERROR "Undefined: ~A" (FIRST E)))))
+    ;; end extensions.
+    (T (CASE (FIRST E)
+         ((NULL)    (NULL  (%EVAL (FIRST (REST E)))))
+         ((ATOM)    (ATOM  (%EVAL (FIRST (REST E)))))
+         ((QUOTE)                 (FIRST (REST E)))
+         ((EQ)      (EQ    (%EVAL (FIRST (REST E)))
+                           (%EVAL (FIRST (REST (REST E))))))
+         ((COMBINE) (CONS  (%EVAL (FIRST (REST E)))
+                           (%EVAL (FIRST (REST (REST E))))))
+         ((FIRST)   (FIRST (%EVAL (FIRST (REST E)))))
+         ((REST)    (REST  (%EVAL (FIRST (REST E)))))
+         ((COND)    (%EVCON (REST E)))
+         ;; begin extensions:
+         ((LOAD)    (LOAD  (%EVAL (FIRST (REST E)))))
+         ((PRINT)   (PRINT (%EVAL (FIRST (REST E)))))
+         ((READ)    (read))
+         (OTHERWISE
+          (COND
+            ((ATOM (FIRST E))
+             (COND ((%BOUNDP (FIRST E)) (%APPLY (DEF (FIRST E)) (REST E)))
+                   (T (ERROR "Undefined: ~A" (FIRST E)))))
+            ;; end extensions.
+            (T (CASE (FIRST (FIRST E))
+                 ((LAMBDA) (%EVLAM (FIRST (REST (FIRST E)))
+                              (FIRST (REST (REST (FIRST E))))
+                              (REST E)))
+                 ((LABEL) (%EVAL (CONS (%SUBST (FIRST E)
+                                               (FIRST (REST (FIRST E)))
+                                               (FIRST (REST (REST (FIRST E)))))
+                                       (REST E))))
+                 (OTHERWISE (ERROR "Invalid: ~A" (FIRST E)))))))))))
+
+
+
+(DEFUN HELP ()
+  (FORMAT T "~&You've got:
+    LAMBDA LABEL
+    COND AND OR NOT  COMBINE FIRST REST
+    NULL ATOM EQ NIL T QUOTE
+Extensions:
+    DEFINE RELOAD DUMP-ENVIRONMENT LOAD
+    QUIT"))
+
+
+(defmacro handling-errors (&body body)
+  `(HANDLER-CASE (progn ,@body)
+     (simple-condition
+      (ERR)
+      (format *error-output* "~&~A: ~%" (class-name (class-of err)))
+      (apply (function format) *error-output*
+             (simple-condition-format-control   err)
+             (simple-condition-format-arguments err))
+      (format *error-output* "~&"))
+     (condition
+      (ERR)
+      (format *error-output* "~&~A: ~%  ~S~%" (class-name (class-of err)) err))))
+
+
+(DEFUN REPL ()
+  (LET ((*PACKAGE* (FIND-PACKAGE "AIM-8")))
+    (HELP)
+    (LOOP
+       (TERPRI)
+       (PRINC "AIM-8> ")
+       (HANDLING-ERRORS
+        (LET ((SEXP (READ)))
+          (COND
+            ((EQUAL SEXP '(QUIT))
+             (FORMAT T "GOOD BYE") (RETURN-FROM REPL))
+            ((EQUAL SEXP '(RELOAD))
+             (LOAD "aim-8") (REPL) (RETURN-FROM REPL))
+            ((EQUAL SEXP '(DUMP-ENVIRONMENT))
+             (FORMAT T "~:{~16@A = ~A~%~}"
+                     (LET ((RES '()))
+                       (MAPHASH (LAMBDA (K V) (PUSH (LIST K V) RES))
+                                *ENVIRONMENT*) RES)))
+            ((AND (LISTP SEXP) (EQ (FIRST SEXP) 'DEFINE))
+             (FDEFINE (SECOND SEXP) (THIRD SEXP))
+             (FORMAT T "~A" (SECOND SEXP)))
+            (T
+             (FORMAT T "~S" (%EVAL SEXP))))))))
+  (TERPRI)
+  (VALUES))
+
+
+(DEFPACKAGE "AIM-8-USER"
+  (:USE)
+  (:IMPORT-FROM "AIM-8"
+                "DEFINE" "LAMBDA" "LABEL"
+                "COND"  "COMBINE" "FIRST" "REST"
+                "NULL" "ATOM" "EQ" "NIL" "T" "QUOTE"))
+
+;;;; aim-8.lisp                       --                     --          ;;;;
diff --git a/small-cl-pgms/aim-8/aim-8.txt b/small-cl-pgms/aim-8/aim-8.txt
new file mode 100644
index 0000000..7a0cc4c
--- /dev/null
+++ b/small-cl-pgms/aim-8/aim-8.txt
@@ -0,0 +1,703 @@
+-*- mode:text; coding:utf-8 -*-
+
+                                    March 23, 1959
+
+Artificial intelligence Project---RLE and MIT Computation Center
+
+                         Memo 8
+
+RECURSIVE FUNCTIONS OF SYMBOLIC EXPRESSIONS AND THEIR COMPUTATION
+
+                       BY MACHINE
+
+                     by J. McCarthy
+
+                   An Error in Memo 8
+
+
+     The definition of eval given on page 15 has two errors,
+one of which is typographical and the other conceptual.  The
+typographical error is in the definition of evcon where
+"1⟶" and "T⟶" should be interchanged.
+     The second error is in evlam.  The program as it stands
+will not work if a quoted expressoin contains a symbol which
+also acts as a variable bound by the lambda.  This can be
+corrected by using insteaad of subst in evlam a function subsq
+defined by
+     subsq=λ[[x;y;z];[null[z]⟶⋀;atom[z]⟶
+[y=z⟶x;l⟶z];first[z]=QUOTE⟶z;l⟶
+ combine[subsq[x;y;first[z]];subsq[x;y;rest[x]]]]]
+
+
+                                    March 4, 1959
+
+Artificial intelligence Project---RLE and MIT Computation Center
+
+                         Memo 8
+
+RECURSIVE FUNCTIONS OF SYMBOLIC EXPRESSIONS AND THEIR COMPUTATION
+
+                       BY MACHINE
+
+                     by J. McCarthy
+
+     The attached paper is a description of the LISP system
+starting with the machine-independent system of recursive
+functions of symbolic expressions.  This seems to be a better
+point of view for looking at the system than the original
+programming approach.  After revision, the paper will be sub-
+mitted for publication in a logic or computing journal.
+     This memorandum contains only the machine independent
+parts of the system.  The representation of S-expressions in
+the computer and the system for representing S-functions by
+computer subroutines will be added.
+
+
+                          -1-
+
+RECURSIVE FUNCTIONS OF SYMBOLIC EXPRESSIONS AND THEIR
+              COMPUTATION BY MACHINE
+       by J. McCarthy, MIT Computation Center
+
+1.    Introduction
+      A programming system called LISP (for LISt Processor)
+has been developed for the IBM 704 computer by the Artificial
+Intelligence Group at MIT.  The system was designed to facili-
+tate experiments with a proposed system called the Advice Taker
+whereby a machine could be instructed in declarative as well
+as imperative sentences and could exhibit "common sense" in
+carrying out its instructions.  The original proposal for the
+Advice Taker is contained in reference 1.  The main require-
+ment was a programming system for manipulating    expressions
+representing formalized declarative and imperative sentences
+so that the ADvice Taker system could make deductions.
+     The development of the LISP system went through several
+stages of simplification in the course of its development and
+was eventually seen to be based on a scheme for representing
+the partial recursive functions of a certain class of symbolic
+expressions.  This representation is independent of the IBM 704
+or any other electronic computer and it now seems expedient
+to expound the system starting with the class of expressions
+called S-expressions and the functions called S-functions.
+     In this paper, we first describe the class of S-expressions
+and S-functions.  Then we describe the representation of
+S-functions by S-expressions which enables us to prove that
+all computable partial functions have been obtained, to obtain
+a universal S-function, and to exhibit a set of questions
+about S-expressions which cannot be decided by an S-function.
+We describe the representation of the system in the IBM 704,
+including the representation of S-expressions by list structures
+similar to those used by Newell, Simon, and Shaw (see refer-
+ence 2), and the representation of S-functions by subroutines.
+Finally, we give some applications to symbolic calculations
+including analytic differentiation, proof checking, and
+compiling including a description of the present status of
+the LISP compiler itself which is being written in the system.
+     Although we have not carried out the development of
+
+                          -2-
+
+recursive function theory in terms of S-functions and their
+representation by S-expressions beyond the simplest theorems,
+it seems that formulation of this theory in terms of S-func-
+tions has important advantages.  Devices such as Gödel number-
+ing are unnecessary and so is the construction of particular
+Turing machines.  (These constructions are all artificial in
+terms of what is intended to be accomplished by them).  The
+advantage stems from the fact that functions of symbolic
+expressoins are easily and briefly described as S-expressions
+and the representation of S-functions by S-expressions is
+trivial.  Moreover, in a large class of cases the S-expression
+representations of S-functions translate directly into effi-
+cient machine programs for the computation of the functions.
+Although, the functions described in the manner of this paper
+include all computable functions of S-expressions, describe
+many important processes in a very convenient way, and compile
+into fast running programs for carrying out the processes;
+there are other kinds of processes whose description by S-func-
+tions is inconvenient and for which the S-functions once found
+do not naturally compile into efficient programs.  For this
+reason, the LISP system includes the possibility of combining
+S-functions into Fortran or IAL-like programs.  Even this
+will not provide the flexibility of description of processes
+hoped for from the Advice Taker system which is beyond the
+scope of this paper.
+
+2.   Recursive Functions of Symbolic Expressions
+     In this section we define the S-expressions and the
+S-functions.  (Actually they are partial functions.  The
+distinction between a partial function and a function that
+the former need not be defined for all arguments because, for
+example, the computation process defining it may not terminate.)
+
+     2.1. S-expressions
+     The expression with which we shall deal are formed
+using the special characters "," and "("  and  ")" and an
+infinite set of distinguishable atomic symbols p₁,p₂,p₃,....
+
+                          -3-
+
+     The S-expressions are formed according to the following
+recursive rules.
+          1.   The atomic symbols p₁ p₂ etc are S-expressions.
+          2.   A null expression ⋀ is also admitted.
+          3.   If e is an S-expression so is  (e).
+          4.   If e₁ and (e₂) are S-expressions so is (e₁,e₂).
+     In what follows we shall use sequences of capital Latin
+letters as atomic symbols.  Since we never juxatpose them with-
+out intervening commas they cannot cause confusion by running
+together.  Some examples of S-expressions are;
+          AB
+          (AB,A)
+          (AB,A,,C,)
+          ((AB,C),A,(BC,(B,B)))
+     2.2  Elementary functions and predicates
+     The functions we shall need are built up from certain
+elementary ones according to certain recursive rules.
+     There are three elementary predicates:
+     1.   null[e]
+          null[e] is true if and only if S-expression e is the
+null expression ⋀.  (We shall use square brackets and semi-colons
+for writing functions of S-expressions since parentheses and
+commas have been pre-empted.  When writing about functions in
+general we may continue to use parentheses and commas.)
+     2.   atom[e]
+          atom[e] is true if and only if the S-expression is
+an atomic symbol.
+     3.   p₁=p₂
+          p₁=p₂ is defined only when p₁ and p₂ are both atomic
+symbols in which case it is true if and only if they are the
+same symbol.  This predicate expresses the distinguishability
+of the symbols.
+     There are three basic functions of S-expressions whose
+values are S-expressions.
+     4.   first[e]
+          first[e] is defined for S-expressions which are
+neither null nor atomic.  If e has the form (e₁,e₂) where e₁
+is an expression, then first[e]=e₁.  If e has the form (e₁)
+wehre e₁ is an S-expression again we have first[e]=e₁.
+
+                          -4-
+
+          Some examples are:
+          first[(A,B)]=A
+          first[A] is undefined
+          first[(A)]=A
+          first[((A,B),C,D)]=(A,B)
+     5.   rest[e]
+          rest[e] is also defined for S-expressions which are
+neither null nor atomic.  If e has the form (e₁,e₂) where e₁
+is an S-expression, then rest[e]=(e₂).  If e has the form (e₁)
+wehre e₁ is an S-expression we have rest[e]=⋀.
+          Some examples are:
+          rest[(A,B)]=(B)
+          rest[(A)]=⋀
+          rest[(A,B,C)]=(B,C)
+     6.   combine[e₁;e₂]
+          combine[e₁;e₂] is defined when e₂ is not atomic.
+                When e₂  has the form (e₃), then combine[e₁;e₂]=(e₁,e₃)
+     When e₂ is ⋀ we have combine[e₁;e₂]=(e₁).
+          Some examples are:
+          combine[A;⋀]=(A)
+          combine[(A,B);(B,C)]=((A,B),B,C)
+     The functions first, rest and combine are related by the
+relations
+          first[combine[e₁;e₂]]=e₁
+          rest[combine[e₁;e₂]]=e₂
+          combine[first[e];rest[e]]=e
+whenever all the quantities involved are defined.
+
+     2.3  Functional Expressions and Functions formed from the
+     elementary functions by composition.
+          Additional functions may be obtained by composing the
+elementary functions of the preceding section.  These functions
+are decribed by expressions in the meta-language which should
+not be confused with the S-expressions being manipulated.  For
+example, the expression first[rest[e]] debute the second sub-
+expression of the S-expression e, e.g. first[rest[(A,B,C)]]=B.
+In general compositions of first and rest give sub-expressions of
+an S-expression in a given position within the expression and
+
+                          -5-
+
+compositions of combine form S-expressions from their sub-
+expressions.  For example, combine[x;combine[y;combine[z,⋀]]]
+forms as sequence of three ters from the terms, e.g. combine
+[A;combine[(B,C);combine[A,⋀]]]=(A,(B,C),A).
+     In order to be able to name compositions of functions and
+not merely functional expressions (forms) we use the Church
+λ-notation.  If ℰ is a functional expression and x₁,...,xn are
+variables which may occur in ℰ, then λ[[x₁,...,xn],] denotes
+the function of n variables that maps x₁,...,xn into ℰ.  For
+example, λ[[x],first[rest[x]]] is the function which selects the
+second element of a list and we have λ[[x],first[rest[x]]][(A,
+[B,C],A)]=[B,C].  λ[[x];[A,B]] is the constant function that
+maps every S-expression into [A,B].
+     The variables occuring in the list of a λ-expression are
+bound and replacing such a variable throughout a λ-expression
+by a new variable does not change the function represented.
+Thus λ[[x,y], combine[x,combine[y,⋀]]] is the same function as
+λ[[u,v], combine[u,combine[v,⋀]]] but different from λ[[y,x],
+combine[x,combine[y,⋀]]].
+     If some of the variables in a functional expressoin or
+form are bound by λ's and others are not, we get a function
+dependent on parameters or from another point of view a form
+whose value is a function when values have been assigned to
+the variables.
+     2.4  Conditional Expressions
+     Let p₁,p₂,...,pk be expressions representing propositions
+and let e₁,...,ek be arbitrary expressions.   The expression
+[p₁⟶e₁,...pk⟶ek] is called a conditional expression and its
+value is determined from the values assigned to the variables
+occuring in it as follows:  If the value of p₁ is not defined
+neither is that of the conditional expression.  If p₁ is defined
+and true the value of the conditional expression is that of e₁
+if the latter is defined and otherwise is undefined.  If p₁ is
+defined and false, then the value of [p₁⟶e₁,...,pk⟶ek] is that
+of [p₂⟶e₂,...pk⟶ek].  Finally if pk is false the value of
+[pk⟶ek] is undefined.
+     An example of a conditional expression is [null[x]⟶⋀;
+atom[x]⟶⋀;1⟶first[x]].  The "1" occuring in the above
+expression is the propositional constant "truth".  We also use
+
+                          -6-
+
+"0" for the propositional constant "falsehood".  When used as then
+last proposition in a conditional expression "1" may be read
+"in all remaining cases".  The expression given is a sort of
+extension of the expressoin first[x] which is defined for all
+S-expressions.  We could define a corresponding function by
+first_a=λ[[x]; [null[x]⟶⋀;atom[x]⟶⋀;1⟶first[x]]].
+     It is very important to note that for a conditional
+expressoin to be defined it is not necessary for all of its
+sub-expressions to be defined.  If p₁ is defined and true and
+e₁ is defined, the conditional expression [p₁⟶e₁,...,pk⟶ek]
+is defined even if none of the other p's or e's is defined.
+If p₁ is defined and false, p₂ is defined and true and e₂ is
+defined, the expression is defined even if e₁ and all the other
+p's and e's are undefined.
+     The propositional connectives ∧ and ∨ and ∼ may be defined
+in terms of conditional expressions.  We have p₁∧p₂=[p₁⟶[p₂
+⟶1,1⟶0],1⟶0] and p₁∨p₂=[p₁⟶1,p₂⟶1,1⟶0] and ∼p=[p⟶0,1⟶1]
+There is a slight difference between the connecetives defined
+this way and the ordinary connectives.  Suppose that p₁ is
+defined and true but p₂ is undefined.  Then p₁∨p₂ is defined
+and true but p₂∨p₁ is undefined.
+     2.5  Recursive Function Definitions
+     The functions which can be obtained from the elementary
+functions and predicates by composition and conditional expres-
+sions form a limited class. As we have decribed them they are
+not defined for all S-expressions but if we modified the
+definitions of the elementary functions so that the undefined
+cases are defined in some trivial way, as in the example of the
+pervious section, the would be always defined.
+     Additional functions may be defined by writing definitions
+of the form,
+     f=λ[[x₁,...,xn],ℰ] where the expression ℰ may contain the
+symbol f itself.  A function f defined in this way is to be
+computed for a given argument is to be computed by substitution
+of the argument into the expression and attempting to evaluate
+the resulting expression.  When a conditional expression is
+encountered we evaluate p's until we find a true p and then
+evaluate the corresponding e.  No attempt is made
+
+                          -7-
+
+to evaluate later p's or any e except the one corresponding
+to the first e.  It may happen that in evaluating for given
+values of the variables it is unnecessary to evaluate any
+expression involving the defined function f.  In this case,
+the evaluation may be completed and the function defined for
+this argument.  If expressions involving f do have to be
+evaluated we substitute the arguments of f and again proceed
+to evaluate.  The process may or may not terminate.  For
+those arguments for which the process does terminate the
+function is defined.
+     We shall illustrate this concept by several examples:
+     1.  Our first example is a function which gives the
+first symbol of an expression:
+We defined
+     ff=λ[[x];[null[x]∨atom[x]⟶x;1⟶ff[first[x]]]]
+Let us trace the computation of ff[(((A),B),C)].  We have
+ff[(((A),B),C)]=[null[(((A),B),C)]∨atom[(((A),B),C)]⟶x;
+     1⟶ff[first[(((A),B),C)]]]]
+          =ff[((A),B)]
+          =[null[((A),B)]∨atom[((A),B)]⟶((A),B);1⟶ff[first[((A),B)]]]
+          =ff[(A)]
+          =[null[(A)]∨atom[(A)]⟶(A);1⟶ff[first[(A)]]]
+          =ff[A]
+          =[null[A]∨atom[A]⟶A;1⟶ff[first[A]]]
+          =A
+*    Note that it does not matter that first A occuring in the
+next to last step is undefined.
+     2.   The second example is a function which gives the result
+of substituting the expression x for the symbol y in the expres-
+sion s.  We define
+     subst=λ[[x;y;s];[null[s]⟶⋀;atom[s]⟶[y=s⟶x;1⟶s];1⟶
+          combine[subst[x;y;first[s]];subst[x;y;rest[s]]]]]
+     We shall illustrate teh application of this definition by
+computing subst[(A,B);X;((X,A),C)].  In order to make the tracing
+shorter we shall give the situation at each recursion and leave
+it to the reader to substitute the definition of each subst
+expression and to check the determination of which case of the
+
+                          -8-
+
+conditional is applicable.  We have
+     subst[(A,B);X;((X,A),C)]=
+     =combine[subst[(A,B);X;(X,A)];subst[(A,B);X;(C)]]
+     =combine[combine[subst[(A,B);X;X];subst[(A,B);X;(A)]];combine[
+          subst[(A,B);X;C];subst[(A,B);X;⋀]]]
+     =combine[combine[(A,B);combine[subst[(A,B);X;A];subst[(A,B)
+          ;X;⋀]]];combine[C;⋀]]
+     =combine[combine[(A,B);combine[A;⋀]];(C)]
+     =(((A,B),A),C)
+     2.6  Functions with Functions as arguments
+     If we allow variables representing functions to occur in
+expressions and create functions by incorporating these variables
+as arguments of λ's we can define certain functions more concisely
+than without this facility.  However, as we shall show later no
+additional S-function become definable.
+     As an example of this facility we define a function maplist [x,f]
+     where x is an S-expression and f is a function from S-expres-
+sions to S-expressions.  We have
+maplist=λ[[x,f];[null[x]⟶⋀;1⟶combine[f[x];maplist[rest[x];f]]]]
+     The usefulness of maplist is illustrated byb formulas for
+the partial derivative with respect to x of expressions involving
+sums and products of x and other variables.  The S-expressions
+we shall differentiate are formed as follow:
+1.   An atomic symbol is an allowed expression.
+2.   If e₁;e₂;...;en are allowed expressions so are (PLUS,e₁,
+...,en) and (TIMES,e₁,...,en) and represent the sum and product
+respectively of e₁;...;en
+     This is essentially the Polish notation for functions except
+that the inclusion of parentheses and commas allows functions of
+variable numbers of arguments.  An example of an allowed
+expression is
+     (TIMES,X,(PLUS,X,A),Y)
+the conventional algebraic notation for which is X(X+A)Y
+     Our differentiation formula is
+     diff=λ[[y;x];[atom[y]⟶[y=x]⟶ONE;1⟶ZERO];
+first[y]=PLUS⟶combine[PLUS;maplist[rest[y];λ[[z];diff[
+first[z];x]]]];first[y]=TIMES⟶combine[PLUS;maplist[
+rest[y];λ[[z];combine[TIMES;maplist[rest[y];λ[[w];[z≠w
+⟶first[w];1⟶diff[first[w];x]]]]]]]]]
+
+                          -9-
+
+     The derivative of the above expression computed by this
+formula is
+(PLUS,(TIMES,ONE,(PLUS,ONE,ZERO),Y),(TIMES,X,(PLUS,ONE,ZERO),Y),
+     (TIMES,X,(PLUS,X,ZERO),ZERO))
+     2.7  Labelled Expressions
+     The λ-notation used for naming functions is inadequate
+for naming recursive functions.  For example, if the function
+named as the second argument of a maplist is to be allowed to
+be recursive an additional notation is required.
+     We define label[s;e] where  s  is a symbol and  e  is an
+expression to be the same as the exression  e  except that
+if  s  occurs as a sub-expression of  e  it is understood to
+refer to the exression  e.  The symbol  s  is bound in label
+[s;e]  and has no significance outside this expression.  Label
+acts as a quantifier with respect to its first argument but a
+quantifier of a different sort from λ.  As an example
+     label[subst;λ[[x;y;s];[null[s]⟶⋀;atom[s]⟶
+          [y=s⟶x;1⟶s];1⟶combine[subst[x;y;first[s]];
+               subst[x;y;rest[s]]]]]]
+is a name suitable for inclusion in a maplist of the substitu-
+tion function mentioned earlier.
+     2.8  Computable Functions
+     In this section we shall show that all functions compu-
+table by Turing machine are expressable as S-functions.  If,
+as we contend, S-functions are a more suitable device for
+developing a theory of computability than Turing machines,
+the proof in this section is out of place and should be re-
+placed by a plausibility argument similar to what is called
+"Turing's thesis" to the effect that S-functions satisfy our
+intuitive notion of effectively computable functions.  The
+reader unfamiliar with Turing machines should skip this section.
+     Nevertheless, Turing machines are well entrenched at present
+so we shall content ourselves with showing that any function
+computable by turing machine is an S-function.  This is done
+as follows:
+     1.   We give a way of describing the instantaneous con-
+figurations of a Turing machine calculation by an S-expression.
+This S-expression must describe the turing machine, its
+
+                          -10-
+
+internal state, the tape, and the square on the tape being
+read.
+     2.   We give an S-function succ whose arguments is an
+instantaneous configuration and whose value is the immediately
+succeeding configuration if there is one and otherwise is 0.
+     3.   We construct from succ another S-function, turing,
+whose arguments are a Turing machine, with a canonical initial
+state and an initial tape in a standard position and whose
+value is defined exactly when the corresponding Turing machine
+calculation terminates and in that case is the final tape.
+     We shall consider Turing machines as given by sets of
+quintuples.  Each quintuple consists of a state,
+a symbol read, a symbol to be printed, a direction of motion
+and a new state.  The states are represented by a finite set
+of symbols, the symbols which may occur by another finite set
+of symbols (it doesn't matter whether these sets overlap) and
+the two directions by the symbols "L" and "R".  A quintuple is
+then represented by an S-expression (st,sy,nsy,dir,nst).
+The Turing machine is represented by an S-expression. (ist,
+blank,quin1,...quink) were ist represents the canonical
+initial state, blank is the symbol used for a blank square
+(squares beyond the region explicitly represented in the
+S-expression for a tape are assumed to be blank and are read
+that way when reached).  As an example, we give the representa-
+tion of a Turing machine which moves to the right on a tape
+and computes the parity of the number of 1's on the tape ignoring
+0's and stopping when it comes to a blank square:
+(0,B,(0,0,B,R,0),(0,1,B,R,1),(0,B,0,R,2),(1,0,B,R,1),(1,1,B,R,0),
+(1,B,1,R,2))
+The machine is assumed to stop if there is no quintuple with a
+given symbol state pair so that the above machine stops as soon
+as it enters state 2.
+     A Turing machine tape is represented by an S-expression as
+follows:  The symbols on the squares to the right of the scanned
+square are given in a list v, the symbols to the left of the
+scanned square in a list u and the scanned symbol as a quantity w.
+These care combined in a list (w,u,v).  This the tape ...bb1101⓪10b...
+is represented by the expression
+     (0,(1,0,1,b,b),(1,1,0,b))
+
+                          -11-
+
+     We adjoin the state to this triplet to make a quadruplet
+(s,w,u,v) which describes the instantaneous configuration of a
+machine.
+     The function succ[m;c] whose arguments are a Turing machine
+m  and  a configuration  c  has as value the immediately suc-
+ceeding configuration of  c  provided the state-symbol pair is
+listed among the quintuplets of  m  and otherwise has value zero.
+     succ is defined with the aid of auxiliary functions.  The
+first of these  find[st;sy;qs] given the triplet (nsy;dir;nst)
+which consists of the last 3 terms of the quintuplet of  m  which
+contains  (st,sy)  as its first two elements.  The recursive
+definition is simplified by defining find [st;sy;qs] where
+qs=rest[rest[m]] since qs then represents the list of quintuplets
+of  m.  We have find[st;sy;qs]=[null[qs]⟶0;first[first[qs]]
+=st∧first[rest[first[qs]]]=sy⟶rest[rest[first[qs]]];1⟶find
+[st;sy;rest[qs]]]
+     The new auxiliary function is move[m;nsy;tape;dir] which
+gives a new tape triplet obtained by writing nsy  on the scanned
+square of tape, and moving in the direction dir.
+move[m;nsy;tape;dir]=[dir=L⟶combine[[
+null[first[rest[tape]]]⟶first[rest[m]];1⟶first[first[rest[tape]]]
+];combine[[null[first[rest[tape]]]⟶⋀;1⟶
+rest[first[rest[tape]]]];combine[combine[nsy;
+first[rest[rest[tape]]]];⋀]]];dir=R⟶
+combine[[null[first[rest[rest[tape]]]]⟶
+first[rest[m]];1⟶first[first[rest[rest[tape]]]]];
+combine[combine[nsy;first[rest[tape]]];
+combine[[null[first[rest[rest[tape]]]]⟶⋀;1⟶
+rest[first[rest[rest[tape]]]]];⋀]]]]
+     The reader should not be alarmed at the monstrous size of
+the last formula.  It rises mainly from the compositions of first
+and rest required to select the proper elements of the structure
+representing the tape. Later we shall descrirbe ways of writing
+such expressions more concisely.
+     We now have
+succ[m;c]=[find[first[c];first[rest[c]];rest[rest[m]]]
+=0⟶0;1⟶combine[first[rest[rest[find[
+  first[c];first[rest[c]];rest[rest[m]]]]]];
+move[m;first[find[first[c];first[rest[c]];
+rest[rest[m]]]];rest[c];first[rest[find[
+first[c];first[rest[c]];rest[rest[m]]]]]]]]
+
+                          -12-
+
+     Finally we define
+turing[m;tape]=tu[m;combine[first[m];tape]]
+where
+tu[m;c]=[succ[m;c]=0⟶rest[c];1⟶tu[m;succ[m;c]]]
+     We reiterate that these definitions can be greatly shortened
+by some devices that will be discussed in the sections on the
+machines  computation of S-functions.
+
+                          -13-
+
+3.   Lisp Self-applied
+     The S-functions have been described by a class of expres-
+sions which has been informally introduced.  Let us call these
+expressions F-expressions.  If we provide a way of translating
+F-expressions into S-expressions, we can use S-functions to
+represent certain functions and predicates of S-expressions.
+     First we shall describe this translation.
+     3.1  Representation of S-functions as S-expressions.
+     The representation is determined by the following rules.
+     1.  Constant S-expressions can occur as parts of the
+F-expressions representing S-functions.  An S-expression ℰ is
+represented by the S-expression.  (QUOTE,ℰ)
+     2.  Variables and function names which were represented
+by strings of lower case letters are represented by the cor-
+responding strings of the corresponding upper case letters.
+Thus we have FIRST, REST and COMBINE, and we shall use X,Y
+etc. for variables.
+     3.  A form is represented by an S-expression whose first
+term is the name of the main function and whose remaining terms
+are the argumetns of the function.  Thus combin[first[x];
+rest[x]] is represented by (COMBINE,(FIRST,X),(REST,X))
+     4.  The null S-expression ⋀ is named NIL.
+     5.  The truth values  1  and 0  are denoted by T and F.
+         The conditional expressoin
+     write[p₁⟶e₁,p₂⟶e₂,...pk⟶ek]
+is repersented by
+          (COND,(p₁,e₁),(p₂,e₂),...(pk,ek))
+     6.  λ[[x;..;s];ℰ] is represented by (LAMBDA,(X,...,S),ℰ)
+     7.  label[α;ℰ] is represented by (LABEL,α,ℰ)
+     8.  x=y is represented by (EQ,X,Y)
+     With these conventions the substitution function mentioned
+earlier whose F-expression is
+     label[subst;λ[[x;y;s];[null[s]⟶⋀;atom[s]⟶
+          [y=s⟶x;1⟶s];1⟶combine[subst[x;y;first[s]];
+               subst[x;y;rest[s]]]]]]
+is represented by the S-expression.
+          (LABEL,SUBST,(LAMBDA,(X,Y,Z),(COND,((NULL,
+               Z),NIL),((ATOM,Z),(COND)((EQ,Y,Z),X),(1,Z))),
+                    (1,(COMBINE,(SUBST,X,Y,(FIRST,Z)),
+                         (SUBST,X,Y,(REST,Z))))))
+
+                          -14-
+
+     This notation is rather formidable for a human to read,
+and when we come to the computer form of the system we will
+see how it can be made easier by adding some features to the
+read and print routines without changing the internal compu-
+tation processes.
+     3.2.  A Function of S-expressions which is not an S-function.
+     It was mentioned in section 2.5 that an S-function is not
+defined for values of its arguments for which the process of
+evaluation does not terminate.  It is easy to give examples
+of S-functions which are defined for all arguments, or examples
+which are defined for no arguments, or examples which are
+defined for some arguments.  It would be nicie to be able to
+determine whether a given S-function is defined for given
+arguments.  Consider, then, the function def[f;s] whose value
+is 1 if the S-function whose corresponding S-expression is  f
+is defined for the list of arguments  s  and is zero otherwise.
+     We assert that def[f,s] is not an S-function.  (If we
+assume Turing machine theory this is an obvious consequence
+of the results of section 2.8, but in support of the contentions
+that S-functions are a good vehicule for expounding the theory
+of recursive functions we give a separate proof).
+
+Theorem:  def[f;s] is not an S-function.
+Proof:    Suppose the contrary.  Consider the function
+g=λ[[f];[∼def[f;f]⟶1;1⟶first[⋀]]]
+     If def were an S-function g would also be an S-function.
+For any S-function  u  with S-expression  u' g[u'] is 1 if u[u']
+undefined and is undefined otherwise.
+Consider now g[g'] where g' is an S-expression for g.  Assume
+first that g[g'] were defined.  This is precisely the condi-
+tion that g' be the kind of S-expression for which  g  is
+undefined.  Contrawise, were g[g'] undefined  g'  would be the
+kind of S-expression for which  g  is defined.
+     Thus our assumption that def[f;s] is an S-function leads
+to a contradiction.
+     The proof is the same as the corresponding proof in
+Turing machine theory.  The simplicity of the rules by which
+S-functions are represented as S-expressions makes the develop-
+ment from scratch simplier, however.
+
+                          -15-
+
+     3.3  The Universal S-Function, Apply
+     There is an S-function apply such that if  f  is an
+S-expression for an S-function φ and args is a list of the
+form (arg1,...,arg n) where arg1,---,arg n are arbitrary
+S-expressions then apply[f,args] and φ[arg1;...;argn]
+are defined for the same values of arg1,...arg n and are
+equal when defined.
+     apply is defined by
+     apply[f;args]=eval[combine[f;args]]
+     eval is defined by
+eval[e]=[
+first[e]=NULL⟶[null[eval[first[rest[e]]]]⟶T;1⟶F]
+first[e]=ATOM⟶[atom[eval[first[rest[e]]]]⟶T;1⟶F]
+first[e]=EQ⟶eval[first[rest[e]]]=eval[first[rest[rest[e]]]]⟶T;
+     1⟶F]
+first[e]=QUOTE⟶first[rest[e]];
+first[e]=FIRST⟶first[eval[first[rest[e]]]];
+first[e]=REST⟶rest[eval[first[rest[e]]]];
+first[e]=COMBINE⟶combine[eval[first[rest[e]]];eval[first[rest[rest
+     [e]]]]];
+first[e]=COND⟶evcon[rest[e]];
+first[first[e]]=LAMBDA⟶evlam[first[rest[first[e]]];first[rest[rest
+    [first[e]]]];rest[e]];
+first[first[e]]=LABEL⟶eval[combine[subst[first[e];first[rest
+    [first[e]]];first[rest[rest[first[e]]]]];rest[e]]]]
+where: evcon[c]=[eval[first[first[c]]]=1⟶eval[first[rest[first[c]]]];
+           T⟶evcon[rest[c]]]
+and
+evlam[vars;exp;args]=[null[vars]⟶eval[exp];1⟶evlam[
+    rest[vars];subst[first[args];first[vars];exp];rest[args]]]
+    The proof of the above assertion is by induction on the
+subexpressions of  e.  The process described by the above
+functions is exactly the process used in the hand-worked
+examples of section 2.5.
+
+                          -16-
+
+4.   Variants of Lisp
+     There are a number of ways of defining functions of
+symbolic expressions which are quite similar to the system
+we have adopted.  Each of them involves three basic functions,
+conditional expressions and recursive function definitions,
+but the class of expressions corresponding to S-expressions
+differs and sod o the precise definitions of the functions.
+We shall describe two fo these variants.
+     4.1  Linear Lisp
+          The L-expressions are defined as follows:
+     1.   A finite list of characters is admited.
+     2.   Any string of admited characters in an L-expres-
+sion.  This includes the null string denoted by ⋀
+     There are three functions of strings
+     1.   first[x] is the first character of the string x.
+          first[⋀] is undefined.
+     For example, first [ABC]=A.
+     2.   rest[x] is the string of characters remaining when
+the first character of the string is deleted.
+          rest[⋀] is undefined.
+          For example, rest[ABC]=BC
+     3.   combine[x;y] is the string formed by prefixing the
+character  x  to the string  y.
+          For example, combine[A;BC]=ABC
+     There are three predicates on strings
+     1.   char[x],  x is a single character
+     2.   null[x],  x is the null string
+     3.   x=y,      defined for  x  and  y characters.
+     The advantage of linear Lisp is that no cahracters are
+given special roles as are parentheses and comma in Lisp.
+This permits computations with any notation which can be
+written linearly.  The disadvantage of linear Lisp is that
+the extraction of sub-expressions is a fairly involed rather
+than an elementary operation.  It is not hard to write in
+linear lisp functions corresponding to the basic functions of
+Lisp so that mathematically linear Lisp includes Lisp.  This
+turns otu to be the most convenient way of programming more
+complicated manipulations.  However, it tunrs out that if the
+functions are to be represented by computer routines Lisp is
+essentially faster.
+
+                          -17-
+
+     4.2  Binary Lisp
+     The unsymmetrical status of  first  and  rest  may be a
+source of uneasiness.  If we admit only two element lists
+then we can define
+     first[(e₁,e₂)]=e₁
+     rest[(e₁,e₂)]=e₂
+     combine[e₁;e₂]=(e₁,e₂)
+     We need only two predicates, equality for symbols and
+atom.  The null list can be dispensed with.  This system is
+easier until we try to represent functions by expressions which
+is, after all, the principal application; moreover, in order
+to apply the system to itself we need to be abel to write
+functions.
+
diff --git a/small-cl-pgms/aim-8/aim-8.txt.gz b/small-cl-pgms/aim-8/aim-8.txt.gz
new file mode 100644
index 0000000..1a59306
Binary files /dev/null and b/small-cl-pgms/aim-8/aim-8.txt.gz differ
diff --git a/small-cl-pgms/aim-8/diff.m b/small-cl-pgms/aim-8/diff.m
new file mode 100644
index 0000000..052ea95
--- /dev/null
+++ b/small-cl-pgms/aim-8/diff.m
@@ -0,0 +1,18 @@
+-*- mode:m-expression; coding:utf-8 -*-
+
+diff=λ[[y;x];
+       [atom[y]
+         ⎯⟶ [y=x ⎯⟶ ONE;
+               1 ⎯⟶ ZERO];
+        first[y]=PLUS
+         ⎯⟶ combine[PLUS;
+                    maplist[rest[y];λ[[z];diff[first[z];x]]]];
+        first[y]=TIMES
+         ⎯⟶ combine[PLUS;
+                    maplist[rest[y];
+                            λ[[z];
+                              combine[TIMES;
+                                      maplist[rest[y];
+                                              λ[[w];
+                                                [z≠w ⎯⟶ first[w];
+                                                   1 ⎯⟶ diff[first[w];x]]]]]]]]]
diff --git a/small-cl-pgms/aim-8/examples.aim-8 b/small-cl-pgms/aim-8/examples.aim-8
new file mode 100644
index 0000000..a469dd9
--- /dev/null
+++ b/small-cl-pgms/aim-8/examples.aim-8
@@ -0,0 +1,170 @@
+;;;; -*- mode:lisp -*-
+;;;;**************************************************************************
+;;;;FILE:               examples.aim-8
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    Transcription in AIM-8 LISP of the programs presented in AIM-8.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2006-08-23 <PJB> Transcribed from AIM-8.
+;;;;**************************************************************************
+
+
+
+;;; ----------------------------------------
+;;; The differential function:
+;;; ----------------------------------------
+
+(define maplist
+    (lambda (x f)
+      (cond ((null x) nil)
+            (t        (combine (f x) (maplist (rest x) f))))))
+
+
+(define diff
+    (lambda (y x)
+      (cond
+        ((atom y)
+         (cond ((eq y x) (quote one))
+               (t (quote zero))))
+        ((eq (first y) (quote plus))
+         (combine (quote plus) (maplist (rest y) (lambda (a) (diff (first a) x)))))
+        ((eq (first y) (quote times))
+         (combine (quote plus)
+                  (maplist
+                   (rest y)
+                   (lambda (a) (combine (quote times)
+                                   (maplist
+                                    (rest y)
+                                    (lambda (w) (cond ((not (eq a w)) (first w))
+                                                 (t (diff (first w) x))
+                                                 )))))))))))
+
+(diff (quote (plus (times a x) b)) (quote x))
+(diff (quote (plus (times a x x) (times b x) c)) (quote x))
+(diff (quote (plus (times 2 x) (times 2 x x))) (quote x))
+(diff (quote (plus (times 2 x x) (times 4 x u) (times 2 y y))) (quote x))
+
+
+
+;;; ----------------------------------------
+;;; The Turing machine:
+;;; ----------------------------------------
+
+(define find
+    (lambda (st sy qs)
+      (cond
+        ((null qs)                                 nil)
+        ((and (eq (first       (first qs))  st)
+              (eq (first (rest (first qs))) sy))   (rest (rest (first qs))))
+        (t                                         (find st sy (rest qs))))))
+
+(define move
+    (lambda (m nsy tape dir)
+      ;; tape = (current-symbol left right)
+      (cond
+        ((eq dir 'l)
+         (combine
+          (cond
+            ((null (first (rest tape)))               (first (rest m)))
+            (t                       (first (first (rest tape)))))
+          (combine
+           (cond ((null (first (rest tape)))          nil)
+                 (t                  (rest (first (rest tape)))) )
+           (combine
+            (combine nsy (first (rest (rest tape))))
+            nil))))
+        ((eq dir 'r)
+         (combine
+          (cond ((null(first (rest (rest tape))))     (first (rest m)))
+                (t                   (first (first (rest (rest tape))))))
+          (combine
+           (combine nsy (first(rest tape)))
+           (combine
+            (cond ((null (first (rest (rest tape))))  nil)
+                  (t                 (rest (first (rest (rest tape))))))
+            nil)))))))
+
+(define succ
+    (lambda (m c)
+      (cond
+        ((null (find (first c)
+                     (first (rest c))
+                     (rest (rest m))))  nil)
+        (t (combine
+            (first (rest (rest (find (first c)
+                                     (first (rest c))
+                                     (rest (rest m))))))
+            (move m
+                  (first (find (first c)
+                               (first (rest c))
+                               (rest (rest m))))
+                  (rest c)
+                  (first (rest (find (first c)
+                                     (first (rest c))
+                                     (rest (rest m)))))))))))
+
+(define turing (lambda (m tape) (tu m (combine (first m) tape))))
+(define tu
+    (lambda (m c)
+      (cond ((null (succ m c)) (rest c))
+            (t                 (tu m (succ m c))))))
+
+
+(define tape  (0 (1 1 1 1 b b) (1 1 0 b)))
+(define m  (0 b
+              (0 0 b r 0)
+              (0 1 b r 1)
+              (0 b 0 r 2)
+              (1 0 b r 1)
+              (1 1 b r 0)
+              (1 b 1 r 2)))
+(define c   (0                                 ; state
+             0 (1 1 1 1 b b) (1 1 0 b)))       ; tape
+
+;; (turing m c)                            ; slow
+
+
+;;; ----------------------------------------
+;;; Lisp Self-applied
+;;; ----------------------------------------
+
+(load (quote "aim-8.aim-8"))
+
+(repl
+        (quote
+         ( (define maplist
+               (lambda (x f)
+                 (cond ((null x) nil)
+                       (t        (combine (f x) (maplist (rest x) f))))))
+
+           (define diff
+               (lambda (y x)
+                 (cond
+                   ((atom y)
+                    (cond ((eq y x) (quote one))
+                          (t (quote zero))))
+                   ((eq (first y) (quote plus))
+                    (combine (quote plus)
+                             (maplist (rest y) (lambda (a) (diff (first a) x)))))
+                   ((eq (first y) (quote times))
+                    (combine (quote plus)
+                             (maplist
+                              (rest y)
+                              (lambda (a) (combine
+                                      (quote times)
+                                      (maplist
+                                       (rest y)
+                                       (lambda (w) (cond
+                                                ((not (eq a w)) (first w))
+                                                (t (diff (first w) x))
+                                                )))))))))))
+
+           (diff (quote (plus (times a x) b)) (quote x)) ; slow
+           )))
+
diff --git a/small-cl-pgms/aim-8/index.html b/small-cl-pgms/aim-8/index.html
new file mode 100644
index 0000000..e7fccd5
--- /dev/null
+++ b/small-cl-pgms/aim-8/index.html
@@ -0,0 +1,200 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">
+
+<HTML>
+ <HEAD>
+  <link rel="icon"          href="/favicon.ico" type="image/x-icon">
+  <link rel="shortcut icon" href="/favicon.ico" type="image/x-icon">
+  <link rel="stylesheet"    href="default.css"  type="text/css">
+
+  <TITLE>The Original LISP</TITLE>
+
+  <META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=iso-8859-1">
+  <META HTTP-EQUIV="Description"
+        NAME="description" CONTENT="AIM-8, The Original LISP">
+  <META NAME="author"      CONTENT="Pascal J. Bourguignon">
+  <META NAME="keywords"    CONTENT="LISP, Common Lisp, AIM-8, John McCarthy">
+ </HEAD>
+ <BODY>
+<!--TOP-BEGIN-->
+<!-- This section is automatically generated by html-update, -->
+<!-- from data in 'node.el'.    Please, do not edit it here. -->
+<DIV CLASS="TOP">
+
+</DIV>
+<!--TOP-END-->
+<!--MENU-BEGIN-->
+<!-- This section is automatically generated by html-update, -->
+<!-- from data in 'node.el'.    Please, do not edit it here. -->
+<DIV CLASS="MENU"><HR><P>|
+ <A HREF="../../../../toc.html">Contents</a> |
+ <A HREF="../../../../index.html">Home</a> |
+ <A HREF="../index.html">Previous</a> |
+ <A HREF="../../index.html">Up</a> |
+ <A HREF="aim-8.html">Down</a> |
+ <A HREF="aim-8.html">Next</a> |
+</P><HR></DIV>
+<!--MENU-END-->
+  <h1>The original LISP</h1>
+  <p>Here is an implementation of the Original LISP as documented in
+  <QUOTE><PRE>
+                                  March 4, 1959
+
+    Artificial Intelligence Project--RLE and MIT Computation Center
+
+                           Memo 8
+
+    RECURSIVE FUNCTIONS OF SYMBOLIC EXPRESSIONS AND THEIR COMPUTATION
+
+                         BY MACHINE
+
+                       by J. McCarthy
+   </PRE></QUOTE>
+<ul>
+<li><a href="aim-8.html">A transcription into machine readable form
+                        (HTML and text)</a></li>
+<li><a href="ftp://publications.ai.mit.edu/ai-publications/pdf/AIM-008.pdf">
+      AI Memo 8, AIM-008.pdf</a></li>
+<li><a href="http://www.ai.mit.edu/research/publications/browse/0000browse.shtml">
+      CSAIL Digital Archive - Artificial Intelligence Laboratory Series,
+      Publications 0 through 99</a></li>
+<li><a href="http://www-formal.stanford.edu/jmc/history/lisp/lisp.html">
+    History of Lisp</a> by John McCarthy</li>
+</ul></P>
+
+  <p>The only symbols predefined are: DEFINE, LAMBDA, LABEL, COND, COMBINE,
+FIRST, REST, NULL, ATOM, EQ, NIL, T, and QUOTE. </p>
+
+  <p>The file <A HREF="aim-8.lisp">aim-8.lisp</A>
+     contains an implementation in Common-Lisp.</p>
+  <p>The file <A HREF="aim-8.aim-8">aim-8.aim-8</A>
+     contains an implementation in AIM-8 LISP.</p>
+  <p>The file <A HREF="examples.aim-8">examples.aim-8</A>
+     contains the other examples given in AIM-8: differential
+     and turing machine.</p>
+
+  <p>(It should be  noted that "compiler" occurs 4  times in this Memo,
+      while "interpreter" doesn't appears.)</p>
+
+
+   <p>For more information about Lisp history, see the
+     <a href="http://community.computerhistory.org/scc/projects/LISP/">
+         Computer History Museum, History of Lisp</a></p>
+
+   <h2>Exemple</h2>
+
+<pre>
+% <b>/usr/local/bin/clisp -norc -ansi </b>
+  i i i i i i i       ooooo    o        ooooooo   ooooo   ooooo
+  I I I I I I I      8     8   8           8     8     o  8    8
+  I  \ `+' /  I      8         8           8     8        8    8
+   \  `-+-'  /       8         8           8      ooooo   8oooo
+    `-__|__-'        8         8           8           8  8
+        |            8     o   8           8     o     8  8
+  ------+------       ooooo    8oooooo  ooo8ooo   ooooo   8
+
+Copyright (c) Bruno Haible, Michael Stoll 1992, 1993
+Copyright (c) Bruno Haible, Marcus Daniels 1994-1997
+Copyright (c) Bruno Haible, Pierpaolo Bernardi, Sam Steingold 1998
+Copyright (c) Bruno Haible, Sam Steingold 1999-2000
+Copyright (c) Sam Steingold, Bruno Haible 2001-2006
+
+[1]&gt; <b>(load (compile-file "aim-8.lisp"))</b>
+;; Compiling file /local/users/pjb/src/public/small-cl-pgms/aim-8/aim-8.lisp ...
+;; Wrote file /local/users/pjb/src/public/small-cl-pgms/aim-8/aim-8.fas
+0 errors, 0 warnings
+;; Loading file /local/users/pjb/src/public/small-cl-pgms/aim-8/aim-8.fas ...
+;; Loaded file /local/users/pjb/src/public/small-cl-pgms/aim-8/aim-8.fas
+T
+[2]&gt; <b>(aim-8:repl)</b>
+You've got:
+    LAMBDA LABEL
+    COND AND OR NOT  COMBINE FIRST REST
+    NULL ATOM EQ NIL T QUOTE
+Extensions:
+    DEFINE RELOAD DUMP-ENVIRONMENT LOAD
+    QUIT
+AIM-8&gt; <b>(define maplist
+           (lambda (x f)
+             (cond ((null x) nil)
+                   (t        (combine (f x) (maplist (rest x) f))))))</b>
+MAPLIST
+AIM-8&gt; <b>(define diff
+           (lambda (y x)
+             (cond
+               ((atom y)
+                (cond ((eq y x) (quote one))
+                      (t (quote zero))))
+               ((eq (first y) (quote plus))
+                (combine (quote plus)
+                         (maplist (rest y) (lambda (a) (diff (first a) x)))))
+               ((eq (first y) (quote times))
+                (combine (quote plus)
+                         (maplist
+                          (rest y)
+                          (lambda (a) (combine
+                                  (quote times)
+                                  (maplist
+                                   (rest y)
+                                   (lambda (w) (cond
+                                            ((not (eq a w)) (first w))
+                                            (t (diff (first w) x))
+                                            )))))))))))</b>
+DIFF
+AIM-8&gt; <b>(diff (quote (plus (times a x) b)) (quote x))</b>
+(PLUS (PLUS (TIMES ZERO X) (TIMES A ONE)) ZERO)
+AIM-8&gt; <b>(diff (quote (plus (times a x x) (times b x) c)) (quote x))</b>
+(PLUS (PLUS (TIMES ZERO X X) (TIMES A ONE X) (TIMES A X ONE))
+ (PLUS (TIMES ZERO X) (TIMES B ONE)) ZERO)
+
+;; Beware, AIM-8 is defined with substitution evaluation.
+;; Therefore, for each occurence of a variable, the whole expression
+;; bound to this variable is evaluated again.  This gives surprizing
+;; results for procedures with side-effects like PRINT and READ.
+;; Moreover, this has the effect of giving exponential complexities very easily.
+
+AIM-8&gt; <b>((lambda (x) (combine x (combine x nil))) (print (quote a)))</b>
+
+A
+A (A A)
+AIM-8&gt; <b>(quit)</b>
+GOOD BYE
+NIL
+[3]&gt; <b>(quit)</b>
+Bye.
+%
+
+  </pre>
+
+<!--MENU-BEGIN-->
+<!-- This section is automatically generated by html-update, -->
+<!-- from data in 'node.el'.    Please, do not edit it here. -->
+<DIV CLASS="MENU"><HR><P>|
+ <A HREF="../../../../toc.html">Contents</a> |
+ <A HREF="../../../../index.html">Home</a> |
+ <A HREF="../index.html">Previous</a> |
+ <A HREF="../../index.html">Up</a> |
+ <A HREF="aim-8.html">Down</a> |
+ <A HREF="aim-8.html">Next</a> |
+</P><HR></DIV>
+<!--MENU-END-->
+<!--BOTTOM-BEGIN-->
+<!-- This section is automatically generated by html-update, -->
+<!-- from data in 'node.el'.    Please, do not edit it here. -->
+<DIV CLASS="BOTTOM">
+<hr><code><small>
+ | <a href="http://www.informatimago.com//develop/lisp/small-cl-pgms/aim-8/index.html">Mirror on informatimago.com</a>
+ | <a href="http://informatimago.free.fr/i//develop/lisp/small-cl-pgms/aim-8/index.html">Mirror on free.fr</a>
+ | </small></code>
+
+<BR><SMALL>Last update : <!--MODIFICATION-DATE--> 2011-01-19 02:07:14
+     by : <!--MODIFICATION-AUTEUR--> Pascal J. Bourguignon
+    </SMALL>
+<BR><SMALL>
+      <a href="http://validator.w3.org/check?uri=referer"><img
+          src="http://www.w3.org/Icons/valid-html401"
+          alt="Valid HTML 4.01!" height="31" width="88"></a>
+   </SMALL>
+</DIV>
+<!--BOTTOM-END-->
+ </BODY>
+</HTML>
diff --git a/small-cl-pgms/author-signature.lisp b/small-cl-pgms/author-signature.lisp
new file mode 100644
index 0000000..3df3acb
--- /dev/null
+++ b/small-cl-pgms/author-signature.lisp
@@ -0,0 +1,236 @@
+;;;; -*- mode:lisp; coding:utf-8 -*-
+;;;;****************************************************************************
+;;;;FILE:               author-signature.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     Common-Lisp
+;;;;DESCRIPTION
+;;;;
+;;;;    This program compute an "author signature" from a text.
+;;;;    See: http://unix.dsu.edu/~johnsone/comp.html
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal Bourguignon
+;;;;MODIFICATIONS
+;;;;    2003-03-13 <PJB> Creation.
+;;;;BUGS
+;;;;LEGAL
+;;;;    GPL
+;;;;
+;;;;    Copyright Pascal Bourguignon 2003 - 2003
+;;;;    mailto:pjb@informatimago.com
+;;;;
+;;;;    This program is free software; you can redistribute it and/or
+;;;;    modify it under the terms of the GNU General Public License
+;;;;    as published by the Free Software Foundation; either version
+;;;;    2 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 General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU General Public
+;;;;    License along with this program; if not, write to the Free
+;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;;    Boston, MA 02111-1307 USA
+;;;;****************************************************************************
+
+
+(DEFPACKAGE "COM.INFORMATIMAGO.COMMON-LISP.AUTHOR-SIGNATURE"
+  (:DOCUMENTATION
+   "This program compute an \"author signature\" from a text.
+    See: http://unix.dsu.edu/~johnsone/comp.html
+
+    Copyright Pascal Bourguignon 2003 - 2003
+    This package is provided under the GNU General Public License.
+    See the source file for details.")
+  (:USE "COMMON-LISP")
+  (:EXPORT COMPARE-TEXTS TALLY-COMPARE
+           TALLY-WORD-LENGTHS TALLY-SMALL-WORDS
+           TALLY-PERCENT  SPLIT-WORDS )
+  );;COM.INFORMATIMAGO.COMMON-LISP.AUTHOR-SIGNATURE
+(IN-PACKAGE "COM.INFORMATIMAGO.COMMON-LISP.AUTHOR-SIGNATURE")
+
+
+(DEFUN STREAM-AS-STRING (STREAM)
+  "
+RETURN:  A string containing all the character read from the stream.
+"
+  (LOOP WITH RESULT = ""
+        WITH EOLN = (FORMAT NIL "~%")
+        FOR LINE = (READ-LINE STREAM NIL NIL)
+        WHILE LINE
+        DO (SETQ RESULT (CONCATENATE 'STRING RESULT LINE EOLN))
+        FINALLY (RETURN RESULT))
+  );;STREAM-AS-STRING
+
+
+(DEFUN REMOVE-PONCTUATION (TEXT)
+  "
+RETURN: A copy of the text string where all character not alphanumeric is
+        replaced by a space.
+"
+  (SETQ TEXT (COPY-SEQ TEXT))
+  (LOOP FOR I FROM 0 BELOW (LENGTH TEXT)
+        FOR CH = (CHAR TEXT I)
+        DO (UNLESS (ALPHANUMERICP CH) (SETF (CHAR TEXT I) #\SPACE)))
+  TEXT
+  );;REMOVE-PONCTUATION
+
+
+(DEFUN SPLIT-WORDS (TEXT)
+  "
+RETURN: A list of words read from the text.
+"
+  (WITH-INPUT-FROM-STRING
+   (IN (REMOVE-PONCTUATION TEXT))
+   (LET ((RESULT  ())
+         (CH (READ-CHAR IN NIL NIL)))
+     (LOOP WHILE CH DO
+           (LOOP WHILE (AND CH (EQL #\SPACE CH)) ;;skip spaces
+                 DO (SETQ CH (READ-CHAR IN NIL NIL)))
+           (LOOP WHILE (AND CH (NOT (EQL #\SPACE CH)))
+                 COLLECT CH INTO WORD
+                 DO (SETQ CH (READ-CHAR IN NIL NIL))
+                 FINALLY (WHEN (< 0 (LENGTH WORD))
+                           (PUSH (MAKE-ARRAY (LIST (LENGTH WORD))
+                                             :ELEMENT-TYPE 'CHARACTER
+                                             :INITIAL-CONTENTS WORD) RESULT)))
+           )
+     (NREVERSE RESULT)))
+  ) ;;SPLIT-WORDS
+
+
+(DEFUN TALLY-WORD-LENGTHS (WORD-LIST)
+  "
+RETURN: An array containing the number of words of each length (in
+        slot 0 is stored the number of words greater than (length result),
+        and (length word-list).
+"
+  ;; max word length in French: 36.
+  (LET* ((MAX-LEN 36)
+         (TALLY (MAKE-ARRAY (LIST (1+ MAX-LEN))
+                            :ELEMENT-TYPE 'FIXNUM
+                            :INITIAL-ELEMENT 0))
+         )
+    (LOOP FOR WORD IN WORD-LIST
+          FOR LEN = (LENGTH WORD)
+          FOR COUNT = 0 THEN (1+ COUNT)
+          DO
+          (IF (< MAX-LEN LEN)
+            (INCF (AREF TALLY 0))
+            (INCF (AREF TALLY LEN)))
+          FINALLY (RETURN (VALUES TALLY COUNT))))
+  );;TALLY-WORD-LENGTHS
+
+
+(DEFUN TALLY-SMALL-WORDS (WORD-LIST)
+  "
+RETURN: An array containing the number of occurences of a list of
+        small words returned as third value.
+        The second value is (length word-list).
+"
+  (LET* ((SMALL-WORDS '("A" "BUT" "IN" "NO" "OUR" "THE" "US"
+                        "WE" "WHICH" "WITH"))
+         (MAX-LEN (LENGTH SMALL-WORDS))
+         (TALLY (MAKE-ARRAY (LIST (1+ MAX-LEN))
+                            :ELEMENT-TYPE 'FIXNUM
+                            :INITIAL-ELEMENT 0))
+         )
+    (LOOP FOR WORD IN WORD-LIST
+          FOR COUNT = 0 THEN (1+ COUNT)
+          FOR POS = (POSITION WORD SMALL-WORDS :TEST (FUNCTION STRING-EQUAL))
+          DO
+          (IF POS
+            (INCF (AREF TALLY (1+ POS)))
+            (INCF (AREF TALLY 0)))
+          FINALLY (RETURN (VALUES TALLY COUNT SMALL-WORDS))))
+  );;TALLY-SMALL-WORDS
+
+
+;; (TALLY-SMALL-WORDS (SPLIT-WORDS (WITH-OPEN-FILE (IN "~/tmp/misc/test.txt" :DIRECTION :INPUT) (STREAM-AS-STRING IN))))
+
+
+(DEFUN TALLY-PERCENT (TALLY COUNT)
+  (LET ((RESULT  (MAKE-ARRAY (LIST (LENGTH TALLY))
+                             :ELEMENT-TYPE 'FLOAT
+                             :INITIAL-ELEMENT 0.0)))
+    (DO ((I 0 (1+ I)))
+        ((<= (LENGTH TALLY) I) RESULT)
+      (SETF (AREF RESULT I) (COERCE (/ (AREF TALLY I) COUNT) 'FLOAT))))
+  );;TALLY-PERCENT
+
+
+(DEFUN MODULE (VECTOR)
+  "
+RETURN:  The module of the vector. [ sqrt(x^2+y^2+z^2) ]
+"
+  (SQRT (APPLY (FUNCTION +)
+               (MAP 'LIST (FUNCTION (LAMBDA (X) (* X X))) VECTOR)))
+  );;MODULE
+
+
+(DEFUN TALLY-COMPARE (TALLY-1 TALLY-2)
+  "
+RETURN:  The module and the vector of percentages of differences
+         between vectors tally-1 and tally-2.
+"
+  (ASSERT (= (LENGTH TALLY-1) (LENGTH TALLY-2)))
+  (LET ((DIFFERENCES (MAKE-ARRAY (LIST (LENGTH TALLY-1))
+                                 :ELEMENT-TYPE 'FLOAT
+                                 :INITIAL-ELEMENT 0.0)))
+    (DO* ((I 0 (1+ I))
+          (D) (M))
+        ((<= (LENGTH DIFFERENCES) I))
+      (SETQ D (ABS (- (AREF TALLY-1 I) (AREF TALLY-2 I)))
+            M (MAX (AREF TALLY-1 I) (AREF TALLY-2 I)))
+      (SETF (AREF DIFFERENCES I) (IF (= 0.0 M) M (COERCE (/ D M) 'FLOAT))) )
+    (VALUES (MODULE DIFFERENCES) DIFFERENCES))
+  );;TALLY-COMPARE
+
+
+(DEFUN COMPARE-TEXTS (PATH-LIST TALLY-FUNCTION)
+  (LET ((TALLIES ()))
+    (MAPC
+     (LAMBDA (PATH)
+       (WITH-OPEN-FILE (INPUT PATH  :DIRECTION :INPUT)
+         (PUSH (CONS (NAMESTRING PATH)
+                     (MULTIPLE-VALUE-BIND (TALLY C)
+                         (FUNCALL TALLY-FUNCTION
+                          (SPLIT-WORDS (STREAM-AS-STRING INPUT)))
+                       (TALLY-PERCENT TALLY C))) TALLIES)))
+     PATH-LIST)
+    (DO* ((T1 TALLIES (CDR T1))
+          (N-TALLY-1 (CAR T1) (CAR T1))
+          (TALLY-1 (CDR N-TALLY-1) (CDR N-TALLY-1)) )
+        ((NULL T1))
+
+      (DO* ((T2 (CDR T1) (CDR T2))
+            (N-TALLY-2 (CAR T2) (CAR T2))
+            (TALLY-2 (CDR N-TALLY-2) (CDR N-TALLY-2)) )
+          ((NULL T2))
+
+          (MULTIPLE-VALUE-BIND
+           (M D) (TALLY-COMPARE TALLY-1 TALLY-2)
+           (FORMAT T "~20A ~20A ~8A~%   ~A~%~%"
+                   (CAR N-TALLY-1) (CAR N-TALLY-2) M D))
+        ))
+    TALLIES)
+  );;COMPARE-TEXTS
+
+
+;; (COMPARE-TEXTS (DIRECTORY "i-*.txt") (FUNCTION TALLY-WORD-LENGTHS))
+;; (COMPARE-TEXTS (DIRECTORY "i-*.txt") (FUNCTION TALLY-SMALL-WORDS))
+
+;; (TALLY-COMPARE
+;;  (MULTIPLE-VALUE-BIND (TALLY C)
+;;      (TALLY-WORD-LENGTHS (SPLIT-WORDS STR))
+;;    (TALLY-PERCENT TALLY C))
+;;  (MULTIPLE-VALUE-BIND (TALLY C)
+;;      (TALLY-WORD-LENGTHS (SPLIT-WORDS STR2))
+;;    (TALLY-PERCENT TALLY C)))
+
+
+
+;;;; author-signature.lisp            -- 2004-03-14 01:32:40 -- pascal   ;;;;
diff --git a/small-cl-pgms/basic/basic.lisp b/small-cl-pgms/basic/basic.lisp
new file mode 100644
index 0000000..3d41296
--- /dev/null
+++ b/small-cl-pgms/basic/basic.lisp
@@ -0,0 +1,990 @@
+;;****************************************************************************
+;;FILE:               basic.lisp
+;;LANGUAGE:           Common-Lisp
+;;SYSTEM:             Common-Lisp
+;;USER-INTERFACE:     standard i/o
+;;DESCRIPTION
+;;
+;;    Quick, Dirty and Ugly BASIC.
+;;
+;;    This is a silly BASIC interpreter.  The lines are tokenized and stored
+;;    as-is in an array indexed by the line number.  When interpreting the
+;;    program, the instructions are parsed directly from there ; the
+;;    expressions are parsed into trees which are then evaluated.
+;;    The variables are stored into a hash table indexed by their
+;;    identifier (symbol). Undefined variables are taken as 0 or "".
+;;    We distinguish number and string variables depending on the presence
+;;    of a '$' character in the last position of the variable identifier.
+;;    Variables are reset by the command RUN. (A program can be restarted
+;;    without losing the variable using the GOTO or GOSUB statements).
+;;
+;;    Commands are not distinguished from statements and may occur in a
+;;    program. In particular, LOAD could be used to load a subprogram
+;;    overlay, and takes a line number where to jump to.
+;;
+;;    Programs are loaded and saved in source form.
+;;
+;;SYNOPSIS
+;;
+;;    (LOAD (COMPILE-FILE "BASIC.LISP"))
+;;    (COM.INFORMATIMAGO.COMMON-LISP.BASIC:MAIN)
+;;
+;;
+;;    command ::= number statements | statements .
+;;    statements ::= statement { ':' statement } .
+;;    statement ::=
+;;            PRINT [ expression { ( ',' | ';' ) expression }
+;;          | INPUT string identifier { ',' identifier }
+;;          | READ  identifier { ',' identifier }
+;;          | DATA  ( string | number ) { ',' ( string | number ) }
+;;          | RESTORE [ expression ]
+;;          | GOTO      expression
+;;          | GOSUB expression
+;;          | RETURN
+;;          | STOP
+;;          | REM whatever-up-to-the-end-of-line
+;;          | identifier '=' expression
+;;          | FOR identifier '=' expression TO expression [ STEP expression ]
+;;          | NEXT [ identifier ]
+;;          | IF condition THEN statements [ ':' ELSE statements ]
+;;          | LIST
+;;          | DIR [name.type]
+;;          | SAVE string
+;;          | LOAD string [ number ]
+;;          | ERASE ( ALL | number { number } )
+;;          | RUN
+;;          | BYE
+;;          .
+;;    expression  ::= expression ( '+' | '-' ) term .
+;;    term        ::= term       ( '*' | '/' | 'mod' ) fact .
+;;    fact        ::= fact       ( '^' ) simp .
+;;    simp        ::= number | string | identifier | '(' expression ')'
+;;                  | ( '+' | '-' ) simp .
+;;    condition   ::= disjonction .
+;;    disjonction ::= disjonction { 'OR' conjonction }  | conjonction .
+;;    conjonction ::= conjonction { 'AND' logicalnot }  | logicalnot .
+;;    logicalnot  ::= comparaison | 'NOT' logicalnot | '(' disjonction ')'
+;;    comparaison ::= expression ( '<' | '<=' | '>' | '>=' | '=' | '<>' )
+;;                                 expression .
+;;    identifier  ::= alpha { alphanum } [ '$' ].
+;;    string      ::= '"' { any-character-but-double-quote } '"' .
+;;    number      ::= digit { digit } .
+;;
+;;    The '+' operator can be used to concatenate strings.
+;;
+;;AUTHORS
+;;    <PJB> Pascal Bourguignon
+;;MODIFICATIONS
+;;    2005-09-26 <PJB> Added missing :NICKNAMES.
+;;    2003-05-19 <PJB> Created (in 2 days).
+;;BUGS
+;;    NOT IMPLEMENTED YET: scanning floating point.
+;;                         scanning parenthesis (we have them in parser).
+;;                         built-in functions: SIN COS ATAN EXP LOG
+;;                                             LEFT$ MID$ RIGHT$ ...
+;;                         arrays
+;;
+;;    This code would be happier with some factoring (basic-eval).
+;;
+;;    Some more testing could be used.
+;;
+;;    The program is stored in a fixed-size array (1000).
+;;    Perhaps we should provide either for a bigger array
+;;    or for a sparse structure (hash?).
+;;
+;;    Missing as a test case: a LISP interpreter implemented in BASIC.
+;;    (Of course, this BASIC interpreter implemented in LISP should then
+;;    be tested over the LISP interpreter implemented in BASIC :-).
+;;
+;;    Two-letter operators are not parsed correctly ("<>" --> "<>" and ">").
+;;
+;;LEGAL
+;;    GPL
+;;
+;;    Copyright Pascal Bourguignon 2003 - 2003
+;;    mailto:pjb@informatimago.com
+;;
+;;    This program is free software; you can redistribute it and/or
+;;    modify it under the terms of the GNU General Public License
+;;    as published by the Free Software Foundation; either version
+;;    2 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 General Public License for more details.
+;;
+;;    You should have received a copy of the GNU General Public
+;;    License along with this program; if not, write to the Free
+;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;    Boston, MA 02111-1307 USA
+;;****************************************************************************
+
+(DEFPACKAGE "COM.INFORMATIMAGO.COMMON-LISP.BASIC"
+  (:NICKNAMES "BASIC")
+  (:USE "COMMON-LISP")
+  (:EXPORT "BASIC" "MAIN")
+  );;BASIC
+(IN-PACKAGE "COM.INFORMATIMAGO.COMMON-LISP.BASIC")
+
+
+(DEFVAR *PROGRAM* (MAKE-ARRAY '(1000) :INITIAL-ELEMENT NIL))
+(DEFVAR *STACK*   (MAKE-ARRAY '(100)
+                              :INITIAL-ELEMENT NIL
+                              :ADJUSTABLE T
+                              :FILL-POINTER 0));;*STACK*
+(DEFVAR *VARIABLES* (MAKE-HASH-TABLE :TEST (FUNCTION EQ) :SIZE 100))
+
+(DEFVAR *CURRENT-LINE* 0)
+(DEFVAR *DATA-PTR* (CONS 0 NIL) "marker for DATA/READ/RESTORE")
+
+
+(DEFMACRO WHILE (CONDITION &BODY BODY) `(DO () ((NOT ,CONDITION)) ,@BODY))
+(DEFMACRO UNTIL (CONDITION &BODY BODY) `(DO () (,CONDITION)       ,@BODY))
+
+
+(DEFUN SPLIT-LINE (LINE)
+  "
+DO:         Split the line between the special characters:
+            space , ; : < > <= >= = <>  + - * / ^
+            as one token.  The special characters are enclosed  in pipes.
+RETURN:     A list of token string (where spaces are removed) ;
+            nil or an error message string.
+NOTE:       No parentheses: yuck maths!  No dots in numbers: yuck maths!
+"
+  (DO ((I 0 (1+ I))
+       (P 0)
+       (PARTS ())
+       (ERR NIL))
+      ((<= (LENGTH LINE) I)
+       (VALUES (PROGN (WHEN (< P (LENGTH LINE))
+                        (PUSH (SUBSEQ LINE P (LENGTH LINE)) PARTS))
+                      (NREVERSE PARTS)) ERR))
+    (MACROLET ((PUSH-PART () `(WHEN (< P I)
+                                (PUSH (SUBSEQ LINE P I) PARTS)
+                                (SETQ P I))))
+      (COND
+       ((CHAR= (CHAR LINE I) (CHARACTER " "))
+        (PUSH-PART)
+        (INCF P))
+       ((CHAR= (CHAR LINE I) (CHARACTER "\""))
+        (PUSH-PART)
+        (INCF I)
+        (DO ()
+            ((OR (<= (LENGTH LINE) I) (CHAR= (CHAR LINE I) (CHARACTER "\""))))
+          (INCF I))
+        (IF (< I (LENGTH LINE)) (INCF I))
+        (PUSH-PART)
+        (DECF I))
+       ((POSITION (CHAR LINE I) ",;:=+-*/^")
+        (PUSH-PART)
+        (INCF P)
+        (PUSH (FORMAT NIL "|~A|" (SUBSEQ LINE I P)) PARTS))
+       ((CHAR= (CHAR LINE I) (CHARACTER "<"))
+        (PUSH-PART)
+        (IF (OR (CHAR= (CHAR LINE (1+ I)) (CHARACTER "="))
+                (CHAR= (CHAR LINE (1+ I)) (CHARACTER ">")))
+          (PROGN (PUSH (FORMAT NIL "|~A|" (SUBSEQ LINE I (+ I 2))) PARTS)
+                 (SETQ P (INCF I)))
+          (PROGN (INCF P)
+                 (PUSH (FORMAT NIL "|~A|" (SUBSEQ LINE I P)) PARTS))))
+       ((CHAR= (CHAR LINE I) (CHARACTER ">"))
+        (PUSH-PART)
+        (IF  (CHAR= (CHAR LINE (1+ I)) (CHARACTER "="))
+          (PROGN (PUSH (FORMAT NIL "|~A|" (SUBSEQ LINE I (+ I 2))) PARTS)
+                 (SETQ P (INCF I)))
+          (PROGN (INCF P)
+                 (PUSH (FORMAT NIL "|~A|" (SUBSEQ LINE I P)) PARTS))))
+       ((OR (ALPHANUMERICP (CHAR LINE I))
+            (CHAR= (CHARACTER "$") (CHAR LINE I))
+            (CHAR= (CHARACTER "%") (CHAR LINE I))))
+       (T
+        (SETQ ERR (FORMAT NIL "INVALID CHARACTER: '~A' AT POSITION ~D."
+                          (CHAR LINE I) I))
+        (SETQ I (LENGTH LINE))))))
+  );;SPLIT-LINE
+
+
+
+
+(DEFUN FETCH-DATA ()
+  "
+RETURN:     The data found at or following *DATA-PTR*, or NIL if none remains.
+DO:         Increments *DATA-PTR*, or issue an error (setting *CURRENT-LINE*).
+"
+  (WHILE (AND (< (CAR *DATA-PTR*) (ARRAY-DIMENSION *PROGRAM* 0))
+              (NULL (CDR *DATA-PTR*)))
+    (INCF (CAR *DATA-PTR*))
+    (WHILE (AND (< (CAR *DATA-PTR*) (ARRAY-DIMENSION *PROGRAM* 0))
+                (OR (NULL (AREF *PROGRAM* (CAR *DATA-PTR*)))
+                    (NOT (EQ 'DATA (CAR (AREF *PROGRAM* (CAR *DATA-PTR*)))))))
+      (INCF (CAR *DATA-PTR*)))
+    (IF (AND (< (CAR *DATA-PTR*) (ARRAY-DIMENSION *PROGRAM* 0))
+             (AREF *PROGRAM* (CAR *DATA-PTR*)))
+      (SETF (CDR *DATA-PTR*) (CDR (AREF *PROGRAM* (CAR *DATA-PTR*))))))
+  ;;(format t "data-ptr= ~S~%" *data-ptr*)
+  (IF (NULL (CDR *DATA-PTR*))
+    (PROGN  (BERROR "NO MORE DATA TO READ.") NIL)
+    (IF (AND (CDR (CDR *DATA-PTR*))
+             (OR (NULL (CDDR (CDR *DATA-PTR*)))
+                 (NOT (EQ '|,| (CADR (CDR *DATA-PTR*))))
+                 (NOT (OR (STRINGP (CAR (CDR *DATA-PTR*)))
+                          (NUMBERP (CAR (CDR *DATA-PTR*)))))))
+      (PROGN (BERROR "MALFORMED DATA LINE ~A." (CAR *DATA-PTR*))    NIL)
+      (PROG1 (POP (CDR *DATA-PTR*)) (POP (CDR *DATA-PTR*))))))
+
+
+
+(DEFMACRO PROTECT-BREAK (FORM)
+  `(HANDLER-CASE
+       (VALUES ,FORM)
+     (T () (FORMAT T "~&BREAK~%") (SETQ *CURRENT-LINE* NIL) NIL)
+     (:NO-ERROR (DATA) DATA)))
+
+
+(DEFUN INPUT-DATA (TYPE)
+  (COND
+   ((EQ TYPE 'STRING) (PROTECT-BREAK (READ-LINE)))
+   ((EQ TYPE 'NUMBER) (PROTECT-BREAK (READ)))))
+
+
+
+
+(DEFUN FIND-FOR (VARIABLE)
+  "
+DO:         Finds the first entry in the stack that is a list beginning
+            with :FOR and the VARIABLE, or just :FOR if VARIABLE is NIL.
+            (compared with EQ).
+NOTE:       If found, any entry above the found entry are poped.
+RETURN:     NIL or the entry.
+"
+  (DO ((POINTER (1- (FILL-POINTER *STACK*)) (DECF POINTER)))
+      ((OR (< POINTER 0)
+           (AND (CONSP (AREF *STACK* POINTER))
+                (EQ :FOR     (CAR    (AREF *STACK* POINTER)))
+                (OR (NULL VARIABLE)
+                    (EQ VARIABLE (SECOND (AREF *STACK* POINTER))))))
+       (IF (< POINTER 0)
+         NIL
+         (PROGN
+           (SETF (FILL-POINTER *STACK*) (1+ POINTER))
+           (AREF *STACK* POINTER))))))
+
+
+(DEFUN FIND-GOSUB ()
+  "
+DO:         Finds the first entry in the stack that is a list beginning
+            with :GOSUB.
+NOTE:       If found, any entry above the found entry are poped.
+RETURN:     NIL or the entry.
+"
+  (DO ((POINTER (1- (FILL-POINTER *STACK*)) (DECF POINTER)))
+      ((OR (< POINTER 0)
+           (AND (CONSP (AREF *STACK* POINTER))
+                (EQ :GOSUB     (CAR    (AREF *STACK* POINTER)))))
+       (IF (< POINTER 0)
+         NIL
+         (PROGN
+           (SETF (FILL-POINTER *STACK*) (1+ POINTER))
+           (AREF *STACK* POINTER))))))
+
+
+
+(DEFUN BERROR (FMT &REST ARGS)
+  "
+DO:         Prints an error message formated from fmt and args.
+"
+  (IF *CURRENT-LINE*
+    (FORMAT T "~&ERROR LINE ~D: ~A~%"
+            *CURRENT-LINE* (APPLY (FUNCTION FORMAT) NIL FMT ARGS))
+    (FORMAT T "~&ERROR: ~A~%"  (APPLY (FUNCTION FORMAT) NIL FMT ARGS)))
+  (SETQ *CURRENT-LINE* NIL))
+
+
+(DEFUN CHECK-LINE (LINENUM)
+  "
+DO:         Check the line number and issue an error message.
+RETURN:     Whether the linenum is a valid line number.
+"
+  (DECLARE (INTEGER LINENUM))
+  (IF (OR (< LINENUM 1)
+          (<= (ARRAY-DIMENSION *PROGRAM* 0) LINENUM))
+    (PROGN (BERROR "LINE NUMBER OUT OF RANGE (1..~D)."
+                   (ARRAY-DIMENSION *PROGRAM* 0))
+           NIL)
+    T))
+
+
+(DEFUN FIND-LINE-OR-NEXT (LINENUM)
+  "
+PRE:       (check-line linenum)
+RETURN:    If line linenum exists then line linenum
+           else the line with the minimum line number greater than linenum
+           or else nil.
+"
+  (IF (OR (<= LINENUM 0) (<= (ARRAY-DIMENSION *PROGRAM* 0) LINENUM))
+    (PROGN (SETQ *CURRENT-LINE* NIL)
+           NIL)
+    (DO* ((LINENUM LINENUM (1+ LINENUM))
+          (LINE (AREF *PROGRAM* LINENUM) (AREF *PROGRAM* LINENUM)) )
+        ((OR LINE (= (ARRAY-DIMENSION *PROGRAM* 0) (1+ LINENUM)))
+         (IF LINE
+           (PROGN (SETQ *CURRENT-LINE* LINENUM)
+                  LINE)
+           (PROGN (SETQ *CURRENT-LINE* NIL)
+                  NIL))))))
+
+
+
+
+(DEFUN SLURP-EXPRESSION (TOKENS TERMINALS)
+  "
+DO:         Parse tokens until a terminal or end of list's found.
+RETURN:     A list of tokens making an expression ;
+            A cdr of tokens.
+"
+  (DO ((EXPR ())
+       (TOKENS TOKENS (CDR TOKENS)))
+      ((OR (NULL TOKENS)
+           (MEMBER (CAR TOKENS) TERMINALS :TEST (FUNCTION EQ)))
+       (VALUES (NREVERSE EXPR) TOKENS))
+    (PUSH (CAR TOKENS) EXPR)))
+
+
+;;; expr : term { [+|-] expr }
+;;; term : fact { [*|/] term }
+;;; fact : simple { ^ fact }
+;;; simple : ident | number | ( expr ) .
+
+(DEFUN PARSE-SIMP (SIMP)
+  "
+DO:         Parses a simple expression:
+            simp ::= number | string | identifier | ( expr ) .
+NOTE:       We're missing a function call: identifier ( expr { , expr } )
+RETURN:     A parse tree or :ERROR ; a cdr of simp.
+"
+  (COND
+   ((MEMBER (CAR SIMP) '(+ -))
+    (MULTIPLE-VALUE-BIND (EXPR REST) (PARSE-SIMP (CDR SIMP))
+      (IF (EQ :ERROR EXPR)
+        (VALUES EXPR REST)
+        (IF (EQ (CAR SIMP) '+)
+          (VALUES EXPR REST)
+          (VALUES (LIST 'NEG EXPR) REST)))))
+   ((NUMBERP (CAR SIMP)) (VALUES (CAR SIMP) (CDR SIMP)))
+   ((STRINGP (CAR SIMP)) (VALUES (CAR SIMP) (CDR SIMP)))
+   ((SYMBOLP (CAR SIMP)) (VALUES (CAR SIMP) (CDR SIMP)))
+   ((EQ '|(| (CAR SIMP))
+    (MULTIPLE-VALUE-BIND (EXPR REST) (PARSE-EXPR (CDR SIMP))
+      (IF (EQ '|)| (CAR REST))
+        (VALUES EXPR (CDR REST))
+        (PROGN
+          (BERROR "MISSING A CLOSING PARENTHESE.")
+          (VALUES :ERROR NIL)))))
+   (T (BERROR "INVALID TOKEN IN EXPRESSION ~S." (CAR SIMP)))))
+
+
+
+(DEFMACRO MAKE-PARSE-LEVEL (NAME OPERATORS NEXT)
+  "
+DO:         Generate a function named PARSE-{name} that parses the
+            following rule:  name ::= name { operators next } .
+            That functions will return a parse tree or :ERROR ; a cdr of expr.
+"
+  (LET ((PARSE-LEVEL-NAME (INTERN (FORMAT NIL "PARSE-~A" NAME)))
+        (PARSE-NEXT-NAME  (INTERN (FORMAT NIL "PARSE-~A" NEXT))))
+    `(DEFUN ,PARSE-LEVEL-NAME (EXPR)
+       (LET ((RESULT))
+         (MULTIPLE-VALUE-BIND (TERM REST) (,PARSE-NEXT-NAME EXPR)
+           (SETQ RESULT TERM EXPR REST))
+         (DO () ((OR (EQ :ERROR RESULT)
+                     (NULL EXPR)
+                     (NOT (MEMBER (CAR EXPR) ',OPERATORS
+                                  :TEST (FUNCTION EQ)))))
+           (MULTIPLE-VALUE-BIND (TERM REST) (,PARSE-NEXT-NAME (CDR EXPR))
+             (IF (EQ :ERROR TERM)
+               (SETQ RESULT :ERROR)
+               (SETQ RESULT (LIST (CAR EXPR) RESULT TERM)
+                     EXPR   REST))))
+         (VALUES RESULT EXPR)))))
+
+(DEFUN PARSE-LNOT (LNOT)
+  "
+DO:         Parses a simple logical expression:
+            lnot ::= comp | NOT lnot | ( disj ).
+RETURN:     A parse tree or :ERROR ; a cdr of expr.
+"
+  (COND
+   ((EQ (CAR LNOT) 'NOT)
+    (MULTIPLE-VALUE-BIND (EXPR REST) (PARSE-LNOT (CDR LNOT))
+      (IF (EQ :ERROR EXPR)
+        (VALUES EXPR REST)
+        (VALUES (LIST 'NOT EXPR) REST))))
+   ((EQ '|(| (CAR LNOT))
+    (MULTIPLE-VALUE-BIND (EXPR REST) (PARSE-DISJ (CDR LNOT))
+      (IF (EQ '|)| (CAR REST))
+        (VALUES EXPR (CDR REST))
+        (PROGN
+          (BERROR "MISSING A CLOSING PARENTHESE.")
+          (VALUES :ERROR NIL)))))
+   (T (PARSE-COMP LNOT))))
+
+
+(MAKE-PARSE-LEVEL FACT (^)       SIMP)
+(MAKE-PARSE-LEVEL TERM (* / MOD) FACT)
+(MAKE-PARSE-LEVEL EXPR (+ -)     TERM)
+(MAKE-PARSE-LEVEL COMP (< <= > >= = <>) EXPR)
+(MAKE-PARSE-LEVEL CONJ (AND) LNOT)
+(MAKE-PARSE-LEVEL DISJ (OR)  CONJ)
+
+
+
+(DEFUN BDIV (A B)
+  "
+RETURN: A floating-point division of a by b.
+"
+  (IF (EQUAL 0 B)
+    (PROGN
+      (BERROR "DIVISION BY ZERO.")
+      NIL)
+    (/ (FLOAT A) B)))
+
+
+
+
+(DEFUN BOOLP (OPERAND)  (MEMBER OPERAND '(:TRUE :FALSE)))
+(DEFUN BAND (A B) (AND (EQ :TRUE A) (EQ :TRUE B)))
+(DEFUN BOR  (A B) (OR  (EQ :TRUE A) (EQ :TRUE B)))
+(DEFUN BNOT (A)   (EQ :FALSE A))
+(DEFUN BOOL (LISP-BOOL) (IF LISP-BOOL :TRUE :FALSE))
+
+(DEFMACRO MAKE-COMPARISON (NAME OPERATOR NUMBER-OP STRING-OP)
+  `(DEFUN ,NAME (A B)
+     (COND
+      ((AND (NUMBERP A) (NUMBERP B)) (BOOL (,NUMBER-OP A B)))
+      ((AND (STRINGP A) (STRINGP B)) (BOOL (,STRING-OP A B)))
+      (T (BERROR "INCOMPATIBLE OPERANDS FOR ~A." ',OPERATOR)))))
+
+(MAKE-COMPARISON BLT <  <  STRING< )
+(MAKE-COMPARISON BLE <= <= STRING<=)
+(MAKE-COMPARISON BGT >  >  STRING> )
+(MAKE-COMPARISON BGE >= >= STRING>=)
+(MAKE-COMPARISON BEQ =  =  STRING= )
+(MAKE-COMPARISON BNE <> /= STRING/=)
+
+
+(DEFMACRO NUM-OP (OPERATOR OPERATION)
+  "PRIVATE MACRO for BASIC-EVAL-TREE"
+  `(LET ((LEFT  (BASIC-EVAL-TREE (SECOND TREE)))
+         (RIGHT (BASIC-EVAL-TREE (THIRD  TREE))))
+     (COND
+      ((AND (NUMBERP LEFT) (NUMBERP RIGHT)) (,OPERATION LEFT RIGHT))
+      (T (BERROR "INCOMPATIBLE OPERANDS FOR ~A." ',OPERATOR)    NIL))))
+
+(DEFMACRO COMP-OP (OPERATOR OPERATION)
+  "PRIVATE MACRO for BASIC-EVAL-TREE"
+  `(LET ((LEFT  (BASIC-EVAL-TREE (SECOND TREE)))
+         (RIGHT (BASIC-EVAL-TREE (THIRD  TREE))))
+     (COND
+      ((AND (NUMBERP LEFT) (NUMBERP RIGHT)) (,OPERATION LEFT RIGHT))
+      ((AND (STRINGP LEFT) (STRINGP RIGHT)) (,OPERATION LEFT RIGHT))
+      (T (BERROR "INCOMPATIBLE OPERANDS FOR ~A." ',OPERATION)    NIL))))
+
+(DEFMACRO BOOL-OP (OPERATOR OPERATION)
+  "PRIVATE MACRO for BASIC-EVAL-TREE"
+  `(LET ((LEFT  (BASIC-EVAL-TREE (SECOND TREE)))
+         (RIGHT (BASIC-EVAL-TREE (THIRD  TREE))))
+     (COND
+      ((AND (BOOLP LEFT) (BOOLP RIGHT)) (,OPERATION LEFT RIGHT))
+      (T (BERROR "INCOMPATIBLE OPERANDS FOR ~A." ',OPERATION)     NIL))))
+
+
+
+(DEFUN BASIC-EVAL-TREE (TREE)
+  "
+DO:         Evaluate an expression tree.
+RETURN:     NIL or the computed value.
+"
+  (COND
+   ((NUMBERP TREE) TREE)
+   ((STRINGP TREE) TREE)
+   ((SYMBOLP TREE)
+    (LET ((VALUE (GETHASH TREE *VARIABLES*)))
+      (UNLESS VALUE
+        (SETQ VALUE
+              (SETF (GETHASH TREE *VARIABLES*)
+                    (IF (CHAR= (CHARACTER "$")
+                               (CHAR (SYMBOL-NAME TREE)
+                                     (1- (LENGTH (SYMBOL-NAME TREE)))))
+                      "" 0))))
+      VALUE))
+   ((CONSP TREE)
+    (CASE (CAR TREE)
+      (-   (NUM-OP  -   -))
+      (*   (NUM-OP  *   *))
+      (/   (NUM-OP  /   BDIV))
+      (^   (NUM-OP  ^   EXPT))
+      (MOD (NUM-OP  MOD MOD))
+      (AND (BOOL-OP AND BAND))
+      (OR  (BOOL-OP OR  BOR))
+      (<   (COMP-OP <   BLT))
+      (<=  (COMP-OP <=  BLE))
+      (>   (COMP-OP >   BGT))
+      (>=  (COMP-OP >=  BGE))
+      (=   (COMP-OP =   BEQ))
+      (<>  (COMP-OP <>  BNE))
+      (+ (LET ((LEFT  (BASIC-EVAL-TREE (SECOND TREE)))
+               (RIGHT (BASIC-EVAL-TREE (THIRD  TREE))))
+           (COND
+            ((AND (STRINGP LEFT) (STRINGP RIGHT))
+             (CONCATENATE 'STRING LEFT RIGHT))
+            ((AND (NUMBERP LEFT) (NUMBERP RIGHT))      (+ LEFT RIGHT))
+            (T (BERROR "INCOMPATIBLE OPERANDS FOR +.") NIL))))
+      (NOT (LET ((LEFT  (BASIC-EVAL-TREE (SECOND TREE))))
+             (COND
+              ((BOOLP LEFT)                                   (BNOT LEFT))
+              (T (BERROR "INCOMPATIBLE OPERANDS FOR UNARY NOT.") NIL))))
+      (NEG (LET ((LEFT  (BASIC-EVAL-TREE (SECOND TREE))))
+             (COND
+              ((NUMBERP LEFT)                                    (- LEFT))
+              (T (BERROR "INCOMPATIBLE OPERANDS FOR UNARY -.")   NIL))))
+      (OTHERWISE (BERROR "UNEXPECTED OPERATOR ~A." (CAR TREE))   NIL)))
+   (T (BERROR "UNEXPECTED OPERAND ~A." TREE)                     NIL)))
+
+
+
+(DEFUN BASIC-EVAL-EXPRESSION (EXPR)
+  "
+DO:         Parses the BASIC expression EXPR and evaluates it.
+RETURN:     NIL or the computed value.
+"
+  (MULTIPLE-VALUE-BIND (TREE REST) (PARSE-EXPR EXPR)
+    (COND
+     ((EQ :ERROR TREE)
+      (BERROR "SYNTAX ERROR IN EXPRESSION ~A." EXPR)
+      NIL)
+     ((NULL REST)
+      (BASIC-EVAL-TREE TREE))
+     (T
+      (BERROR "UNEXPECTED TOKEN IN EXPRESSION: ~A." (CAR REST))
+      NIL))))
+
+
+
+(DEFUN BASIC-EVAL-CONDITION (EXPR)
+  "
+DO:         Parses the BASIC condition EXPR and evaluates it.
+RETURN:     NIL or the computed value.
+"
+  (MULTIPLE-VALUE-BIND (TREE REST) (PARSE-DISJ EXPR)
+    (COND
+     ((EQ :ERROR TREE)
+      (BERROR "SYNTAX ERROR IN CONDITION ~A." EXPR)
+      NIL)
+     ((NULL REST)
+      (BASIC-EVAL-TREE TREE))
+     (T
+      (BERROR "UNEXPECTED TOKEN IN CONDITION: ~A." (CAR REST))
+      NIL))))
+
+
+(DEFUN IDENTIFIERP  (SYM)
+  (AND (SYMBOLP SYM)
+       (ALPHA-CHAR-P (CHAR (SYMBOL-NAME SYM) 0))))
+
+
+(DEFUN IDENTIFIER-TYPE (SYM)
+  (CHAR (SYMBOL-NAME SYM) (1- (LENGTH (SYMBOL-NAME SYM)))))
+
+
+(DEFUN CHECK-LIST-VAR (LISTVAR)
+  "
+DO:         Check that listvar is a list of identifier symbols separated
+            by comas.
+RETURN:     The list of identifier symbols without the comas.
+"
+  (DO ((LISTVAR LISTVAR (CDDR LISTVAR))
+       (RESULT  '()))
+      ((NULL LISTVAR) (NREVERSE RESULT))
+    (COND
+     ((NULL LISTVAR)
+      (BERROR "EXPECTED A LIST OF VARIABLES SEPARATED BY COMAS.")
+      (SETQ RESULT NIL LISTVAR NIL))
+     ((NULL (CDR LISTVAR))
+      (IF (IDENTIFIERP (CAR LISTVAR))
+        (PUSH (CAR LISTVAR) RESULT)
+        (PROGN
+          (BERROR "EXPECTED A VARIABLE INSTEAD OF ~A." (CAR LISTVAR))
+          (SETQ RESULT NIL LISTVAR NIL))))
+     ((NULL (CDDR LISTVAR))
+      (BERROR "MALFORMED LIST OF VARIABLES.")
+      (SETQ RESULT NIL LISTVAR NIL))
+     (T
+      (IF (AND (IDENTIFIERP (CAR LISTVAR)) (EQ '|,| (CADR LISTVAR)))
+        (PUSH (CAR LISTVAR) RESULT)
+        (PROGN
+          (IF (EQ '|,| (CADR LISTVAR))
+            (BERROR "EXPECTED A VARIABLE INSTEAD OF ~A." (CAR LISTVAR))
+            (BERROR "EXPECTED A COMA INSTEAD OF ~A." (CADR LISTVAR)))
+          (SETQ RESULT NIL LISTVAR NIL)))))))
+
+
+(DEFUN BASIC-EVAL (STATEMENT)
+  "
+DO:         Evaluate the statement,
+            and the following if *current-line* is non nil.
+RETURN:     NIL or :BYE.
+"
+  (LOOP
+   ;; (format t "current-line=~S   token=~A:~A statement=~S~%"
+   ;;         *current-line* (package-name (symbol-package (car statement)))
+   ;;         (car statement) statement)
+   ;; (format t "dir=~A:~A   EQUAL=~S~%" (package-name (symbol-package 'dir))
+   ;;         'dir (equal 'dir (car statement)))
+   (UNLESS STATEMENT (RETURN NIL))
+   (CASE (CAR STATEMENT)
+     ((PRINT)
+      (MULTIPLE-VALUE-BIND (EXPR REST)
+          (SLURP-EXPRESSION (CDR STATEMENT) '(|,| |;| |:|))
+        (IF EXPR
+          (LET ((VALUE (BASIC-EVAL-EXPRESSION EXPR)))
+            (IF VALUE
+              (PROGN
+                (FORMAT T (CASE (CAR REST)
+                            ((|,|) "~A ")
+                            ((|;|) "~A")
+                            (T "~A~%")) VALUE)
+                (WHEN REST
+                  (CASE (CAR REST)
+                    ((|,| |;|) (BASIC-EVAL (CONS 'PRINT (CDR REST))))
+                    ((NIL))
+                    ((|:|)     (BASIC-EVAL (CDR REST)))
+                    (OTHERWISE (BERROR "UNEXPECTED TOKEN '~A'.") ))))
+              (SETQ *CURRENT-LINE* NIL))))))
+     ((FOR)
+      ;; FOR A = EXPR TO EXPR [ STEP EXPR ] :
+      (LET* ((VARSYM (SECOND STATEMENT))
+             (VARIABLE (IF (SYMBOLP VARSYM) (SYMBOL-NAME VARSYM) NIL))
+             (VARTYPE (IF VARIABLE (CHAR VARIABLE (1- (LENGTH VARIABLE)))))
+             (TARGET)
+             (STEP)
+             (REMAINDER)
+             (LINENUM *CURRENT-LINE*))
+        (IF (AND VARIABLE
+                 (ALPHA-CHAR-P (CHAR VARIABLE 0))
+                 (CHAR/= (CHARACTER "$") VARTYPE)
+                 (EQ '= (THIRD STATEMENT)))
+          ;; for a =
+          (MULTIPLE-VALUE-BIND (ASSIGNMENT REST)
+              (SLURP-EXPRESSION (CDR STATEMENT) '(TO))
+            (IF (EQ 'TO (CAR REST))
+              (MULTIPLE-VALUE-BIND (TARGET-EXPR RREST)
+                  (SLURP-EXPRESSION (CDR REST) '(STEP |:|))
+                (SETQ TARGET (BASIC-EVAL-EXPRESSION TARGET-EXPR))
+                (IF TARGET
+                  (IF (NUMBERP TARGET)
+                    (IF (EQ (CAR RREST) 'STEP)
+                      (MULTIPLE-VALUE-BIND (STEP-EXPR RRREST)
+                          (SLURP-EXPRESSION (CDR RREST) '(|:|))
+                        (SETQ STEP (BASIC-EVAL-EXPRESSION STEP-EXPR))
+                        (IF (NUMBERP STEP)
+                          (SETQ REMAINDER  RRREST)
+                          (PROGN
+                            (BERROR "INVALID STEP VALUE: MUST BE NUMERIC!")
+                            (SETQ STEP NIL))))
+                      (SETQ STEP 1
+                            REMAINDER  RREST))
+                    (PROGN
+                      (BERROR "INVALID TARGET VALUE: MUST BE NUMERIC!")
+                      (SETQ TARGET NIL)))))
+              (BERROR "INVALID TOKEN AFTER ASSIGNMENT IN FOR: '~A'."
+                      (CAR REST)))
+            (WHEN STEP
+              (VECTOR-PUSH-EXTEND
+               (LIST :FOR VARSYM TARGET STEP LINENUM (CDR REMAINDER))
+               *STACK* (ARRAY-DIMENSION *STACK* 0))
+              (BASIC-EVAL (NCONC ASSIGNMENT REMAINDER))))
+          (BERROR "FOR EXPECTS A NUMERIC VARIABLE ASSIGNMENT."))))
+     ((NEXT)
+      (IF (AND (< 2 (LENGTH STATEMENT)) (NOT (EQ '|:| (THIRD STATEMENT))))
+        (BERROR "INVALID TOKEN AFTER NEXT: '~A'." (THIRD STATEMENT))
+        (LET* ((VARSYM    (IF (EQ '|:| (SECOND STATEMENT))
+                            NIL (SECOND STATEMENT)))
+               (FOR-STATE (FIND-FOR VARSYM)))
+          (IF FOR-STATE
+            (LET ((VARSYM    (SECOND FOR-STATE))
+                  (TARGET    (THIRD FOR-STATE))
+                  (STEP      (FOURTH FOR-STATE))
+                  (LINENUM   (FIFTH FOR-STATE))
+                  (REMAINDER (SIXTH FOR-STATE))
+                  (VALUE     (GETHASH VARSYM *VARIABLES*)))
+              (SETQ VALUE (+ VALUE STEP))
+              (SETF (GETHASH VARSYM *VARIABLES*) VALUE)
+              (IF (IF (< 0 STEP) (<= VALUE TARGET) (<= TARGET VALUE))
+                (PROGN ;; loop
+                  (SETQ *CURRENT-LINE* LINENUM)
+                  (BASIC-EVAL (OR REMAINDER '(REM))))
+                (PROGN ;; exit loop
+                  (VECTOR-POP *STACK*)
+                  (BASIC-EVAL (IF VARSYM
+                                (CDDDR STATEMENT)
+                                (CDDR  STATEMENT))))))
+            (IF (NULL VARSYM)
+              (BERROR "NO 'FOR' LOOP.")
+              (BERROR "NO 'FOR' LOOP WITH THIS VARIABLE ~A." VARSYM))))))
+     ((IF) ;; if bool then .... else ...
+      (MULTIPLE-VALUE-BIND (EXPR REST)
+          (SLURP-EXPRESSION (CDR STATEMENT) '(THEN))
+        (LET ((CONDITION (BASIC-EVAL-CONDITION EXPR)))
+          (COND
+           ((NULL CONDITION)) ;; error already issued
+           ((BOOLP CONDITION)
+            (IF (EQ (CAR REST) 'THEN)
+              (IF (EQ :TRUE CONDITION)
+                ;; run after then
+                (BASIC-EVAL (CDR REST))
+                ;; run after else
+                (BASIC-EVAL (CDR (MEMBER 'ELSE REST))))
+              (BERROR "EXPECTED 'THEN' AFTER 'IF' CONDITION, NOT '~A'."
+                      (CAR REST))))
+           (T
+            (BERROR "INVALID BOOL EXPRESSION."))))))
+     ((ELSE)) ;; ignored and skip the rest of the line.
+     ((GOTO)
+      (MULTIPLE-VALUE-BIND (EXPR REST)
+          (SLURP-EXPRESSION (CDR STATEMENT) '(|:|))
+        (LET ((VALUE (BASIC-EVAL-EXPRESSION EXPR)))
+          (IF (AND VALUE (INTEGERP VALUE) (CHECK-LINE VALUE))
+            (SETQ *CURRENT-LINE* (1- VALUE))
+            (BERROR "INVALID TARGET LINE NUMBER IN GOTO.")))))
+     ((GOSUB)
+      (MULTIPLE-VALUE-BIND (EXPR REST)
+          (SLURP-EXPRESSION (CDR STATEMENT) '(|:|))
+        (LET ((VALUE (BASIC-EVAL-EXPRESSION EXPR)))
+          (IF (AND VALUE (INTEGERP VALUE) (CHECK-LINE VALUE))
+            (PROGN
+              (VECTOR-PUSH-EXTEND
+               (LIST :GOSUB *CURRENT-LINE* (CDR REST))
+               *STACK* (ARRAY-DIMENSION *STACK* 0))
+              (SETQ *CURRENT-LINE* (1- VALUE)))
+            (BERROR "INVALID TARGET LINE NUMBER IN GOSUB.")))))
+     ((RETURN)
+      (LET* ((GOSUB-STATE (FIND-GOSUB)))
+        (IF GOSUB-STATE
+          (LET ((LINENUM   (SECOND GOSUB-STATE))
+                (REMAINDER (THIRD  GOSUB-STATE)))
+            (SETQ *CURRENT-LINE* LINENUM)
+            (IF REMAINDER (BASIC-EVAL REMAINDER)))
+          (BERROR "NO 'GOSUB' FOR 'RETURN'."))))
+     ((INPUT)
+      (LET ((STAT-LIST-VAR))
+        (IF (STRINGP (SECOND STATEMENT))
+          (LET ((SAVED *CURRENT-LINE*))
+            (SETQ *CURRENT-LINE* NIL)
+            (BASIC-EVAL (LIST 'PRINT (SECOND STATEMENT) '|;|))
+            (SETQ *CURRENT-LINE* SAVED)
+            (SETQ STAT-LIST-VAR (CDDR STATEMENT)))
+          (PROGN
+            (FORMAT T "> ")
+            (SETQ STAT-LIST-VAR (CDR STATEMENT))))
+        (MULTIPLE-VALUE-BIND (LISTVAR REST)
+            (SLURP-EXPRESSION STAT-LIST-VAR '(|:|))
+          (LET ((LISTSYM (CHECK-LIST-VAR LISTVAR)))
+            (WHEN LISTSYM
+              (DO* ((LISTSYM LISTSYM (CDR LISTSYM))
+                    (VARSYM (CAR LISTSYM) (CAR LISTSYM))
+                    (VARTYPE (IDENTIFIER-TYPE VARSYM) (IDENTIFIER-TYPE VARSYM))
+                    (VALUE))
+                  ((NULL LISTSYM))
+                (SETQ VALUE (INPUT-DATA (IF (CHAR= (CHARACTER "$") VARTYPE)
+                                          'STRING 'NUMBER)))
+                (COND
+                 ((NULL VALUE))
+                 ;; the error is already issued and *current-line* nullified
+                 ((AND (NUMBERP VALUE) (CHAR/= (CHARACTER "$") VARTYPE))
+                  (SETF (GETHASH VARSYM *VARIABLES*) VALUE))
+                 ((AND (STRINGP VALUE) (CHAR= (CHARACTER "$") VARTYPE))
+                  (SETF (GETHASH VARSYM *VARIABLES*) VALUE))
+                 (T (BERROR "TYPE MISMATCH FOR ~A." VARSYM)))))))))
+     ((DATA)) ;; skip the rest of the line which is data.
+     ((READ)
+      (MULTIPLE-VALUE-BIND (LISTVAR REST)
+          (SLURP-EXPRESSION (CDR STATEMENT) '(|:|))
+        (LET ((LISTSYM (CHECK-LIST-VAR LISTVAR)))
+          (WHEN LISTSYM
+            (DO* ((LISTSYM LISTSYM (CDR LISTSYM))
+                  (VARSYM (CAR LISTSYM) (CAR LISTSYM))
+                  (VARTYPE (IDENTIFIER-TYPE VARSYM) (IDENTIFIER-TYPE VARSYM))
+                  (VALUE))
+                ((NULL LISTSYM))
+              (SETQ VALUE (FETCH-DATA))
+              (COND
+               ((NULL VALUE))
+               ;; the error is already issued and *current-line* nullified
+               ((AND (NUMBERP VALUE) (CHAR/= (CHARACTER "$") VARTYPE))
+                (SETF (GETHASH VARSYM *VARIABLES*) VALUE))
+               ((AND (STRINGP VALUE) (CHAR= (CHARACTER "$") VARTYPE))
+                (SETF (GETHASH VARSYM *VARIABLES*) VALUE))
+               (T (BERROR "TYPE MISMATCH FOR ~A." VARSYM))))))))
+     ((RESTORE)
+      (LET* ((REST NIL)
+             (LINENUM
+              (MULTIPLE-VALUE-BIND (EXPR TSER)
+                  (SLURP-EXPRESSION (CDR STATEMENT) '(|:|))
+                (PROG1
+                    (IF (NULL EXPR)
+                      (IF (OR (NULL (CDR STATEMENT))
+                              (EQ '|:| (CADR STATEMENT)))
+                        1
+                        (PROGN (BERROR "UNEXPECTED TOKEN AFTER RESTORE: ~A"
+                                       (CADR STATEMENT))
+                               NIL))
+                      (BASIC-EVAL-EXPRESSION EXPR))
+                  (SETQ REST (CDR TSER))))))
+        (WHEN LINENUM
+          (IF (CHECK-LINE LINENUM)
+            (PROGN
+              (SETQ *DATA-PTR* (CONS (1- LINENUM) NIL))
+              (BASIC-EVAL (OR REST '(REM))))
+            (BERROR "INVALID LINE NUMBER FOR READ: ~A" LINENUM)))))
+     ((REM)) ;; ignored
+     ((STOP)
+      (SETQ *CURRENT-LINE* NIL))
+     ((RUN)
+      (SETF (FILL-POINTER *STACK*) 0)
+      (SETQ *DATA-PTR* (CONS 0 NIL))
+      (SETQ *VARIABLES* (MAKE-HASH-TABLE :TEST (FUNCTION EQ) :SIZE 100))
+      (IF (AND (CDR STATEMENT) (INTEGERP (SECOND STATEMENT)))
+        (WHEN (CHECK-LINE (SECOND STATEMENT))
+          (BASIC-EVAL (OR (FIND-LINE-OR-NEXT (SECOND STATEMENT))
+                          (FIND-LINE-OR-NEXT 1))))
+        (BASIC-EVAL (FIND-LINE-OR-NEXT 1)))
+      (SETQ *CURRENT-LINE* NIL))
+     ((LIST)
+      (DOTIMES (LINENUM (ARRAY-DIMENSION *PROGRAM* 0))
+        (LET ((LINE (AREF *PROGRAM* LINENUM)))
+          (WHEN LINE
+            (FORMAT T "~4D " LINENUM)
+            (MAPC (LAMBDA (TOKEN)
+                    (IF (SYMBOLP TOKEN)
+                      (FORMAT T "~A " (SYMBOL-NAME TOKEN))
+                      (FORMAT T "~S " TOKEN))) LINE)
+            (FORMAT T "~%")))))
+     ((DIR)
+      (format t "~{~A~%~}" (mapcar (function pathname-name)
+                                   (directory "*.basic"))))
+     ((SAVE)
+      (IF (STRINGP (CADR STATEMENT))
+        (WITH-OPEN-FILE (*STANDARD-OUTPUT*
+                         (CADR STATEMENT) :DIRECTION :OUTPUT
+                         :IF-EXISTS :SUPERSEDE :IF-DOES-NOT-EXIST :CREATE)
+          (LET ((SAVED *CURRENT-LINE*))
+            (SETQ *CURRENT-LINE* NIL)
+            (BASIC-EVAL '(LIST))
+            (SETQ *CURRENT-LINE* SAVED)))
+        (BERROR "NOT A FILE NAME: ~S." (CADR STATEMENT))))
+     ((LOAD)
+      (IF (STRINGP (SECOND STATEMENT))
+        (PROGN
+          (WITH-OPEN-FILE (IN (CADR STATEMENT) :DIRECTION :INPUT
+                              :IF-DOES-NOT-EXIST NIL)
+            (IF (NULL IN)
+              (BERROR "CAN'T FIND A FILE FILE NAMED: ~S." (CADR STATEMENT))
+              (PROGN
+                (SETQ *CURRENT-LINE* NIL)
+                (BASIC-EVAL '(ERASE ALL))
+                (DO ((LINE (READ-LINE IN NIL NIL) (READ-LINE IN NIL NIL)))
+                    ((NOT LINE))
+                  (BASIC-PROCESS-LINE LINE)))))
+          (SETQ *CURRENT-LINE*
+                (IF (AND (NUMBERP (THIRD STATEMENT))
+                         (CHECK-LINE (THIRD STATEMENT)))
+                  (1- (THIRD STATEMENT)) NIL)))
+        (BERROR "NOT A FILE NAME: ~S." (SECOND STATEMENT))))
+     ((ERASE)
+      (MAPC (LAMBDA (LINENUM)
+              (COND
+               ((INTEGERP LINENUM)
+                (WHEN (CHECK-LINE LINENUM)
+                  (SETF (AREF *PROGRAM* LINENUM) NIL)))
+               ((EQ 'ALL LINENUM)
+                (DOTIMES (I (ARRAY-DIMENSION *PROGRAM* 0))
+                  (SETF (AREF *PROGRAM* I) NIL)))
+               (T (BERROR "NOT A LINE NUMBER: ~S." LINENUM))))
+            (CDR STATEMENT)))
+     ((BYE) (SETQ *CURRENT-LINE* NIL) (RETURN :BYE))
+     (OTHERWISE
+      (LET* ((VARSYM   (CAR STATEMENT))
+             (VARIABLE (IF (SYMBOLP VARSYM) (SYMBOL-NAME VARSYM)   NIL))
+             (VARTYPE  (IF VARIABLE (CHAR VARIABLE (1- (LENGTH VARIABLE))))))
+        (IF (AND VARIABLE
+                 (ALPHA-CHAR-P (CHAR VARIABLE 0))
+                 (EQ '= (SECOND STATEMENT)))
+          ;; assignment
+          (MULTIPLE-VALUE-BIND (EXPR REST)
+              (SLURP-EXPRESSION (CDDR STATEMENT) '(|:|))
+            (IF (OR (NULL REST) (EQ (CAR REST) '|:|))
+              (PROGN
+                (LET ((VALUE (BASIC-EVAL-EXPRESSION EXPR)))
+                  (COND
+                   ((NULL VALUE))
+                   ;; the error is already issued and *current-line* nullified
+                   ((AND (NUMBERP VALUE) (CHAR/= (CHARACTER "$") VARTYPE))
+                    (SETF (GETHASH VARSYM *VARIABLES*) VALUE))
+                   ((AND (STRINGP VALUE) (CHAR= (CHARACTER "$") VARTYPE))
+                    (SETF (GETHASH VARSYM *VARIABLES*) VALUE))
+                   (T (BERROR "TYPE MISMATCH FOR ~A." VARIABLE))))
+                (WHEN REST (BASIC-EVAL (CDR REST))))
+              (BERROR "INVALID TOKEN ~S IN EXPRESSION." (CAR REST))))
+          (BERROR "INVALID TOKEN ~S IN STATEMENT." (CAR STATEMENT)))))
+     ) ;;case
+   (IF *CURRENT-LINE*
+     (PROGN
+       (INCF *CURRENT-LINE*)
+       (SETQ STATEMENT (FIND-LINE-OR-NEXT *CURRENT-LINE*)))
+     (RETURN NIL))))
+
+
+(DEFUN BASIC-PROCESS-LINE (LINE)
+  "
+DO:         Process one BASIC line.
+"
+  (MULTIPLE-VALUE-BIND (TOKENS ERR) (SPLIT-LINE LINE)
+    (SETQ TOKENS (let ((*package* (find-package "BASIC")))
+                   (MAPCAR (LAMBDA (ITEM) (READ-FROM-STRING ITEM)) TOKENS)))
+    (COND (ERR (BERROR "~A" ERR))
+          ((AND (< 0 (LENGTH TOKENS)) (INTEGERP (CAR TOKENS)))
+           (WHEN (CHECK-LINE (CAR TOKENS))
+             (SETF (AREF *PROGRAM* (CAR TOKENS)) (CDR TOKENS))))
+          (T (SETQ *CURRENT-LINE* NIL)
+             (BASIC-EVAL TOKENS)))))
+
+
+(DEFUN BASIC ()
+  "
+DO:         Read a line and either execute it or store it in the program.
+            Repeat until the BYE command is executed.
+"
+  (SETF (FILL-POINTER *STACK*) 0)
+  (SETQ *DATA-PTR* (CONS 0 NIL))
+  (FORMAT T "*** QUICK-DIRTY-AND-UGLY BASIC, VERSION 0.1 ***~%~
+             COPYRIGHT PASCAL BOURGUIGNON 2003~%~
+             QUICK-DIRTY-AND-UGLY BASIC COMES WITH *ABSOLUTELY NO WARRANTY*.~%~
+             THIS IS FREE SOFTWARE, AND YOU ARE WELCOME TO REDISTRIBUTE IT~%~
+             UNDER THE CONDITIONS LISTED IN THE GNU PUBLIC LICENSE.~4%")
+  (BLOCK :TOP-LEVEL
+    (LOOP
+     (FORMAT T "~&> ")
+     (LET ((LINE (READ-LINE *STANDARD-INPUT* NIL NIL)))
+       (UNLESS LINE (RETURN-FROM :TOP-LEVEL))
+       (IF (EQ :BYE (BASIC-PROCESS-LINE LINE))
+         (RETURN-FROM :TOP-LEVEL)))))
+  (VALUES))
+
+
+(DEFUN MAIN (&REST ARGUMENTS)
+  (DECLARE (IGNORE ARGUMENTS))
+  (BASIC))
+
+
+;;;; basic.lisp                       -- 2004-03-14 01:34:04 -- pascal   ;;;;
diff --git a/small-cl-pgms/basic/index.html b/small-cl-pgms/basic/index.html
new file mode 100644
index 0000000..d45e166
--- /dev/null
+++ b/small-cl-pgms/basic/index.html
@@ -0,0 +1,95 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">
+
+<HTML>
+ <HEAD>
+  <link rel="icon"          href="/favicon.ico" type="image/x-icon">
+  <link rel="shortcut icon" href="/favicon.ico" type="image/x-icon">
+  <link rel="stylesheet"    href="default.css"  type="text/css">
+
+  <TITLE>A Quick, Dirty and Ugly BASIC implemented in Common Lisp</TITLE>
+
+  <META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=iso-8859-1">
+  <META HTTP-EQUIV="Description"
+        NAME="description" CONTENT="BASIC in Common Lisp">
+  <META NAME="author"      CONTENT="Pascal J. Bourguignon">
+
+  <META NAME="keywords"    CONTENT="BASIC, Common Lisp, Lisp">
+ </HEAD>
+<BODY>
+<!--TOP-BEGIN-->
+<!-- This section is automatically generated by html-update, -->
+<!-- from data in 'node.el'.    Please, do not edit it here. -->
+<DIV CLASS="TOP">
+
+</DIV>
+<!--TOP-END-->
+<!--MENU-BEGIN-->
+<!-- This section is automatically generated by html-update, -->
+<!-- from data in 'node.el'.    Please, do not edit it here. -->
+<DIV CLASS="MENU"><HR><P>|
+ <A HREF="../../../../toc.html">Contents</a> |
+ <A HREF="../../../../index.html">Home</a> |
+ <A HREF="../rpsls/index.html">Previous</a> |
+ <A HREF="../../index.html">Up</a> |
+ <A HREF="../../l99/index.html">Next</a> |
+</P><HR></DIV>
+<!--MENU-END-->
+
+<H1>BASIC</H1>
+<H2>A Quick, Dirty and Ugly Basic interpreter</H2>
+<p>This is a silly BASIC interpreter.
+<p>The lines are tokenized and stored
+   as-is in an array indexed by the line number.  When interpreting the
+   program, the instructions are parsed directly from there ; the
+   expressions are parsed into trees which are then evaluated.</p>
+
+<p> The variables are stored into a hash table indexed by their
+   identifier (symbol). Undefined variables are taken as 0 or "".</p>
+
+<p> We distinguish number and string variables depending on the presence
+   of a '$' character in the last position of the variable identifier.
+<p> Variables are reset by the command RUN. (A program can be restarted
+   without losing the variable using the GOTO or GOSUB statements).
+   Commands are not distinguished from statements and may occur in a
+   program. In particular, LOAD could be used to load a subprogram
+   overlay, and takes a line number where to jump to. </p>
+<p> Programs are loaded and saved in source form.</P>
+
+<UL>
+<LI><A HREF="basic.lisp">basic.lisp</A></LI>
+<LI><A HREF="test1.basic">test1.basic</A></LI>
+<LI><A HREF="test2.basic">test2.basic</A></LI>
+</UL>
+
+<!--MENU-BEGIN-->
+<!-- This section is automatically generated by html-update, -->
+<!-- from data in 'node.el'.    Please, do not edit it here. -->
+<DIV CLASS="MENU"><HR><P>|
+ <A HREF="../../../../toc.html">Contents</a> |
+ <A HREF="../../../../index.html">Home</a> |
+ <A HREF="../rpsls/index.html">Previous</a> |
+ <A HREF="../../index.html">Up</a> |
+ <A HREF="../../l99/index.html">Next</a> |
+</P><HR></DIV>
+<!--MENU-END-->
+<!--BOTTOM-BEGIN-->
+<!-- This section is automatically generated by html-update, -->
+<!-- from data in 'node.el'.    Please, do not edit it here. -->
+<DIV CLASS="BOTTOM">
+<hr><code><small>
+ | <a href="http://www.informatimago.com//develop/lisp/small-cl-pgms/basic/index.html">Mirror on informatimago.com</a>
+ | <a href="http://informatimago.free.fr/i//develop/lisp/small-cl-pgms/basic/index.html">Mirror on free.fr</a>
+ | </small></code>
+
+<BR><SMALL>Last update : <!--MODIFICATION-DATE--> 2011-01-19 02:07:15
+     by : <!--MODIFICATION-AUTEUR--> Pascal J. Bourguignon
+    </SMALL>
+<BR><SMALL>
+      <a href="http://validator.w3.org/check?uri=referer"><img
+          src="http://www.w3.org/Icons/valid-html401"
+          alt="Valid HTML 4.01!" height="31" width="88"></a>
+   </SMALL>
+</DIV>
+<!--BOTTOM-END-->
+</BODY>
+</HTML>
diff --git a/small-cl-pgms/basic/test-gosub-read.basic b/small-cl-pgms/basic/test-gosub-read.basic
new file mode 100644
index 0000000..987fc18
--- /dev/null
+++ b/small-cl-pgms/basic/test-gosub-read.basic
@@ -0,0 +1,14 @@
+  10 A$ = "Pascal" : GOSUB 100
+  20 A$ = "Bernard" : GOSUB 100
+  30 A$ = "Alain" : GOSUB 100
+  40 A$ = "Toto" : GOSUB 100
+  50 STOP
+ 100 RESTORE 200
+ 110 READ NOM$ , J , M , A
+ 120 IF J = 0 THEN PRINT "Pas trouv" : RETURN
+ 130 IF NOM$ = A$ THEN PRINT J ; "/" ; M ; "/" ; A : RETURN
+ 140 GOTO 110
+ 200 DATA "Pascal" , 15 , 3 , 1964
+ 201 DATA "Bernard" , 14 , 1 , 1966
+ 202 DATA "Alain" , 3 , 7 , 1968
+ 203 DATA "Fin" , 0 , 0 , 0
diff --git a/small-cl-pgms/basic/test1.basic b/small-cl-pgms/basic/test1.basic
new file mode 100644
index 0000000..7fe069d
--- /dev/null
+++ b/small-cl-pgms/basic/test1.basic
@@ -0,0 +1,30 @@
+   1 INPUT "What's your name? " NAME$
+   2 PRINT "Welcome " + NAME$ + "!"
+  10 PRINT "hello" , "world"
+  20 I = 1 : II = I + 1 : III = II + I
+  30 FOR K = 1 TO 3 * III STEP II
+  40 PRINT "k=" ; K
+  50 NEXT K
+  60 IF I < 10 THEN A = 10 : B = 1 : ELSE J = 1
+  80 REM ESPACE , ; : < > <= = = = = = >= = = = = = = <> > > > > > + - * / ^
+ 100 N = 0
+ 110 PRINT "---> n=" ; N
+ 120 IF N < 5 THEN N = N + 1 : GOTO 110
+ 130 PRINT "out"
+ 200 N = 0
+ 210 PRINT ">>>> n=" ; N
+ 220 IF N > 5 THEN PRINT "out" : ELSE N = N + 1 : GOTO 210
+ 250 RESTORE : I = 1
+ 255 READ NOM$ , J , M , A
+ 260 IF J = 0 THEN GOTO 280
+ 265 PRINT I , ":" , NOM$ , J ; "/" ; M ; "/" ; A
+ 266 I = I + 1
+ 270 GOTO 255
+ 300 DATA "Pascal" , 15 , 3 , 1964
+ 301 DATA "Bernard" , 14 , 1 , 1966
+ 302 DATA "Alain" , 3 , 7 , 1968
+ 303 DATA "Fin" , 0 , 0 , 0
+ 400 INPUT "Please enter a number:" N
+ 405 IF N < 1 THEN STOP
+ 410 RESTORE 299 + N
+ 420 I = 1 : GOTO 255
diff --git a/small-cl-pgms/basic/test2.basic b/small-cl-pgms/basic/test2.basic
new file mode 100644
index 0000000..f288b77
--- /dev/null
+++ b/small-cl-pgms/basic/test2.basic
@@ -0,0 +1,7 @@
+  10 PRINT "toto" , "I" ;
+  20 I = 1 : II = I + 1 : III = II + I
+  30 FOR K = 1 TO 3 * III STEP II
+  40 PRINT "k=" ; K
+  50 NEXT K
+  60 IF I < 10 THEN A = 10 : B = 1 ELSE J = 1
+  80 REM ESPACE , ; : < > <= = >= = = <> > + - * / ^
diff --git a/small-cl-pgms/brainfuck/99botles.bf b/small-cl-pgms/brainfuck/99botles.bf
new file mode 100644
index 0000000..75fbba8
--- /dev/null
+++ b/small-cl-pgms/brainfuck/99botles.bf
@@ -0,0 +1,60 @@
+99 Bottles of Beer in Urban Mueller's BrainF*** (The actual
+name is impolite)
+
+by Ben Olmstead
+
+ANSI C interpreter available on the internet; due to
+constraints in comments the address below needs to have the
+stuff in parenthesis replaced with the appropriate symbol:
+
+http://www(dot)cats(dash)eye(dot)com/cet/soft/lang/bf/
+
+Believe it or not this language is indeed Turing complete!
+Combines the speed of BASIC with the ease of INTERCAL and
+the readability of an IOCCC entry!
+
+>+++++++++[<+++++++++++>-]<[>[-]>[-]<<[>+>+<<-]>>[<<+>>-]>>>
+[-]<<<+++++++++<[>>>+<<[>+>[-]<<-]>[<+>-]>[<<++++++++++>>>+<
+-]<<-<-]+++++++++>[<->-]>>+>[<[-]<<+>>>-]>[-]+<<[>+>-<<-]<<<
+[>>+>+<<<-]>>>[<<<+>>>-]>[<+>-]<<-[>[-]<[-]]>>+<[>[-]<-]<+++
++++++[<++++++<++++++>>-]>>>[>+>+<<-]>>[<<+>>-]<[<<<<<.>>>>>-
+]<<<<<<.>>[-]>[-]++++[<++++++++>-]<.>++++[<++++++++>-]<++.>+
+++++[<+++++++++>-]<.><+++++..--------.-------.>>[>>+>+<<<-]>
+>>[<<<+>>>-]<[<<<<++++++++++++++.>>>>-]<<<<[-]>++++[<+++++++
++>-]<.>+++++++++[<+++++++++>-]<--.---------.>+++++++[<------
+---->-]<.>++++++[<+++++++++++>-]<.+++..+++++++++++++.>++++++
+++[<---------->-]<--.>+++++++++[<+++++++++>-]<--.-.>++++++++
+[<---------->-]<++.>++++++++[<++++++++++>-]<++++.-----------
+-.---.>+++++++[<---------->-]<+.>++++++++[<+++++++++++>-]<-.
+>++[<----------->-]<.+++++++++++..>+++++++++[<---------->-]<
+-----.---.>>>[>+>+<<-]>>[<<+>>-]<[<<<<<.>>>>>-]<<<<<<.>>>+++
++[<++++++>-]<--.>++++[<++++++++>-]<++.>+++++[<+++++++++>-]<.
+><+++++..--------.-------.>>[>>+>+<<<-]>>>[<<<+>>>-]<[<<<<++
+++++++++++++.>>>>-]<<<<[-]>++++[<++++++++>-]<.>+++++++++[<++
++++++++>-]<--.---------.>+++++++[<---------->-]<.>++++++[<++
++++++++++>-]<.+++..+++++++++++++.>++++++++++[<---------->-]<
+-.---.>+++++++[<++++++++++>-]<++++.+++++++++++++.++++++++++.
+------.>+++++++[<---------->-]<+.>++++++++[<++++++++++>-]<-.
+-.---------.>+++++++[<---------->-]<+.>+++++++[<++++++++++>-
+]<--.+++++++++++.++++++++.---------.>++++++++[<---------->-]
+<++.>+++++[<+++++++++++++>-]<.+++++++++++++.----------.>++++
++++[<---------->-]<++.>++++++++[<++++++++++>-]<.>+++[<----->
+-]<.>+++[<++++++>-]<..>+++++++++[<--------->-]<--.>+++++++[<
+++++++++++>-]<+++.+++++++++++.>++++++++[<----------->-]<++++
+.>+++++[<+++++++++++++>-]<.>+++[<++++++>-]<-.---.++++++.----
+---.----------.>++++++++[<----------->-]<+.---.[-]<<<->[-]>[
+-]<<[>+>+<<-]>>[<<+>>-]>>>[-]<<<+++++++++<[>>>+<<[>+>[-]<<-]
+>[<+>-]>[<<++++++++++>>>+<-]<<-<-]+++++++++>[<->-]>>+>[<[-]<
+<+>>>-]>[-]+<<[>+>-<<-]<<<[>>+>+<<<-]>>>[<<<+>>>-]<>>[<+>-]<
+<-[>[-]<[-]]>>+<[>[-]<-]<++++++++[<++++++<++++++>>-]>>>[>+>+
+<<-]>>[<<+>>-]<[<<<<<.>>>>>-]<<<<<<.>>[-]>[-]++++[<++++++++>
+-]<.>++++[<++++++++>-]<++.>+++++[<+++++++++>-]<.><+++++..---
+-----.-------.>>[>>+>+<<<-]>>>[<<<+>>>-]<[<<<<++++++++++++++
+.>>>>-]<<<<[-]>++++[<++++++++>-]<.>+++++++++[<+++++++++>-]<-
+-.---------.>+++++++[<---------->-]<.>++++++[<+++++++++++>-]
+<.+++..+++++++++++++.>++++++++[<---------->-]<--.>+++++++++[
+<+++++++++>-]<--.-.>++++++++[<---------->-]<++.>++++++++[<++
+++++++++>-]<++++.------------.---.>+++++++[<---------->-]<+.
+>++++++++[<+++++++++++>-]<-.>++[<----------->-]<.+++++++++++
+..>+++++++++[<---------->-]<-----.---.+++.---.[-]<<<]
+
diff --git a/small-cl-pgms/brainfuck/bf.lisp b/small-cl-pgms/brainfuck/bf.lisp
new file mode 100644
index 0000000..76b0762
--- /dev/null
+++ b/small-cl-pgms/brainfuck/bf.lisp
@@ -0,0 +1,899 @@
+;;;; -*- 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 Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2005-09-11 <PJB> Created
+;;;;BUGS
+;;;;LEGAL
+;;;;    GPL
+;;;;
+;;;;    Copyright Pascal Bourguignon 2005 - 2005
+;;;;
+;;;;    This program is free software; you can redistribute it and/or
+;;;;    modify it under the terms of the GNU General Public License
+;;;;    as published by the Free Software Foundation; either version
+;;;;    2 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 General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU General Public
+;;;;    License along with this program; if not, write to the Free
+;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;;    Boston, MA 02111-1307 USA
+;;;;****************************************************************************
+
+
+
+;;;----------------------------------------------------------------------
+;;; -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
+
+
+(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 test1 (&rest args)
+  (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))
+
+
+||#
+
+
+(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/index.html b/small-cl-pgms/brainfuck/index.html
new file mode 100644
index 0000000..887d43a
--- /dev/null
+++ b/small-cl-pgms/brainfuck/index.html
@@ -0,0 +1,44 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">
+
+<HTML>
+ <HEAD>
+  <link rel="icon"          href="/favicon.ico" type="image/x-icon">
+  <link rel="shortcut icon" href="/favicon.ico" type="image/x-icon">
+  <link rel="stylesheet"    href="default.css"  type="text/css">
+
+  <TITLE>Brainfuck in Lisp -- Lisp in Brainfuck</TITLE>
+
+  <META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=iso-8859-1">
+  <META HTTP-EQUIV="Description"
+        NAME="description" CONTENT="BASIC in Common Lisp">
+  <META NAME="author"      CONTENT="Pascal J. Bourguignon">
+
+  <META NAME="keywords"    CONTENT="Brainfuck, Common Lisp, Lisp, virtual machine, compiler, emulator">
+ </HEAD>
+<BODY>
+<!--TOP-BEGIN-->
+<!--TOP-END-->
+<!--MENU-BEGIN-->
+<!--MENU-END-->
+
+<H1>Brainfuck in Lisp</H1>
+<p>This file contains:
+<ul>
+<li>a brainfuck virtual machine in Lisp</li>
+<li>a brainfuck optimizing compiler, translates to lisp and compiles lisp to native code</li>
+<li>a sketch for an implementation of a lisp on brainfuck. Nothing much actually, some macros to generate brainfuck code from lisp, some lisp "vm" primitives.  I kind of abandonned this, given the time complexity of any non-trivial brainfuck program and space limitations of the brainfuck virtual machine (however, this brainfuck to lisp compiler reduces the time complexities by using some random access to the memory, so it might be practical. Not that there is no limitation on the size of the programs...).<br>Instead of implementing a lisp system over the brainfuck virtual machine, it might be more practical to implement a lisp compiler generating optimized brainfuck code.</li>
+</ul>
+</p>
+
+
+<UL>
+<LI><A HREF="bf.lisp">bf.lisp</A></LI>
+<LI><A HREF="99botles.bf">99botles.bf -- the "99 Bottles" program in brainfuck</A></LI>
+</UL>
+
+<!--MENU-BEGIN-->
+<!--MENU-END-->
+<!--BOTTOM-BEGIN-->
+<!--BOTTOM-END-->
+</BODY>
+</HTML>
diff --git a/small-cl-pgms/brainfuck/simple-cl.lisp b/small-cl-pgms/brainfuck/simple-cl.lisp
new file mode 100644
index 0000000..255b5d0
--- /dev/null
+++ b/small-cl-pgms/brainfuck/simple-cl.lisp
@@ -0,0 +1,320 @@
+;;;; -*- mode:lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE:               simple-cl.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    A simple subset of CL.
+;;;;
+;;;;    The reader is a very simple subset of the Common Lisp reader.
+;;;;    We DO NOT implement the reader macros characters:
+;;;;        ;         comment
+;;;;        '         quote
+;;;;        "         strings (with \ escapes)
+;;;;        |\        single and multiple escapes in symbol names.
+;;;;        ` , ,@    backquote, comma and comma-at.
+;;;;        #         the dispatching macro character.
+;;;;    we don't implement any of the dispatch reader macro,
+;;;;    we don't implement packages nor package separators,
+;;;;
+;;;;    we only have fixnum, symbols, list and dotted lists.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2008-07-12 <PJB> Restricted the reader.
+;;;;    2008-05-20 <PJB> Implemented simple-reader.
+;;;;    2008-05-05 <PJB> Created.
+;;;;BUGS
+;;;;LEGAL
+;;;;    GPL
+;;;;
+;;;;    Copyright Pascal Bourguignon 2008 - 2008
+;;;;
+;;;;    This program is free software; you can redistribute it and/or
+;;;;    modify it under the terms of the GNU General Public License
+;;;;    as published by the Free Software Foundation; either version
+;;;;    2 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 General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU General Public
+;;;;    License along with this program; if not, write to the Free
+;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;;    Boston, MA 02111-1307 USA
+;;;;**************************************************************************
+
+
+
+(defun bf$print (obj)
+  (let ((stack (list 'element obj)))
+    (loop
+       :while stack
+       :do (let ((kind    (pop stack))
+                 (cur-obj (pop stack)))
+             (typecase cur-obj
+               (cons
+                (if (eql kind 'element)
+                    (progn
+                      (bf$$print-string "(")
+                      (push (cdr cur-obj) stack)
+                      (push 'list         stack)
+                      (push (car cur-obj) stack)
+                      (push 'element stack))
+                    (progn
+                      (bf$$print-string " ")
+                      (push (cdr cur-obj) stack)
+                      (push 'list         stack)
+                      (push (car cur-obj) stack)
+                      (push 'element stack))))
+               (null
+                (if (eql kind 'element)
+                    (bf$$print-string "NIL")
+                    (bf$$print-string ")")))
+               (t
+                (if (eql kind 'element)
+                    (bf$$print-string (prin1-to-string cur-obj))
+                    (progn (bf$$print-string " . ")
+                           (bf$$print-string (prin1-to-string cur-obj))
+                           (bf$$print-string ")")))))))
+    output))
+
+
+
+(setf text "(attributes (lock \"toto\"))")
+
+(defun make-str (str) (copy-seq   str))
+(defun make-sym (str) (intern     str))
+
+(defvar *scanner-text*)
+(defvar *scanner-position*)
+(defun init-scanner (text)
+  (setf *scanner-text* text
+        *scanner-position* 0))
+(defconstant +eot+ 'nil)
+(defun eotp (ch) (eql +eot+ ch))
+(defun next-char ()
+  (when (< *scanner-position* (length *scanner-text*))
+    (prog1 (aref *scanner-text* *scanner-position*)
+      (incf *scanner-position*))))
+(defun parse-token (kind token)
+  (case kind
+    ((symbol) (values 'symbol (make-sym token)))
+    (otherwise
+     (let ((value  (parse-integer token :junk-allowed t)))
+       (if (string= token (prin1-to-string value))
+           (values 'integer value)
+           (values 'symbol  (make-sym token)))))))
+
+(defun read-from-str (text)
+  (init-scanner text)
+  (let ((ch #\space)
+        type value
+        (stack '(parse done eot nil)))
+    (macrolet ((stop () `(car stack))
+               (spop ()
+                 '(pop stack)
+                 #-(and)
+                 (let ((val (gensym)))
+                   `(let ((,val (pop stack)))
+                      (format t "(pop ~A) --> ~S~%~A = ~S~%~%"
+                              'stack ,val 'stack stack)
+                      ,val)))
+               (spush (expr)
+                 `(push ,expr stack)
+                 #-(and)
+                 (let ((vexpr (gensym)))
+                   `(let ((,vexpr ,expr))
+                      (format t "~A = ~S~%(push  ~S = ~S  ~A)~%"
+                              'stack stack ',expr  ,vexpr 'stack)
+                      (prog1 (push ,vexpr stack)
+                        (format t  "~A = ~S~2%"  'stack stack))))))
+      (loop
+         :for state = (spop)
+         :until (eql state 'done)
+         :do (ecase state
+               ((parse)
+                (progn
+                  (loop
+                     :named skip-spaces
+                     :while (and (not (eotp ch)) (or (char= #\space ch) (char= #\newline ch)))
+                     :do (setf ch (next-char)))
+                  (case ch
+                    ((#.+eot+)
+                     (spush nil)
+                     (spush 'eot)
+                     (spush 'done))
+                    ((#\')
+                     (spush 'quote)
+                     (spush 'parse))
+                    ((#\")
+                     (loop
+                        :with strstate = 'in-string
+                        :with str = ""
+                        :until (or (eotp ch) (eql strstate 'done))
+                        :do (setf ch (next-char))
+                        :do (ecase strstate
+                              ((in-string)
+                               (case ch
+                                 ((#\") (setf strstate 'done))
+                                 ((#\\) (setf strstate 'escaped))
+                                 (otherwise (concat str ch))))
+                              ((escaped)
+                               (concat str ch)
+                               (setf strstate 'in-string)))
+                        :finally (if (eotp ch)
+                                     (error "End-Of-Text in the string ~S" str)
+                                     (progn
+                                       (spush (make-str str))
+                                       (spush 'string)
+                                       (spush 'token)
+                                       (setf ch (next-char))))))
+                    ((#\()
+                     (spush 'nil)
+                     (spush 'list)
+                     (spush 'parse)
+                     (setf ch (next-char)))
+                    ((#\))
+                     (if (eql 'list (stop))
+                         (progn (spop)
+                                (spush (reverse (spop)))
+                                (spush 'cons)
+                                (spush 'token)
+                                (setf ch (next-char)))
+                         (error "An object cannot begin with #\\)")))
+                    ((#\;)
+                     (loop :named comment :until (or (scanner-eot) (char= #\newline (next-char))))
+                     (spush 'parse))
+                    ((#\` #\, #\#)
+                     (error "Reader macro for character #\\~C is not implemented yet." ch))
+                    (otherwise
+                     (loop
+                        :with kind = nil
+                        :with tokenstate = 'in-token
+                        :with token = ""
+                        :until (eql tokenstate 'done)
+                        :do (ecase tokenstate
+                              ((in-token)
+                               (case ch
+                                 ((#.+eot+)
+                                  (setf tokenstate 'done)
+                                  (multiple-value-bind (type value) (parse-token kind token)
+                                    (progn (spush value)
+                                           (spush type)
+                                           (spush 'token))))
+                                 ((#\space #\' #\" #\; #\, #\` #\( #\) #\newline)
+                                  (setf tokenstate 'done)
+                                  (multiple-value-bind (type value) (parse-token kind token)
+                                    (progn (spush value)
+                                           (spush type)
+                                           (spush 'token))))
+                                 ((#\\)
+                                  (setf tokenstate 'escape1 kind 'symbol)
+                                  (setf ch (next-char)))
+                                 ((#\|)
+                                  (setf tokenstate 'escape2 kind 'symbol)
+                                  (setf ch (next-char)))
+                                 (otherwise
+                                  (unless (or (eotp ch)
+                                              (digit-char-p ch)
+                                              (position ch "+-.EeSsFfDdLl"))
+                                    (setf kind 'symbol))
+                                  (concat token (char-upcase ch))
+                                  (setf ch (next-char)))))
+                              ((escape1)
+                               (when (eotp ch)
+                                 (error "Escaping EOT"))
+                               (concat token ch)
+                               (setf tokenstate 'in-token)
+                               (setf ch (next-char)))
+                              ((escape2)
+                               (case ch
+                                 ((#.+eot+) (error "EOT in multiple escape"))
+                                 ((#\\)     (setf tokenstate 'escape21))
+                                 ((#\|)     (setf tokenstate 'in-token))
+                                 (otherwise (concat token ch)))
+                               (setf ch (next-char)))
+                              ((escape21)
+                               (when (eotp ch)
+                                 (error "Escaping EOT"))
+                               (concat token ch)
+                               (setf tokenstate 'escape2)
+                               (setf ch (next-char)))))))))
+               ((token)
+                (let ((type  (spop))
+                      (value (spop)))
+                  (ecase (setf state (spop))
+                    ((done)
+                     (spop)
+                     (spop)
+                     (spush value)
+                     (spush type)
+                     (spush 'done))
+                    ((list)
+                     (spush (cons value (spop)))
+                     (spush 'list)
+                     (spush 'parse))
+                    ((quote)
+                     (spush (list 'quote value))
+                     (spush 'cons)
+                     (spush 'token))))))
+         :finally (let ((type  (spop))
+                        (value (spop)))
+                    (return (values value *scanner-position*)))))))
+
+
+
+
+
+
+;; ((#\` #<COMPILED-FUNCTION COM.INFORMATIMAGO.COMMON-LISP.READER::READER-MACRO-BACKQUOTE>        NIL NIL)
+;;  (#\; #<COMPILED-FUNCTION COM.INFORMATIMAGO.COMMON-LISP.READER::READER-MACRO-LINE-COMMENT>     NIL NIL)
+;;  (#\, #<COMPILED-FUNCTION COM.INFORMATIMAGO.COMMON-LISP.READER::READER-MACRO-COMMA>            NIL NIL)
+;;  (#\) #<COMPILED-FUNCTION COM.INFORMATIMAGO.COMMON-LISP.READER::READER-MACRO-ERROR-START>      NIL NIL)
+;;  (#\( #<COMPILED-FUNCTION COM.INFORMATIMAGO.COMMON-LISP.READER::READER-MACRO-LEFT-PARENTHESIS> NIL NIL)
+;;  (#\' #<COMPILED-FUNCTION COM.INFORMATIMAGO.COMMON-LISP.READER::READER-MACRO-QUOTE>            NIL NIL)
+;;  (#\" #<COMPILED-FUNCTION COM.INFORMATIMAGO.COMMON-LISP.READER::READER-MACRO-STRING>           NIL NIL))
+
+;; comment ::= ';' line-char '\n' .
+;; sexp ::= atom | '(' ')' | '(' sexp+ [ '.' sexp ] ')' | '\'''(' sexp ')'
+;; atom ::= [-+]digit+ | [-+]digit+.digit+[[eE][-+]digit+] | '"' string-char* '"' | symbol-char(symbol-char|digit)*
+
+;;(trace next-char)
+(dolist (test '((|symbol|  "|symbol|")
+                (|symbol|  "\\s\\y\\m\\b\\o\\l and another")
+                (|SYMBOL|  "symbol")
+                (|SYMBOL|  "SYMBOL and another")
+                (1234      "1234")
+                (1234      "1234 integer")
+                (1234      "01234 integer")
+                ("string"  "\"string\"")
+                ("string"  "\"string\" and something else")
+                ("string\"with dblquote"
+                 "\"string\\\"with dblquote\" and something else")
+                ( "string
+with newline"
+                  "\"string
+with newline\" and something else")
+                (() "()")
+                (() "  (   )   ")
+                ((1) "  ( 1  )   ")
+                ((1 2 3 4) "  ( 1 2 3 4 )   ")
+                ((|a| |bc| |def|) " (|a| |bc| \\d\\e\\f)   ")
+                ((|attributes| (|lock| "toto")) "(|attr|\\i|butes| (|lock| \"toto\"))")
+                ((A BC DEF) " (a bc def)   ")
+                ((attributes (lock "toto")) "(attributes (lock \"toto\"))")))
+  (let ((results  (multiple-value-list (read-from-str (second test)))))
+    (format t "(read-from-str ~S) ~% --> ~{~S~^, ~}~%" (second test) results)
+    (if (equal (first results) (first test))
+        (format t "    as expected.~%")
+        (format t "    BUT EXPECTED: ~S~%" (first test)))))
+
+
+
+
+
diff --git a/small-cl-pgms/brainfuck/simple-symbol.lisp b/small-cl-pgms/brainfuck/simple-symbol.lisp
new file mode 100644
index 0000000..78056da
--- /dev/null
+++ b/small-cl-pgms/brainfuck/simple-symbol.lisp
@@ -0,0 +1,37 @@
+
+
+(defparameter bf$symbols '())
+
+(defun bf$intern (name)
+  (let ((ass (assoc name bf$symbols :test (function equal))))
+    (if ass
+        (cdr ass)
+        (let ((sym (cons :$symbol (list :pname name))))
+          (setf bf$symbols (cons (cons name sym) bf$symbols))
+          sym))))
+
+(defun bf$set (sym value)
+  (let ((slot (member :value (cdr sym))))
+    (if slot
+        (setf (cadr slot) value)
+        (setf (cdr sym) (list* :value value (cdr sym))))
+    value))
+
+(defun bf$symbol-value (sym)
+  (let ((slot (member :value (cdr sym))))
+    (when slot
+        (cadr slot))))
+
+
+
+(bf$intern "CAR")
+(bf$intern "ASSOC")
+(bf$set (bf$intern "X") 42)
+(bf$symbol-value (bf$intern "X"))
+(bf$symbol-value (bf$intern "ASSOC"))
+(bf$symbol-value (bf$intern "Y"))
+(bf$set (bf$intern "X") 24)
+(bf$symbol-value (bf$intern "X"))
+bf$symbols
+
+
diff --git a/small-cl-pgms/clisp-fork/count-fork.c b/small-cl-pgms/clisp-fork/count-fork.c
new file mode 100644
index 0000000..9acefac
--- /dev/null
+++ b/small-cl-pgms/clisp-fork/count-fork.c
@@ -0,0 +1,23 @@
+#include <stdio.h>
+#include <unistd.h>
+#include <sys/time.h>
+#include <signal.h>
+
+static run=1;
+static void sh_stop(int signal){run=0;}
+int main(void){
+    long long counter;
+    struct itimerval i;
+    i.it_interval.tv_sec=0;
+    i.it_interval.tv_usec=0;
+    i.it_value.tv_sec=0;
+    i.it_value.tv_usec=10000;
+    signal(SIGVTALRM,sh_stop);
+    setitimer(ITIMER_VIRTUAL,&i,0);
+    counter=0;
+    while(run){
+        if(fork()==0){
+            exit(0);}
+        counter++;}
+    printf("forked %lld times\n",counter);
+    return(0);}
diff --git a/small-cl-pgms/clisp-fork/count-fork.lisp b/small-cl-pgms/clisp-fork/count-fork.lisp
new file mode 100644
index 0000000..0e9e5ac
--- /dev/null
+++ b/small-cl-pgms/clisp-fork/count-fork.lisp
@@ -0,0 +1,112 @@
+;;;;**************************************************************************
+;;;;FILE:               count-fork.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    Testing fork and signals in clisp.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2006-05-02 <PJB> Added this header.
+;;;;BUGS
+;;;;LEGAL
+;;;;    GPL
+;;;;
+;;;;    Copyright Pascal Bourguignon 2006 - 2006
+;;;;
+;;;;    This program is free software; you can redistribute it and/or
+;;;;    modify it under the terms of the GNU General Public License
+;;;;    as published by the Free Software Foundation; either version
+;;;;    2 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 General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU General Public
+;;;;    License along with this program; if not, write to the Free
+;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;;    Boston, MA 02111-1307 USA
+;;;;**************************************************************************
+
+(defparameter *run* t)
+
+
+(defun install-signal-handler (signum handler)
+  (let ((oldhan (linux:|set-signal-handler| signum handler))
+        (sigset (second (multiple-value-list
+                          (linux:|sigaddset| (second (multiple-value-list
+                                                      (linux:|sigemptyset|)))
+                                 signum)))))
+    (linux:|sigprocmask-set-n-save| linux:|SIG_UNBLOCK| sigset)
+    (values signum oldhan sigset)))
+
+
+(defun restore-signal-handler (signum oldhan sigset)
+  (linux:|set-signal-handler| signum oldhan)
+  (linux:|sigprocmask-set-n-save| linux:|SIG_UNBLOCK| sigset))
+
+
+(defmacro with-signal-handler (signum handler &body body)
+  (let ((voldhan (gensym))
+        (vsignum (gensym))
+        (vsigset (gensym)))
+    `(let* ((,vsignum ,signum)
+            (,voldhan (linux:|set-signal-handler| ,vsignum ,handler))
+            (,vsigset (second (multiple-value-list
+                               (linux:|sigaddset|
+                                      (second (multiple-value-list
+                                               (linux:|sigemptyset|)))
+                                      ,vsignum)))))
+      (linux:|sigprocmask-set-n-save| linux:|SIG_UNBLOCK| ,vsigset)
+      (unwind-protect (progn ,@body)
+        (linux:|set-signal-handler| ,vsignum ,voldhan)
+        (linux:|sigprocmask-set-n-save| linux:|SIG_UNBLOCK| ,vsigset)))))
+
+
+(ffi:def-c-struct itimerval
+  (interval-sec  ffi:long)
+  (interval-mic  ffi:long)
+  (value-sec     ffi:long)
+  (value-mic     ffi:long))
+
+(defconstant +itimer-real+    0)
+(defconstant +itimer-virtual+ 1)
+(defconstant +itimer-prof+    2)
+
+(ffi:def-call-out
+ setitimer
+ (:name "setitimer")
+ (:arguments (which ffi:int :in) (value (ffi:c-ptr itimerval) :in)
+  (ovalue (ffi:c-ptr-null itimerval) :in))
+ (:return-type ffi:int)
+ (:language :stdc)
+ (:library "/lib/libc.so.6"))
+
+
+(defun main ()
+  (setf *run* t)
+  (sleep 1.0)
+  (with-signal-handler linux:|SIGVTALRM|
+    (lambda (signum) (declare (ignore signum)) (setf *run* nil))
+    (ffi:with-c-var (i 'itimerval (make-itimerval :interval-sec 0
+                                                  :interval-mic 0
+                                                  :value-sec 0
+                                                  :value-mic 10000))
+      (setitimer +itimer-virtual+ i nil))
+    (loop
+       :with counter = 0
+       :with failed  = 0
+       :while *run*
+       :do (let ((res (linux:fork)))
+               (cond ((null res) (incf failed))
+                     ((= 0 res) (linux:exit 0))
+                     (t (incf counter))))
+       :finally (format t "forked ~D times (failed ~D times)~%"
+                          counter failed)
+       (finish-output))))
+
diff --git a/small-cl-pgms/cube.lisp b/small-cl-pgms/cube.lisp
new file mode 100644
index 0000000..c81e30b
--- /dev/null
+++ b/small-cl-pgms/cube.lisp
@@ -0,0 +1,477 @@
+;;;; -*- mode:lisp; coding:utf-8 -*-
+;;;;****************************************************************************
+;;;;FILE:               cube.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             clisp
+;;;;USER-INTERFACE:     clisp
+;;;;DESCRIPTION
+;;;;
+;;;;    This program tries to resolve the Cube Puzzle, where a cube
+;;;;    composed of 27 smaller cubes linked with a thread  must be
+;;;;    recomposed.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal J. Bourguignon
+;;;;MODIFICATIONS
+;;;;    2004-01-25 <PJB> Removed import from CLOS (everything is in COMMON-LISP).
+;;;;    1995-??-?? <PJB> Creation.
+;;;;BUGS
+;;;;    Does not solve it yet.
+;;;;LEGAL
+;;;;    GPL
+;;;;    Copyright Pascal J. Bourguignon 1995 - 2004
+;;;;
+;;;;    This file is part of the Cube Puzzle program.
+;;;;
+;;;;    This  program is  free software;  you can  redistribute  it and/or
+;;;;    modify it  under the  terms of the  GNU General Public  License as
+;;;;    published by the Free Software Foundation; either version 2 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
+;;;;    General Public License for more details.
+;;;;
+;;;;    You should have received a  copy of the GNU General Public License
+;;;;    along with  this program; see the  file COPYING; if  not, write to
+;;;;    the Free  Software Foundation, Inc.,  59 Temple Place,  Suite 330,
+;;;;    Boston, MA 02111-1307 USA
+;;;;
+;;;;****************************************************************************
+
+(DEFPACKAGE "COM.INFORMATIMAGO.COMMON-LISP.CUBE"
+  (:DOCUMENTATION
+   "This program tries to resolve the Cube Puzzle, where a cube
+    composed of 27 smaller cubes linked with a thread  must be
+    recomposed.
+
+    Copyright Pascal Bourguignon 1995 - 2004
+    This package is provided under the GNU General Public License.
+    See the source file for details.")
+  (:USE "COMMON-LISP")
+  (:EXPORT MAKE-CUBE-LIST
+           CUBE
+           SET-NUMBER SET-COORDINATE INPUT-VECTOR OUTPUT-VECTOR
+           COLLIDE ROLL SOLVE ADD-OUTPUT-CUBE-TO-SIDE
+           SET-INPUT-CUBE-TO-SIDE BOUNDS REVERSE-CUBES  )
+  );;COM.INFORMATIMAGO.COMMON-LISP.CUBE
+;;(IN-PACKAGE "COM.INFORMATIMAGO.COMMON-LISP.CUBE")
+
+
+;; 3 2 3 2 3 2 3 3 2 3 3 3 3
+;;#
+;;#
+;;##
+;; ###
+;;   ###
+;;     ##
+;;      #
+;;      ###
+;;        ##
+;;         ###
+;;           #
+;;           ###
+;;             #
+;;             #
+
+;;###
+;;  ##
+;;   #
+;;   ##
+;;    #
+;;    ##
+;;     #
+;;     ###
+;;       ##
+;;        ##
+;;         #
+;;         ###
+;;           #
+;;           ###
+
+
+
+;;                      ^ z
+;;                      |
+;;               +------|----+
+;;              /       |   /|
+;;             /        |  / |    ^
+;;            /      4  | /  |   / y
+;;           /          |/   |  /
+;;          +-----------+    | /
+;;          |           | 6  |/
+;;          |           |    +
+;;          |           |   /
+;;          |     2     |  /
+;;          |           | /
+;;          |           |/
+;;          +-----------+------------> x
+
+
+(defun v (x y z)
+  (make-array '(3) :element-type number :initial-contents (list x y z)))
+
+
+(defun o (a b c d e f g h i)
+  (make-array '(3) :initial-contents (list (v a b c) (v d e f) (v g h i))))
+
+
+(defun ov (c1 c2 c3)
+  (make-array '(3) :initial-contents (list c1 c2 c3)))
+
+
+(defmacro oref (o i j) `(aref (aref ,o ,i) ,j))
+
+
+(defun v+ (&rest args)
+  (let ((x 0)(y 0)(z 0))
+    (dolist (arg args)
+      (incf x (aref arg 0))
+      (incf y (aref arg 1))
+      (incf z (aref arg 2)))
+    (v x y z)));;v+
+
+
+(defun v- (arg1 &rest args)
+  (if (null args)
+    (v (- (aref arg1 0)) (- (aref arg1 1)) (- (aref arg1 2)))
+    (let ((x (aref arg1 0)) (y (aref arg1 1)) (z (aref arg1 2)))
+      (dolist (arg args)
+        (decf x (aref arg 0))
+        (decf y (aref arg 1))
+        (decf z (aref arg 2)))
+      (v x y z))));;v-
+
+
+(defun o- (arg1 &rest args)
+  (if (null args)
+    (ov (v- (aref arg1 0)) (v- (aref arg1 1)) (v- (aref arg1 2)))
+    (let ((a (oref arg1 0 0))(b (oref arg1 0 1))(c (oref arg1 0 2))
+          (d (oref arg1 1 0))(e (oref arg1 1 1))(f (oref arg1 1 2))
+          (g (oref arg1 2 0))(h (oref arg1 2 1))(i (oref arg1 2 2)))
+      (dolist (arg args)
+        (decf a (oref arg 0 0))
+        (decf b (oref arg 0 1))
+        (decf c (oref arg 0 2))
+        (decf d (oref arg 1 0))
+        (decf e (oref arg 1 1))
+        (decf f (oref arg 1 2))
+        (decf g (oref arg 2 0))
+        (decf h (oref arg 2 1))
+        (decf i (oref arg 2 2)))
+      (o a b c d e f g h i))));;o-
+
+
+(DEFUN o*v (OPER VECT)
+  "
+    ((a b c) (d e f) (g h i)) (x y z)
+    (ax+dy+gz bx+ey+hz cx+fy+iz)
+"
+  (let ((x (aref vect 0))(y (aref vect 1))(z (aref vect 2)))
+    (v (+ (* x (oref oper 0 0))
+          (* y (oref oper 1 0))
+          (* z (oref oper 2 0)))
+       (+ (* x (oref oper 0 1))
+          (* y (oref oper 1 1))
+          (* z (oref oper 2 1)))
+       (+ (* x (oref oper 0 2))
+          (* y (oref oper 1 2))
+          (* z (oref oper 2 2))))));;o*v
+
+
+
+
+(DEFVAR origin #(0 0 0))
+(DEFVAR X-AXIS #(1 0 0))
+(DEFVAR Y-AXIS #(0 1 0))
+(DEFVAR Z-AXIS #(0 0 1))
+(DEFVAR -X-AXIS #(-1 0 0))
+(DEFVAR -Y-AXIS #(0 -1 0))
+(DEFVAR -Z-AXIS #(0 0 -1))
+(DEFVAR X-AXIS-QUARTER-TURN #(#(1 0 0) #(0 0 1) #(0 -1 0))) ; x y z --> x z -y
+(DEFVAR Y-AXIS-QUARTER-TURN #(#(0 0 -1) #(0 1 0) #(1 0 0))) ; x y z --> -z y x
+(DEFVAR Z-AXIS-QUARTER-TURN #(#(0 1 0) #(-1 0 0) #(0 0 1))) ; x y z --> y -x z
+(DEFVAR -X-AXIS-QUARTER-TURN #(#(-1 0 0) #(0 0 -1) #(0 1 0)))
+(DEFVAR -Y-AXIS-QUARTER-TURN #(#(0 0 1) #(0 -1 0) #(-1 0 0)))
+(DEFVAR -Z-AXIS-QUARTER-TURN #(#(0 -1 0) #(1 0 0) #(0 0 -1))
+(DEFVAR identity #(#(1 0 0) #(0 1 0) #(0 0 1))) ; also the base.
+
+
+(DEFUN QUARTER-TURN (VECT)
+  (COND
+   ((EQUAL VECT X-AXIS) X-AXIS-QUARTER-TURN)
+   ((EQUAL VECT Y-AXIS) Y-AXIS-QUARTER-TURN)
+   ((EQUAL VECT Z-AXIS) Z-AXIS-QUARTER-TURN)
+   ((EQUAL VECT -X-AXIS) -X-AXIS-QUARTER-TURN)
+   ((EQUAL VECT -Y-AXIS) -Y-AXIS-QUARTER-TURN)
+   ((EQUAL VECT -Z-AXIS) -Z-AXIS-QUARTER-TURN)
+   (T (ERROR "quarter-turn: general case not implemented~% vect must be a base vector or opposite thereof~%"))));;QUARTER-TURN
+
+
+
+
+(DEFUN CHECK-OPERATOR (OPERATOR ARGUMENT EXPECTED)
+  (FORMAT T "[~s]~a = ~a =? ~a (~a)~%"
+          OPERATOR ARGUMENT
+          (o*v OPERATOR ARGUMENT) EXPECTED
+          (EQUAL (o*v OPERATOR ARGUMENT) EXPECTED)));;CHECK-OPERATOR
+
+
+(DEFUN CHECK ()
+  (CHECK-OPERATOR X-AXIS-QUARTER-TURN X-AXIS X-AXIS)
+  (CHECK-OPERATOR X-AXIS-QUARTER-TURN Y-AXIS Z-AXIS)
+  (CHECK-OPERATOR X-AXIS-QUARTER-TURN Z-AXIS (v- Y-AXIS))
+  (CHECK-OPERATOR Y-AXIS-QUARTER-TURN X-AXIS (v- Z-AXIS))
+  (CHECK-OPERATOR Y-AXIS-QUARTER-TURN Y-AXIS Y-AXIS)
+  (CHECK-OPERATOR Y-AXIS-QUARTER-TURN Z-AXIS X-AXIS)
+  (CHECK-OPERATOR Z-AXIS-QUARTER-TURN X-AXIS Y-AXIS)
+  (CHECK-OPERATOR Z-AXIS-QUARTER-TURN Y-AXIS (v- X-AXIS))
+  (CHECK-OPERATOR Z-AXIS-QUARTER-TURN Z-AXIS Z-AXIS)
+  );;CHECK
+
+
+
+
+
+;; A box is list with (car box) containing the left-bottom-far most
+;; place and (cdr box) containing the right-top-near most place of the
+;; box. Each is a list of three coordinate (x y z).
+;; Sides of the box are parallel to the base planes.
+
+
+(defun make-box (lbf rtn) (cons lbf rtn))
+(defmacro box-lbf (box) `(car ,box))
+(defmacro box-rtn (box) `(cdr ,box))
+
+
+(DEFUN BOX-SIZE   (BOX)
+  (let ((d (v- (box-lbf BOX) (box-rtn BOX))))
+    (abs (* (aref d 0) (aref d 1) (aref d 2)))))
+
+
+(DEFUN BOX-EXPAND (BOX POS)
+  (LET ((LBF (box-lbf BOX)) (RTN (box-rtn BOX)) )
+    (make-box (v (MIN (aref POS 0) (aref LBF 0))
+                 (MIN (aref POS 1) (aref LBF 1))
+                 (MIN (aref POS 2) (aref LBF 2 )))
+              (v (MAX (aref POS 0) (aref RTN 0))
+                 (MAX (aref POS 1) (aref RTN 1))
+                 (MAX (aref POS 2) (aref RTN 2))))))
+
+
+(defun check-box-expand ()
+  (PRINT (BOX-EXPAND (make-box origin origin) (v 0   0   0) ))
+  (PRINT (BOX-EXPAND (make-box origin origin) (v 1   0   0) ))
+  (PRINT (BOX-EXPAND (make-box origin origin) (v 0   1   0) ))
+  (PRINT (BOX-EXPAND (make-box origin origin) (v 0   0   1) ))
+  (PRINT (BOX-EXPAND (make-box origin origin) (v -1  0   0) ))
+  (PRINT (BOX-EXPAND (make-box origin origin) (v 0  -1   0) ))
+  (PRINT (BOX-EXPAND (make-box origin origin) (v 0   0  -1) ))
+  (PRINT (BOX-EXPAND (make-box origin origin) (v 1   0   0) ))
+  (PRINT (BOX-EXPAND (make-box origin origin) (v 1   1   0) ))
+  (PRINT (BOX-EXPAND (make-box origin origin) (v 1   0   1) ))
+  (PRINT (BOX-EXPAND (make-box origin origin) (v -1  0   0) ))
+  (PRINT (BOX-EXPAND (make-box origin origin) (v 1  -1   0) ))
+  (PRINT (BOX-EXPAND (make-box origin origin) (v 1   0  -1) ))
+  (PRINT (BOX-EXPAND (make-box origin origin) (v 1   1   0) ))
+  (PRINT (BOX-EXPAND (make-box origin origin) (v 0   1   0) ))
+  (PRINT (BOX-EXPAND (make-box origin origin) (v 0   1   1) ))
+  (PRINT (BOX-EXPAND (make-box origin origin) (v -1  1   0) ))
+  (PRINT (BOX-EXPAND (make-box origin origin) (v 0  -1   0) ))
+  (PRINT (BOX-EXPAND (make-box origin origin) (v 0   1  -1) ))
+  (PRINT (BOX-EXPAND (make-box origin origin) (v 1   0   1) ))
+  (PRINT (BOX-EXPAND (make-box origin origin) (v 0   1   1) ))
+  (PRINT (BOX-EXPAND (make-box origin origin) (v 0   0   1) ))
+  (PRINT (BOX-EXPAND (make-box origin origin) (v -1  0   1) ))
+  (PRINT (BOX-EXPAND (make-box origin origin) (v 0  -1   1) ))
+  (PRINT (BOX-EXPAND (make-box origin origin) (v 0   0  -1) ))
+  )
+
+
+
+;;----------------------------------------------------------------------
+
+;; orientation = tri-vecteur ((1 0 0) (0 1 0) (0 0 1))
+;; axe         = vecteur     (1 0 0)
+;;
+;;
+
+
+(DEFCLASS CUBE ()
+  (
+   ;;Invariants:
+   ;; coordinate    = input-cube.coordinate+input-cube.outputVector
+   ;; orientation = rotation(input-cube.axe,input-cube.orientation)
+   (INDEX        :ACCESSOR INDEX         :INITFORM 0)
+   (COORDINATE   :ACCESSOR COORDINATE    :INITFORM '(0 0 0))
+   (ORIENTATION  :ACCESSOR ORIENTATION   :INITFORM BASIS)
+   (INPUT-SIDE   :ACCESSOR INPUT-SIDE    :INITFORM 0)
+   (INPUT-CUBE   :ACCESSOR INPUT-CUBE    :INITFORM '())
+   (OUTPUT-SIDE  :ACCESSOR OUTPUT-SIDE   :INITFORM 0)
+   (OUTPUT-CUBE  :ACCESSOR OUTPUT-CUBE   :INITFORM '())
+   )
+  );;CUBE
+
+
+;; use the following line to update the class summary, but skip the first
+;; semicolon.
+;; egrep 'defclass|defmethod' $file |sed -e 's/(defclass \(.*\)/	(format t "class \1~%")/' -e 's/(defmethod\(.*\)/    (format t "\1~%")/' -e 's/;/~%  /g'|grep -v egrep
+
+
+(DEFMETHOD SET-INDEX           ((SELF CUBE) INDEX)
+  (SETF (INDEX SELF) INDEX)
+  (IF (NULL (OUTPUT-CUBE SELF))
+    INDEX
+    (SET-INDEX (OUTPUT-CUBE SELF) (1+ INDEX))));;SET-INDEX
+
+
+(DEFMETHOD SET-COORDINATE       ((SELF CUBE) NEWCOORDINATE)
+  (SETF (COORDINATE SELF) NEWCOORDINATE)
+  (IF (NULL (OUTPUT-CUBE SELF))
+    NEWCOORDINATE
+    (SET-COORDINATE (OUTPUT-CUBE SELF)
+                    (ADD-VECTOR NEWCOORDINATE (OUTPUT-VECTOR SELF)))));;SET-COORDINATE
+
+
+(DEFMETHOD INPUT-VECTOR         ((SELF CUBE))
+  (IF (= 0 (INPUT-SIDE SELF))
+    '(0 0 0)
+    (OPPOSITE-VECTOR (OUTPUT-VECTOR (INPUT-CUBE SELF)))));;INPUT-VECTOR
+
+
+(DEFMETHOD OUTPUT-VECTOR        ((SELF CUBE))
+  (COND
+   ((= 0 (OUTPUT-SIDE SELF)) '(0 0 0))
+   ((= 1 (OUTPUT-SIDE SELF))
+    (OPPOSITE-VECTOR (FIRST (ORIENTATION SELF))))
+   ((= 2 (OUTPUT-SIDE SELF))
+    (OPPOSITE-VECTOR (SECOND (ORIENTATION SELF))))
+   ((= 3 (OUTPUT-SIDE SELF))
+    (OPPOSITE-VECTOR (THIRD (ORIENTATION SELF))))
+   ((= 4 (OUTPUT-SIDE SELF))
+    (THIRD (ORIENTATION SELF)))
+   ((= 5 (OUTPUT-SIDE SELF))
+    (SECOND (ORIENTATION SELF)))
+   ((= 6 (OUTPUT-SIDE SELF))
+    (FIRST (ORIENTATION SELF)))
+   (T (ERROR "Invalid output-side (~a) for ~a~%"
+             (OUTPUT-SIDE SELF) SELF)
+      '(0 0 0))));;OUTPUT-VECTOR
+
+
+(DEFMETHOD COLLIDE  ((SELF CUBE) OTHERCOORD)
+  (COND
+   ((NULL SELF) NIL)
+   ((EQUAL (COORDINATE SELF) OTHERCOORD) T)
+   ((NULL (INPUT-CUBE SELF)) NIL)
+   (T (COLLIDE (INPUT-CUBE SELF) OTHERCOORD)))
+  );;COLLIDE
+
+
+(DEFMETHOD ROLL     ((SELF CUBE))
+  (SETF (ORIENTATION SELF)
+		(MAPCAR
+         (LAMBDA (V)
+           (APPLY-OPERATOR (QUARTER-TURN (OUTPUT-VECTOR (INPUT-CUBE SELF))) V))
+         (ORIENTATION SELF)))
+  (SET-COORDINATE SELF (COORDINATE SELF))
+  );;ROLL
+
+
+(DEFMETHOD SOLVE   ((SELF CUBE) TRY) ;; try in [0..3+1]
+  (FORMAT T "--> ~a~%" (MAPCAR 'COORDINATE (INPUT-CUBE SELF)))
+  (COND
+   ((NULL SELF)    T)
+   ((> TRY 3)      (BLOCK T (ROLL SELF) NIL))
+   ((AND (INPUT-CUBE SELF) (OR
+                            (> (APPLY 'MAX (BOX-SIZE (BOUNDS SELF))) 3)
+                            (COLLIDE (INPUT-CUBE SELF) (COORDINATE SELF))))
+    (ROLL SELF)
+    (SOLVE SELF (1+ TRY)))
+   ((OUTPUT-CUBE SELF)
+    (IF (SOLVE (OUTPUT-CUBE SELF) 0)
+      T
+      (BLOCK T
+        (ROLL SELF)
+        (SOLVE SELF (1+ TRY)))))
+   (T T)
+   ));;SOLVE
+
+
+(DEFMETHOD ADD-OUTPUT-CUBE-TO-SIDE ((SELF CUBE) (NEW-OUTPUT CUBE) SIDE)
+  (SETF (OUTPUT-CUBE SELF) NEW-OUTPUT)
+  (SETF (OUTPUT-SIDE SELF) SIDE)
+  (SETF (ORIENTATION SELF) (ORIENTATION NEW-OUTPUT))
+  (SET-INPUT-CUBE-TO-SIDE NEW-OUTPUT SELF (- 7 SIDE))
+  (SETF (INDEX SELF)     (1- (INDEX NEW-OUTPUT)))
+  (SETF (COORDINATE SELF)
+        (ADD-VECTOR (COORDINATE NEW-OUTPUT)
+                    (OPPOSITE-VECTOR (OUTPUT-VECTOR SELF))))
+  );;ADD-OUTPUT-CUBE-TO-SIDE
+
+
+(DEFMETHOD SET-INPUT-CUBE-TO-SIDE  ((SELF CUBE) (NEW-INPUT CUBE) SIDE)
+  (SETF (INPUT-CUBE SELF) NEW-INPUT)
+  (SETF (INPUT-SIDE SELF) SIDE));;SET-INPUT-CUBE-TO-SIDE
+
+
+(DEFMETHOD BOUNDS              ((SELF CUBE)) ; returns a box.
+  (IF (NULL (INPUT-CUBE SELF))
+    (CONS (COORDINATE SELF) (COORDINATE SELF))
+    (BOX-EXPAND (BOUNDS (INPUT-CUBE SELF)) (COORDINATE SELF))));;BOUNDS
+
+
+(DEFMETHOD REVERSE-CUBES    ((SELF CUBE)) ; reverse the cube list.
+  (LET ((C (INPUT-CUBE SELF)) (S (INPUT-SIDE SELF)))
+    (SETF (INPUT-CUBE SELF) (OUTPUT-CUBE SELF))
+    (SETF (INPUT-SIDE SELF) (OUTPUT-SIDE SELF))
+    (SETF (OUTPUT-CUBE SELF) C)
+    (SETF (OUTPUT-SIDE SELF) S)
+	)
+  (REVERSE-CUBES (INPUT-CUBE SELF)));;REVERSE-CUBES
+
+
+
+(DEFUN MAKE-CUBE-LIST (L)
+  (LET ((CURRENT ()))
+    (MAPcar (LAMBDA (SIDE)
+            (LET ((NEWCUBE    (MAKE-INSTANCE 'CUBE)))
+              (IF (= 0 SIDE)
+                (SETQ CURRENT NEWCUBE)
+                (BLOCK T
+                  (ADD-OUTPUT-CUBE-TO-SIDE NEWCUBE CURRENT SIDE)
+                  (SETQ CURRENT NEWCUBE)))))
+          L)));;MAKE-CUBE-LIST
+
+
+
+;;(setq cubeList (reverse
+;;	(make-cube-list '(0 6 6 2 2 6 6 2 2 6 2 6 2 6 6 2 2 6 2 2 6 2 2 6 2 6 6))))
+;;; (SETQ CUBELIST (REVERSE (MAKE-CUBE-LIST (REVERSE '(6 6 2 2 6 6 2 2 6 2 6 2 6 6 2 2 6 2 2 6 2 2 6 2 6 6 0)))))
+;;; (SET-INDEX (CAR CUBELIST) 1)
+;;; (SET-COORDINATE (CAR CUBELIST) '(0 0 0))
+
+
+
+;;(setq box (bounds (fourth cubeList)))
+;;(mapcar 'coordinate cubeList)
+;;(mapcar 'bounds cubeList)
+;;(mapcar (lambda (cube) (box-size (bounds cube)))cubeList)
+;;(mapcar (lambda (cube) (apply 'max (box-size (bounds cube)))) cubeList)
+;;(mapcar (lambda (cube) (apply 'max (box-size (bounds (output-cube cube))))) (butlast cubeList))
+;;(max (box-size (bounds (output-cube self))))
+;;(mapcar 'output-vector cubeList)
+;;(mapcar 'input-vector cubeList)
+;;(list (equal x-axis '(1 0 0))
+;;(equal y-axis '(0 1 0))
+;;(equal z-axis '(0 0 1)))
+
+
+(defun test-solve ()
+  (let ((CUBELIST (REVERSE (MAKE-CUBE-LIST (REVERSE '(6 6 2 2 6 6 2 2 6 2 6 2 6 6 2 2 6 2 2 6 2 2 6 2 6 6 0))))))
+    (SOLVE (CAR CUBELIST) 0)));;test-solve
+
+
+
+;;;; cube.lisp                        -- 2004-03-19 23:29:09 -- pascal   ;;;;
diff --git a/small-cl-pgms/douze.lisp b/small-cl-pgms/douze.lisp
new file mode 100644
index 0000000..b8b5e43
--- /dev/null
+++ b/small-cl-pgms/douze.lisp
@@ -0,0 +1,371 @@
+;;;; -*- mode:lisp; coding:utf-8 -*-
+;;;;****************************************************************************
+;;;;FILE:               douze.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    A demographic simulator.
+;;;;
+;;;;    Assuming an Adam and an Eve 20 years old each,
+;;;;    assuming the current US life table,
+;;;;    and assuming an "intensive" reproduction rate, with gene selection,
+;;;;    simulate the population growth during 80 years
+;;;;    and draw the final age pyramid.
+;;;;
+;;;;USAGE:
+;;;;
+;;;;    (LOAD (COMPILE-FILE "DOUZE.LISP"))
+;;;;    (COM.INFORMATIMAGO.COMMON-LISP.DOUZE:SIMULATE)
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2004-02-25 <PJB> Added this comment.
+;;;;BUGS
+;;;;LEGAL
+;;;;    Public Domain
+;;;;
+;;;;    This software is in Public Domain.
+;;;;    You're free to do with it as you please.
+;;;;****************************************************************************
+
+(DEFPACKAGE "COM.INFORMATIMAGO.COMMON-LISP.DOUZE"
+  (:DOCUMENTATION "
+    A demographic simulator.
+
+    Assuming an Adam and an Eve 20 years old each,
+    assuming the current US life table,
+    and assuming an \"intensive\" reproduction rate, with gene selection,
+    simulate the population growth during 80 years
+    and draw the final age pyramid.
+
+    Copyright Pascal Bourguignon 2003 - 2004
+    This package is put in the Public Domain.
+    ")
+  (:USE "COMMON-LISP")
+  (:EXPORT "SIMULATE")
+  );;COM.INFORMATIMAGO.COMMON-LISP.DOUZE
+(IN-PACKAGE "COM.INFORMATIMAGO.COMMON-LISP.DOUZE")
+
+(DEFVAR *YEAR* 0)
+(DEFVAR *POPULATION* '())
+(DEFVAR *CEMETERY* '())
+
+
+
+;; http://www.ssa.gov/OACT/STATS/table4c6.html
+
+
+;;; lynx -source http://www.ssa.gov/OACT/STATS/table4c6.html | html-get-tables | sed -n -e '/^[0-9][0-9]*[|][0-9.,|]*$/p' | awk -F\| '{i=$1;male[i]=$2;female[i]=$5;}END{printf "(defparameter *male-dp* (make-array (quote (%d)) :element-type (quote float) :initial-contents (quote (",1+i;for(k=0;k<=i;k++){printf " %f",male[k];} printf "))))\n";printf "(defparameter *female-dp* (make-array (quote (%d)) :element-type (quote float) :initial-contents (quote (",1+i;for(k=0;k<=i;k++){printf " %f",female[k];} printf "))))\n";}'
+
+
+(defparameter *male-dp*
+  (make-array
+   '(120)
+   :element-type (quote float)
+   :initial-contents
+   '(
+     0.008115 0.000531 0.000359 0.000298 0.000232 0.000206 0.000192
+     0.000180 0.000163 0.000141 0.000125 0.000135 0.000191 0.000308
+     0.000467 0.000640 0.000804 0.000954 0.001079 0.001181 0.001285
+     0.001383 0.001437 0.001434 0.001391 0.001333 0.001286 0.001259
+     0.001267 0.001303 0.001350 0.001400 0.001465 0.001546 0.001642
+     0.001754 0.001883 0.002030 0.002196 0.002381 0.002583 0.002802
+     0.003045 0.003312 0.003602 0.003928 0.004272 0.004603 0.004908
+     0.005210 0.005538 0.005926 0.006386 0.006935 0.007568 0.008292
+     0.009083 0.009910 0.010759 0.011663 0.012645 0.013774 0.015117
+     0.016717 0.018541 0.020582 0.022740 0.024910 0.027036 0.029205
+     0.031630 0.034380 0.037348 0.040548 0.044060 0.048038 0.052535
+     0.057502 0.062970 0.069027 0.075760 0.083288 0.091713 0.101108
+     0.111468 0.122752 0.134930 0.147987 0.161928 0.176773 0.192542
+     0.209250 0.226904 0.245500 0.265023 0.284534 0.303801 0.322578
+     0.340612 0.357642 0.375525 0.394301 0.414016 0.434717 0.456452
+     0.479275 0.503239 0.528401 0.554821 0.582562 0.611690 0.642274
+     0.674388 0.708107 0.743513 0.780688 0.819722 0.860709 0.903744
+     0.948931)));;*male-dp*
+
+
+(defparameter *female-dp*
+  (make-array
+   '(120)
+   :element-type (quote float)
+   :initial-contents
+   '(
+     0.006702 0.000458 0.000299 0.000223 0.000167 0.000155 0.000148
+     0.000143 0.000136 0.000128 0.000121 0.000124 0.000144 0.000186
+     0.000243 0.000309 0.000369 0.000416 0.000441 0.000451 0.000459
+     0.000471 0.000480 0.000486 0.000491 0.000496 0.000505 0.000522
+     0.000550 0.000588 0.000632 0.000681 0.000737 0.000800 0.000871
+     0.000949 0.001035 0.001131 0.001237 0.001354 0.001484 0.001623
+     0.001760 0.001894 0.002029 0.002180 0.002353 0.002541 0.002747
+     0.002976 0.003233 0.003523 0.003849 0.004214 0.004621 0.005083
+     0.005594 0.006144 0.006731 0.007369 0.008061 0.008837 0.009729
+     0.010758 0.011909 0.013209 0.014590 0.015949 0.017242 0.018547
+     0.020032 0.021768 0.023697 0.025843 0.028258 0.031071 0.034292
+     0.037840 0.041720 0.046042 0.051013 0.056716 0.063090 0.070175
+     0.078071 0.086897 0.096754 0.107719 0.119836 0.133124 0.147587
+     0.163214 0.179988 0.197882 0.216861 0.236103 0.255356 0.274345
+     0.292777 0.310343 0.328964 0.348701 0.369624 0.391801 0.415309
+     0.440228 0.466641 0.494640 0.524318 0.555777 0.589124 0.624471
+     0.661939 0.701655 0.743513 0.780688 0.819722 0.860709 0.903744
+     0.948931)));;*female-dp*
+
+
+
+(DEFCLASS HUMAN ()
+  (
+   (BIRTHDAY
+    :ACCESSOR BIRTHDAY
+    :INITARG :BIRTHDAY
+    :INITFORM *YEAR*
+    :TYPE     INTEGER
+    :DOCUMENTATION "The year of birth.")
+   )
+  (:DOCUMENTATION "A human.")
+  );;HUMAN
+
+
+(DEFMETHOD AGE ((SELF HUMAN))
+  (- *YEAR* (BIRTHDAY SELF))
+  );;AGE
+
+
+(DEFMETHOD LIVE ((SELF HUMAN))
+  (IF (should-die self)
+    (DIE SELF))
+  );;LIVE
+
+
+(DEFMETHOD DIE ((SELF HUMAN))
+  (SETQ *POPULATION* (DELETE SELF *POPULATION*))
+  (PUSH SELF *CEMETERY*)
+  );;DIE
+
+
+(DEFCLASS MAN (HUMAN)
+  ()
+  (:DOCUMENTATION "A man.")
+  );;MAN
+
+
+(defmethod should-die ((self man))
+  (or (<= (length *male-dp*) (age self))
+      (< (random 1.0) (aref *male-dp* (age self)) ))
+  );;should-die
+
+
+
+(DEFCLASS WOMAN (HUMAN)
+  (
+   (NUMBER-OF-CHILDREN
+    :ACCESSOR NUMBER-OF-CHILDREN
+    :INITFORM 0
+    :TYPE INTEGER
+    :DOCUMENTATION "The number of children brought by this woman.")
+   )
+  (:DOCUMENTATION "A woman.")
+  );;WOMAN
+
+
+(defmethod should-die ((self woman))
+  (or (<= (length *female-dp*) (age self))
+      (< (random 1.0) (aref *female-dp* (age self)) ))
+  );;should-die
+
+
+(DEFMETHOD LIVE ((SELF WOMAN))
+  (IF (AND (<= 20 (AGE SELF))
+           (< (NUMBER-OF-CHILDREN SELF) 12))
+    (GIVE-BIRTH SELF))
+  (CALL-NEXT-METHOD)
+  );;LIVE
+
+
+(DEFMETHOD GIVE-BIRTH ((SELF WOMAN))
+  (WHEN (SOME (LAMBDA (BEING) (AND (TYPEP BEING 'MAN)
+                                   (<= 20 (AGE BEING)))) *POPULATION*)
+    (PUSH (MAKE-INSTANCE (IF (ODDP (RANDOM 2)) 'MAN 'WOMAN)) *POPULATION*))
+  );;GIVE-BIRTH
+
+
+
+(DEFUN FILL-HISTOGRAM (N-SLICE SLICE-WIDTH VALUES)
+  (LET ((HISTOGRAM (MAKE-ARRAY (LIST N-SLICE)
+                               :INITIAL-ELEMENT 0
+                               :ELEMENT-TYPE 'INTEGER)))
+    (DOLIST (VALUE VALUES)
+      (INCF (AREF HISTOGRAM (TRUNCATE VALUE SLICE-WIDTH))))
+    HISTOGRAM)
+  );;FILL-HISTOGRAM
+
+
+(DEFUN MAX-ARRAY (ARRAY)
+  (LET ((RESULT (AREF ARRAY 0)))
+    (DOTIMES (I (LENGTH ARRAY))
+      (SETQ RESULT (MAX RESULT (AREF ARRAY I))))
+    RESULT)
+  );;MAX-ARRAY
+
+
+(DEFUN MAKE-BAR (ALIGNMENT WIDTH VALUE MAX-VALUE)
+  (LET* ((BAR-WIDTH (TRUNCATE (* WIDTH VALUE) MAX-VALUE))
+         (REST (- WIDTH BAR-WIDTH))
+         (LEFT (TRUNCATE REST 2))
+         (LEFT (TRUNCATE REST 2))
+         (RESULT (MAKE-STRING WIDTH)))
+    (CASE ALIGNMENT
+      ((:LEFT)
+       (FILL RESULT (CHARACTER "#") :START 0 :END BAR-WIDTH)
+       (FILL RESULT (CHARACTER " ") :START BAR-WIDTH))
+      ((:CENTER)
+       (FILL RESULT (CHARACTER " ") :START 0 :END LEFT)
+       (FILL RESULT (CHARACTER "#") :START LEFT :END (+ LEFT BAR-WIDTH))
+       (FILL RESULT (CHARACTER " ") :START (+ LEFT BAR-WIDTH)))
+      ((:RIGHT)
+       (FILL RESULT (CHARACTER " ") :START 0 :END (- width BAR-WIDTH))
+       (FILL RESULT (CHARACTER "#") :START (- width BAR-WIDTH))))
+    RESULT)
+  );;MAKE-BAR
+
+
+(DEFUN PRINT-PYRAMID (MEN-AGES DEAD-MEN WOMEN-AGES DEAD-WOMEN)
+  (LET* ((AGE-SLICE 5)
+         (WIDTH 26)
+         (MAX-AGE (MAX (APPLY (FUNCTION MAX) MEN-AGES)
+                       (APPLY (FUNCTION MAX) WOMEN-AGES)))
+         (N-SLICE (TRUNCATE (+ MAX-AGE AGE-SLICE -1) AGE-SLICE))
+         (MEN     (FILL-HISTOGRAM N-SLICE AGE-SLICE MEN-AGES))
+         (WOMEN   (FILL-HISTOGRAM N-SLICE AGE-SLICE WOMEN-AGES))
+         (MAX-COUNT (MAX (MAX-ARRAY MEN) (MAX-ARRAY WOMEN))))
+    (FORMAT T "~10A: ~VA ~4D : ~4D ~vA~%"
+            "Deceased"  width "" DEAD-MEN  DEAD-WOMEN width "")
+    (DOTIMES (J N-SLICE)
+      (let ((I (- n-slice 1 j)))
+        (FORMAT T "~3D to ~3D: ~VA ~4D : ~4D ~VA~%"
+                (* I AGE-SLICE) (1- (* (1+ I) AGE-SLICE))
+                width (MAKE-BAR :RIGHT  width (AREF MEN   I) MAX-COUNT)
+                (aref men i) (aref women i)
+                width (MAKE-BAR :left width (AREF WOMEN I) MAX-COUNT)))
+      ))
+  );;PRINT-PYRAMID
+
+
+
+;;
+;;
+;; Table 1: Abbreviated decennial life table for U.S. Males.
+;; From: National Center for Health Statistics (1997).
+;; -----------------------------------------------------------
+;;   x     l(x)  d(x)     q(x)     m(x)   L(x)     T(x)   e(x)
+;; -----------------------------------------------------------
+;;   0   100000  1039  0.01039  0.01044  99052  7182893   71.8
+;;   1    98961    77  0.00078  0.00078  98922  7083841   71.6
+;;   2    98883    53  0.00054  0.00054  98857  6984919   70.6
+;;   3    98830    41  0.00042  0.00042  98809  6886062   69.7
+;;   4    98789    34  0.00035  0.00035  98771  6787252   68.7
+;;   5    98754    30  0.00031  0.00031  98739  6688481   67.7
+;;   6    98723    27  0.00028  0.00028  98710  6589742   66.7
+;;   7    98696    25  0.00026  0.00026  98683  6491032   65.8
+;;   8    98670    22  0.00023  0.00023  98659  6392348   64.8
+;;   9    98647    19  0.00020  0.00020  98637  6293689   63.8
+;;  10    98628    16  0.00017  0.00017  98619  6195051   62.8
+;;
+;;  20    97855   151  0.00155  0.00155  97779  5211251   53.3
+;;
+;;  30    96166   197  0.00205  0.00205  96068  4240855   44.1
+;;
+;;  40    93762   295  0.00315  0.00316  93614  3290379   35.1
+;;
+;;  50    89867   566  0.00630  0.00632  89584  2370098   26.4
+;;  51    89301   615  0.00689  0.00691  88993  2280513   25.5
+;;
+;;  60    81381  1294  0.01591  0.01604  80733  1508080   18.5
+;;
+;;  70    64109  2312  0.03607  0.03674  62953   772498   12.0
+;;
+;;  75    51387  2822  0.05492  0.05649  49976   482656    9.4
+;;  76    48565  2886  0.05943  0.06127  47121   432679    8.9
+;;
+;;  80    36750  3044  0.08283  0.08646  35228   261838    7.1
+;;
+;;  90     9878  1823  0.18460  0.20408   8966    38380    3.9
+;;
+;; 100      528   177  0.33505  0.40804    439     1190    2.3
+;; -----------------------------------------------------------
+;;
+;; The columns of the table, from left to right, are:
+;;
+;; x: age
+;;
+;; l(x), "the survivorship function": the number of persons alive at age
+;; x. For example of the original 100,000 U.S. males in the hypothetical
+;; cohort, l(50) = 89,867 (or 89.867%) live to age 50.
+;;
+;; d(x): number of deaths in the interval (x,x+1) for persons alive at
+;; age x. Thus of the l(50)=89,867 persons alive at age 50, d(50) = 566
+;; died prior to age 51.
+;;
+;; q(x): probability of dying at age x. Also known as the (age-specific)
+;; risk of death. Note that q(x) = d(x)/l(x), so, for example, q(50) =
+;; 566 / 89,867 = 0.00630.
+;;
+;; m(x): the age-specific mortality rate. Computed as the number of
+;; deaths at age x divided by the number of person-years at risk at age
+;; x. Note that the mortality rate, m(x), and the probability of death,
+;; q(x), are not identical. For a one year interval they will be close in
+;; value, but m(x) will always be larger.
+;;
+;; L(x): total number of person-years lived by the cohort from age x to
+;; x+1. This is the sum of the years lived by the l(x+1) persons who
+;; survive the interval, and the d(x) persons who die during the
+;; interval. The former contribute exactly 1 year each, while the latter
+;; contribute, on average, approximately half a year. [At age 0 and at
+;; the oldest age, other methods are used; for details see the National
+;; Center for Health Statistics (1997) or Schoen (1988). Note: m(x) =
+;; d(x)/L(x).]
+;;
+;; T(x): total number of person-years lived by the cohort from age x
+;; until all members of the cohort have died. This is the sum of numbers
+;; in the L(x) column from age x to the last row in the table.
+;;
+;; e(x): the (remaining) life expectancy of persons alive at age x,
+;; computed as e(x) = T(x)/l(x). For example, at age 50, the life
+;; expectancy is e(50) = T(50)/l(50) = 2,370,099/89,867 = 26.4.
+
+
+
+(DEFUN PRINT-STATS ()
+  (LET
+      ((MEN        (REMOVE-IF (LAMBDA (BEING) (TYPEP BEING 'MAN))      *POPULATION*))
+       (WOMEN      (REMOVE-IF (LAMBDA (BEING) (NOT (TYPEP BEING 'MAN)))*POPULATION*))
+       (DEAD-MEN   (REMOVE-IF (LAMBDA (BEING) (TYPEP BEING 'MAN))      *CEMETERY*))
+       (DEAD-WOMEN (REMOVE-IF (LAMBDA (BEING) (NOT (TYPEP BEING 'MAN)))*CEMETERY*)))
+    (PRINT-PYRAMID (MAPCAR (FUNCTION AGE) MEN)   (LENGTH DEAD-MEN)
+                   (MAPCAR (FUNCTION AGE) WOMEN) (LENGTH DEAD-WOMEN)))
+  );;PRINT-STATS
+
+
+(DEFUN SIMULATE ()
+  (SETQ *RANDOM-STATE* (MAKE-RANDOM-STATE T))
+  (SETQ *POPULATION* NIL
+        *CEMETERY*   NIL
+        *YEAR*       0)
+  (PUSH (MAKE-INSTANCE 'MAN)   *POPULATION*)
+  (PUSH (MAKE-INSTANCE 'WOMAN) *POPULATION*)
+  (DOTIMES (Y 80)
+    (SETQ *YEAR* (+ 20 Y))
+    (LET* ((MALE (COUNT-IF (LAMBDA (BEING) (TYPEP BEING 'MAN)) *POPULATION*))
+           (TPOP (LENGTH *POPULATION*))
+           (FEMA (- TPOP MALE)))
+      (FORMAT T "Year ~3D : ~5D m + ~5D f = ~5D total (~5D dead)~%"
+              *YEAR* MALE FEMA TPOP (LENGTH *CEMETERY*))
+      (MAPC (LAMBDA (BEING) (LIVE BEING)) (COPY-SEQ *POPULATION*))))
+  (when (< 2 (length *population*))
+    (PRINT-STATS))
+  );;SIMULATE
+
+
+
+;;;; douze.lisp                       -- 2004-03-14 01:38:09 -- pascal   ;;;;
diff --git a/small-cl-pgms/example-soft-opcodes.lisp b/small-cl-pgms/example-soft-opcodes.lisp
new file mode 100644
index 0000000..ad000de
--- /dev/null
+++ b/small-cl-pgms/example-soft-opcodes.lisp
@@ -0,0 +1,812 @@
+;;;; -*- mode:lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE:               example-soft-opcodes.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    Example of a processor with illegal instruction traps allowing
+;;;;    one to implement missing instructions in software.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2011-01-08 <PJB> Created.
+;;;;BUGS
+;;;;LEGAL
+;;;;    GPL
+;;;;
+;;;;    Copyright Pascal J. Bourguignon 2011 - 2011
+;;;;
+;;;;    This program is free software; you can redistribute it and/or
+;;;;    modify it under the terms of the GNU General Public License
+;;;;    as published by the Free Software Foundation; either version
+;;;;    2 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 General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU General Public
+;;;;    License along with this program; if not, write to the Free
+;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;;    Boston, MA 02111-1307 USA
+;;;;**************************************************************************
+
+
+;;; First we define the processor (as a virtual machine here, but the
+;;; same could be done in real hardware).
+
+(deftype word () '(unsigned-byte 64))
+
+(defparameter *memory-size* 65536 "Number of words in the memory")
+
+(defstruct machine
+  (pc          0 :type word)
+  (accumulator 0 :type word)
+  (memory (make-array *memory-size* :element-type 'word :initial-element 0)))
+
+(defun opcode (word)  (ldb (byte  8 56) word))
+(defun src    (word)  (ldb (byte 28 28) word))
+(defun dst    (word)  (ldb (byte 28  0) word))
+
+(defconstant +word-mask+ #xFFFFFFFFFFFFFFFF)
+(defconstant +save-address+             1)
+(defconstant +illegal-instruction-trap+ 2)
+(defconstant +invalid-address-trap+     3)
+
+
+
+(defun valid-address-p (address)
+  (and (<= 0 address) (< address *memory-size*)))
+
+(defun word (value) (logand value +word-mask+))
+
+(defun load-machine (machine address words)
+  "Loads a code vector WORDS in the MACHINE memory at the given ADDRESS."
+  (replace (machine-memory machine) words :start1 address)
+  machine)
+
+(defun dump-machine (machine address length)
+  "Dumps the MACHINE memory starting from ADDRESS, for LENGTH words."
+  (loop
+     :repeat length
+     :for a :from address
+     :do (format t "~4,'0X: ~16,'0X  ~:*~D~%"
+                 a (aref (machine-memory machine) a)))
+  machine)
+
+(defun run (machine &key (verbose nil) (step nil))
+  "Run the machine.
+When verbose is true, prints the instructions and traps executed.
+When step is true, executes only one step."
+  (loop :named :machine :do
+     (let ((pc (machine-pc machine)))
+       (if (valid-address-p pc)
+           (let* ((instruction (aref (machine-memory machine) pc))
+                  (opcode (opcode instruction))
+                  (src    (src    instruction))
+                  (dst    (dst    instruction)))
+             (flet ((trap (machine trap-address)
+                      (when verbose
+                        (format t "~4,'0X: ~A trap~%" (machine-pc machine)
+                                (ecase trap-address
+                                  (#.+illegal-instruction-trap+ "Illegal instruction")
+                                  (#.+invalid-address-trap+     "Invalid address"))))
+                      (shiftf (aref (machine-memory machine) +save-address+)
+                              (machine-pc machine)
+                              (aref (machine-memory machine) trap-address))))
+               #+emacs (progn
+                         (cl-indent 'src-instruction 1)
+                         (cl-indent 'dst-instruction 1)
+                         (cl-indent 'acc-instruction 1)
+                         (cl-indent 'jmp-instruction 1))
+               (macrolet ((src-instruction (instruction-form &body body)
+                            `(cond
+                               ((and verbose (format t "~4,'0X: ~S~%" pc ,instruction-form)))
+                               ((not (valid-address-p src))
+                                (trap machine +invalid-address-trap+))
+                               ((not (zerop dst))
+                                (trap machine +invalid-address-trap+))
+                               (t
+                                ,@body
+                                (incf (machine-pc machine)))))
+                          (dst-instruction (instruction-form &body body)
+                            `(cond
+                               ((and verbose (format t "~4,'0X: ~S~%" pc ,instruction-form)))
+                               ((not (zerop src))
+                                (trap machine +invalid-address-trap+))
+                               ((not (valid-address-p dst))
+                                (trap machine +invalid-address-trap+))
+                               (t
+                                ,@body
+                                (incf (machine-pc machine)))))
+                          (acc-instruction (instruction-form &body body)
+                            `(cond
+                               ((and verbose (format t "~4,'0X: ~S~%" pc ,instruction-form)))
+                               ((not (zerop src))
+                                (trap machine +invalid-address-trap+))
+                               ((not (zerop dst))
+                                (trap machine +invalid-address-trap+))
+                               (t
+                                ,@body
+                                (incf (machine-pc machine)))))
+                          (jmp-instruction (instruction-form &body body)
+                            `(cond
+                               ((and verbose (format t "~4,'0X: ~S~%" pc ,instruction-form)))
+                               ((not (valid-address-p src))
+                                (trap machine +invalid-address-trap+))
+                               ((not (zerop dst))
+                                (trap machine +invalid-address-trap+))
+                               (t
+                                ,@body))))
+                 (if (zerop (ldb (byte 4 0) opcode))
+                     (case (ldb (byte 4 4) opcode)
+                       ;; Notice not all instructions are implemented:
+                       ;; 0000 move src,dst
+                       ;; 0001 load src,acc
+                       (#b0001
+                        (src-instruction `(load ,src acc)
+                          (setf (machine-accumulator machine)
+                                (aref (machine-memory machine) src))))
+                       ;; 0010 store acc,dst
+                       (#b0010
+                        (dst-instruction `(store acc ,dst)
+                          (setf (aref (machine-memory machine) dst)
+                                (machine-accumulator machine))))
+                       ;; 0100 add src,acc
+                       (#b0100
+                        (src-instruction `(add ,src acc)
+                          (setf (machine-accumulator machine)
+                                (word (+ (machine-accumulator machine)
+                                         (aref (machine-memory machine) src))))))
+                       ;; 0101 sub src,acc
+                       ;; 0110 mul src,acc
+                       ;; 0111 div src,acc
+                       ;; 1000 not acc
+                       (#b1000
+                        (acc-instruction `(not acc)
+                          (setf (machine-accumulator machine)
+                                (word (lognot (machine-accumulator machine))))))
+                       ;; 1001 neg acc
+                       ;; (#b10100000 (lshift src acc))
+                       (#b1010
+                        (src-instruction `(lshift ,src acc)
+                          (setf (machine-accumulator machine)
+                                (word (ash (machine-accumulator machine)
+                                           (aref (machine-memory machine) src))))))
+                       ;; (#b10110000 (rshift src acc))
+                       (#b1011
+                        (src-instruction `(rshift ,src acc)
+                          (setf (machine-accumulator machine)
+                                (word (ash (machine-accumulator machine)
+                                           (- (aref (machine-memory machine) src)))))))
+                       ;; (#b11000000 (and src acc))
+                       (#b1100
+                        (src-instruction `(and ,src acc)
+                          (setf (machine-accumulator machine)
+                                (word (logand (machine-accumulator machine)
+                                              (aref (machine-memory machine) src))))))
+                       ;; (#b11010000 (or  src acc))
+                       (#b1101
+                        (src-instruction `(or ,src acc)
+                          (setf (machine-accumulator machine)
+                                (word (logior (machine-accumulator machine)
+                                              (aref (machine-memory machine) src))))))
+                       ;; 1110 jzero src
+                       (#b1110
+                        (jmp-instruction `(jzero ,src)
+                          (if (zerop (machine-accumulator machine))
+                              (setf (machine-pc machine) src)
+                              (incf (machine-pc machine)))))
+                       ;; 1111 jump  src
+                       (#b1111
+                        (jmp-instruction `(jump ,src)
+                          (setf (machine-pc machine) src)))
+                       (otherwise
+                        (trap machine +illegal-instruction-trap+)))
+                     (case opcode
+                       (#b11111111
+                        (jmp-instruction `(halt)
+                          (return-from :machine)))
+                       (otherwise
+                        (trap machine +illegal-instruction-trap+)))))))
+           (trap machine +invalid-address-trap+)))
+     :until step))
+
+
+;;; Next we write a little LAP assembler.
+;;; Notice we may assemble instructions that are not implemented (yet)
+;;; in hardware.
+
+(defparameter *instructions*
+  '((#b00000000 (move src dst))
+    (#b00010000 (load src acc))
+    (#b00100000 (store acc dst))
+    (#b01000000 (add src acc))
+    (#b01010000 (sub src acc))
+    (#b01100000 (mul src acc))
+    (#b01110000 (div src acc))
+    (#b10000000 (not acc))
+    (#b10010000 (neg acc))
+    (#b10100000 (lshift src acc))
+    (#b10110000 (rshift src acc))
+    (#b11000000 (and src acc))
+    (#b11010000 (or  src acc))
+    (#b11100000 (jzero src))
+    (#b11110000 (jump src))
+    (#b11111111 (halt))))
+
+
+(defun encode-instruction (op src dst)
+  (word (dpb op (byte 8 56) (dpb src (byte 28 28) dst))))
+
+(defun sym-eval (expression bindings)
+  (progv
+      (mapcar (function car) bindings)
+      (mapcar (function cdr) bindings)
+    (eval expression)))
+
+(defun validate-operand (pattern operand symtable)
+  (word
+   (ecase pattern
+     ((nil)
+      (if (null operand)
+          0
+          (error "Expected no operand, got ~S in" operand)))
+     ((acc)
+      (if (eql operand 'acc)
+          0
+          (error "Expected ACC, got ~S in" operand)))
+     ((src dst)
+      (sym-eval operand symtable)))))
+
+(defun assemble (address lap)
+  "
+ADDRESS is the base address of the code.
+There's no operator to change the current address in a LAP list.
+
+LAP is a list of symbols or LAP sexps.  Symbols are equaled to the
+current address and entered in the symbol table during the first
+phase.  LAP sexps may be either one of the instructions defined in
+*INSTRUCTIONS*, or one of the two special operator defined below.
+
+In addition to the instruction opcodes, there is:
+    (eql symbol expr)
+to enter a symbol in the symbol table. expr is evaluated right away.
+
+And:
+    (dcl expr ...)
+to store arbitrary values in memory. * is the address of the first one.
+
+The SRC, DST, and EXPR forms are evaluated in Lisp, in a context where
+the symbols in the assembler symbol table are dynamically bound to
+their value, with PROGV and EVAL.  Any lisp expression may be used
+here, executed during the first phase for EQL, and the second phase
+for the other LAP forms.
+
+Return the code vector, and the symbol table,
+an a-list of (symbol . values).
+"
+  (loop
+     :with symtable ; a-list symbol -> address
+     = (loop
+          :named first-phase
+          :with symtable = '()
+          :with address = address
+          :for statement :in lap
+          :if (atom statement) :do (push (cons statement address) symtable)
+          :else :do (case (first statement)
+                      ((eql)
+                       (unless (symbolp (second statement))
+                         (error "EQL requires a symbol as first argument instead of ~S"
+                                (second statement)))
+                       (push (cons (second statement)
+                                   (sym-eval (third statement)
+                                             (acons '* address symtable)))
+                             symtable))
+                      ((dcl) (incf address (length (rest statement))))
+                      (otherwise (incf address)))
+          :finally (return-from first-phase symtable))
+     :with address = address
+     :with code = '()
+     :for statement :in lap
+     :do (when (listp statement)
+           (let* ((op (first statement))
+                  (instruction (find op *instructions* :key (function caadr))))
+             (handler-case
+                 (cond
+                   ((eql op 'eql))
+                   ((eql op 'dcl)
+                    (let ((symtable  (acons '* address symtable)))
+                      (dolist (expr (rest statement))
+                        (push (sym-eval expr symtable) code))
+                      (incf address (length (rest statement)))))
+                   (instruction
+                    (push
+                     (encode-instruction
+                      (first instruction)
+                      (validate-operand (second (second instruction)) (second statement)
+                                        (acons '* address symtable))
+                      (validate-operand (third  (second instruction)) (third  statement)
+                                        (acons '* address symtable)))
+                     code)
+                    (incf address))
+                   (t
+                    (error "Invalid opcode in lap statement")))
+               (error (err)
+                 (error "~A in ~A: ~S" err address statement)))))
+     :finally (return (values (coerce (nreverse code) 'vector)
+                              symtable))))
+
+
+;;; Finally, we can write a few missing instructions in assembler,
+;;; load them in the machine, and write a program using them.
+;;;
+;;; In real machines, these handlers are usually priviledged code, but
+;;; nothing prevents a system to let application define their own
+;;; opcodes too.
+
+
+(defvar *machine* nil
+  "for debugging purpose, we bind the last machine used here.")
+
+(multiple-value-bind (code symtable)
+    (assemble
+     0
+     '(
+       ;; Address 0 contains a jump to start, the machine boots with pc=0
+       (jump start)
+
+       ;; Address 1 is where the PC of the instruction that is invalid
+       ;; or accessed an invalid address is stored.
+       return-pc           (dcl 0)
+
+       ;; Address 2 is where the address of the illegal instruction
+       ;; trap handler is stored.
+       illegal-instruction (dcl process-illegal-instruction)
+
+       ;; Address 3 is where the address of the invalid address
+       ;; trap handler is stored.
+       invalid-address     (dcl process-invalid-address)
+
+       ;; Let's start with the illegal instruction handler:
+       process-illegal-instruction
+
+       (store acc save-acc)                ; save accumulator.
+       ;; We really would need a stack and indirect addressing...
+       ;; but this is to show that it's possible to start with a very
+       ;; crude machine, and we may add higher level instructions first
+       ;; in software.
+                                        ; save the return address
+       (load return-pc acc)                ; get the instruction address
+       (add one acc)                       ; add one for return address
+       (lshift src-offset acc)    ; store it into the return instruction.
+       (add return-op acc)
+       (store acc return-instruction)
+
+       (load return-pc acc)          ; get the instruction address
+       (lshift src-offset acc)       ; store it into the load instruction
+       (add load-op acc)
+       (store acc load-instruction)
+
+       load-instruction (load 0 acc)       ; get the instruction
+       (store acc instruction)
+       (and opcode-lo-mask acc)
+       (jzero lo-ok)
+       (jump really-illegal-instruction)
+
+       lo-ok
+       (load instruction acc)
+       (and opcode-hi-mask acc)
+       (rshift opcode-hi-offset acc)
+       (not acc)               ; remember, we don't have NEG nor SUB yet.
+       (add one acc)           ; so we get two-complement of opcode
+       (store acc -op-hi)
+
+       (load -op-hi acc)
+       (add move-op acc)
+       (jzero move)
+
+       (load -op-hi acc)
+       (add sub-op acc)
+       (jzero sub)
+
+       (load -op-hi acc)
+       (add neg-op acc)
+       (jzero neg)
+
+       (load -op-hi acc)
+       (add or-op acc)
+       (jzero or)
+
+       move-op (dcl #b0000)
+       sub-op  (dcl #b0101)
+       mul-op  (dcl #b0110)
+       div-op  (dcl #b0111)
+       neg-op  (dcl #b1001)
+       or-op   (dcl #b1101)
+
+       -op-hi           (dcl 0)
+       opcode-hi-mask   (dcl #xF000000000000000)
+       opcode-hi-offset (dcl 60)
+       opcode-lo-mask   (dcl #x0F00000000000000)
+
+
+       ;; Not implemented yet, we'd need an OS to do something with those.
+       really-illegal-instruction (halt)
+       process-invalid-address    (halt)
+       ;; eg. process-invalid-address could go to a VM manager.
+
+       neg
+       (load save-acc acc)
+       (not acc)
+       (add one acc)
+       (store acc save-acc)
+       (jump return)
+
+
+       sub
+       (load instruction acc)              ; load the src data
+       (and src-mask acc)                  ; maskout the source address
+       (add load-op acc)
+       (store acc sub-load-data-instruction)
+       sub-load-data-instruction (load 0 acc)
+       (not acc)
+       (add one acc)
+       (add save-acc acc)
+       (store acc save-acc)
+       (jump return)
+
+       or                ; implemented as (not (and (not mem) (not acc)))
+       (load instruction acc)              ; load the src data
+       (and src-mask acc)                  ; maskout the source address
+       (add load-op acc)
+       (store acc or-load-data-instruction)
+       or-load-data-instruction (load 0 acc)
+       (not acc)
+       (store acc or-op)
+       (load save-acc acc)
+       (not acc)
+       (and or-op acc)
+       (not acc)
+       (store acc save-acc)
+       (jump return)
+       or-op (dcl 0)
+
+       move                                ; move src dst
+       (load instruction acc)              ; load the src data:
+       (and src-mask acc)                  ; maskout the source address
+       (add load-op acc)
+       (store acc move-load-data-instruction)
+       move-load-data-instruction (load 0 acc)
+       (store acc data)
+       (load instruction acc)              ; store the data into the dst
+       (and dst-mask acc)
+       (add store-op acc)
+       (store acc store-data-instruction)
+       (load data acc)
+       store-data-instruction (store acc 0)
+
+       return
+       (load save-acc acc)                 ; restore the accumulator:
+       return-instruction (jump 0)         ; and continue
+
+       return-op   (jump 0)
+       load-op     (load 0 acc)
+       store-op    (store acc 0)
+
+       src-offset  (dcl 28)
+       src-mask*   (dcl #xFF0000000FFFFFFF)
+       src-mask    (dcl #x00FFFFFFF0000000)
+       dst-mask    (dcl #x000000000FFFFFFF)
+       one         (dcl 1)
+       save-acc    (dcl 0)
+       instruction (dcl 0)
+       data        (dcl 0)
+
+
+       start ; let's test the new opcodes:
+
+       (move src dst)
+       (move (+ src 1) (+ dst 1))
+       (move (+ src 2) (+ dst 2))
+       (move (+ src 3) (+ dst 3))
+
+       (load pi acc)
+       (neg acc)
+       (store acc -pi)
+
+       (load a acc)
+       (or b acc)
+       (store acc a-or-b)
+
+       (load pi acc)
+       (sub pi-1 acc)
+       (store acc pi-diff)
+
+       (halt)
+
+       ;; We will dump the memory from src to end when the machine
+       ;; halts:
+
+       src     (dcl #x1122334455667788 #xff #xDeadBeef #xFeedBabe)
+       dst     (dcl 0 0 0 0)
+       pi      (dcl 3141592653589)
+       pi-1    (dcl 2141592653589)
+       pi-diff (dcl 1000000000000)
+       -pi     (dcl 0)
+       a       (dcl #xffffffff00000000)
+       b       (dcl #xffff0000ffff0000)
+       a-or-b  (dcl 0)
+       end     (dcl 0)
+
+       ))
+  (let ((start (cdr (assoc 'src symtable)))
+        (end   (cdr (assoc 'end symtable)))
+        (machine (make-machine)))
+    (print code) (terpri) (finish-output)
+    (setf *machine* machine)
+    (load-machine machine 0 code)
+    (let ((*print-length* 10)) (print machine)) (terpri) (finish-output)
+    (run machine :verbose t)
+    (dump-machine machine start (- end start))))
+
+
+#||
+0000: (JUMP 103)
+0067: Illegal instruction trap
+0004: (STORE ACC 100)
+0005: (LOAD 1 ACC)
+0006: (ADD 99 ACC)
+0007: (LSHIFT 95 ACC)
+0008: (ADD 92 ACC)
+0009: (STORE ACC 91)
+000A: (LOAD 1 ACC)
+000B: (LSHIFT 95 ACC)
+000C: (ADD 93 ACC)
+000D: (STORE ACC 14)
+000E: (LOAD 103 ACC)
+000F: (STORE ACC 101)
+0010: (AND 46 ACC)
+0011: (JZERO 19)
+0013: (LOAD 101 ACC)
+0014: (AND 44 ACC)
+0015: (RSHIFT 45 ACC)
+0016: (NOT ACC)
+0017: (ADD 99 ACC)
+0018: (STORE ACC 43)
+0019: (LOAD 43 ACC)
+001A: (ADD 37 ACC)
+001B: (JZERO 78)
+004E: (LOAD 101 ACC)
+004F: (AND 97 ACC)
+0050: (ADD 93 ACC)
+0051: (STORE ACC 82)
+0052: (LOAD 117 ACC)
+0053: (STORE ACC 102)
+0054: (LOAD 101 ACC)
+0055: (AND 98 ACC)
+0056: (ADD 94 ACC)
+0057: (STORE ACC 89)
+0058: (LOAD 102 ACC)
+0059: (STORE ACC 121)
+005A: (LOAD 100 ACC)
+005B: (JUMP 104)
+0068: Illegal instruction trap
+0004: (STORE ACC 100)
+0005: (LOAD 1 ACC)
+0006: (ADD 99 ACC)
+0007: (LSHIFT 95 ACC)
+0008: (ADD 92 ACC)
+0009: (STORE ACC 91)
+000A: (LOAD 1 ACC)
+000B: (LSHIFT 95 ACC)
+000C: (ADD 93 ACC)
+000D: (STORE ACC 14)
+000E: (LOAD 104 ACC)
+000F: (STORE ACC 101)
+0010: (AND 46 ACC)
+0011: (JZERO 19)
+0013: (LOAD 101 ACC)
+0014: (AND 44 ACC)
+0015: (RSHIFT 45 ACC)
+0016: (NOT ACC)
+0017: (ADD 99 ACC)
+0018: (STORE ACC 43)
+0019: (LOAD 43 ACC)
+001A: (ADD 37 ACC)
+001B: (JZERO 78)
+004E: (LOAD 101 ACC)
+004F: (AND 97 ACC)
+0050: (ADD 93 ACC)
+0051: (STORE ACC 82)
+0052: (LOAD 118 ACC)
+0053: (STORE ACC 102)
+0054: (LOAD 101 ACC)
+0055: (AND 98 ACC)
+0056: (ADD 94 ACC)
+0057: (STORE ACC 89)
+0058: (LOAD 102 ACC)
+0059: (STORE ACC 122)
+005A: (LOAD 100 ACC)
+005B: (JUMP 105)
+0069: Illegal instruction trap
+0004: (STORE ACC 100)
+0005: (LOAD 1 ACC)
+0006: (ADD 99 ACC)
+0007: (LSHIFT 95 ACC)
+0008: (ADD 92 ACC)
+0009: (STORE ACC 91)
+000A: (LOAD 1 ACC)
+000B: (LSHIFT 95 ACC)
+000C: (ADD 93 ACC)
+000D: (STORE ACC 14)
+000E: (LOAD 105 ACC)
+000F: (STORE ACC 101)
+0010: (AND 46 ACC)
+0011: (JZERO 19)
+0013: (LOAD 101 ACC)
+0014: (AND 44 ACC)
+0015: (RSHIFT 45 ACC)
+0016: (NOT ACC)
+0017: (ADD 99 ACC)
+0018: (STORE ACC 43)
+0019: (LOAD 43 ACC)
+001A: (ADD 37 ACC)
+001B: (JZERO 78)
+004E: (LOAD 101 ACC)
+004F: (AND 97 ACC)
+0050: (ADD 93 ACC)
+0051: (STORE ACC 82)
+0052: (LOAD 119 ACC)
+0053: (STORE ACC 102)
+0054: (LOAD 101 ACC)
+0055: (AND 98 ACC)
+0056: (ADD 94 ACC)
+0057: (STORE ACC 89)
+0058: (LOAD 102 ACC)
+0059: (STORE ACC 123)
+005A: (LOAD 100 ACC)
+005B: (JUMP 106)
+006A: Illegal instruction trap
+0004: (STORE ACC 100)
+0005: (LOAD 1 ACC)
+0006: (ADD 99 ACC)
+0007: (LSHIFT 95 ACC)
+0008: (ADD 92 ACC)
+0009: (STORE ACC 91)
+000A: (LOAD 1 ACC)
+000B: (LSHIFT 95 ACC)
+000C: (ADD 93 ACC)
+000D: (STORE ACC 14)
+000E: (LOAD 106 ACC)
+000F: (STORE ACC 101)
+0010: (AND 46 ACC)
+0011: (JZERO 19)
+0013: (LOAD 101 ACC)
+0014: (AND 44 ACC)
+0015: (RSHIFT 45 ACC)
+0016: (NOT ACC)
+0017: (ADD 99 ACC)
+0018: (STORE ACC 43)
+0019: (LOAD 43 ACC)
+001A: (ADD 37 ACC)
+001B: (JZERO 78)
+004E: (LOAD 101 ACC)
+004F: (AND 97 ACC)
+0050: (ADD 93 ACC)
+0051: (STORE ACC 82)
+0052: (LOAD 120 ACC)
+0053: (STORE ACC 102)
+0054: (LOAD 101 ACC)
+0055: (AND 98 ACC)
+0056: (ADD 94 ACC)
+0057: (STORE ACC 89)
+0058: (LOAD 102 ACC)
+0059: (STORE ACC 124)
+005A: (LOAD 100 ACC)
+005B: (JUMP 107)
+006B: (LOAD 125 ACC)
+006C: Illegal instruction trap
+0004: (STORE ACC 100)
+0005: (LOAD 1 ACC)
+0006: (ADD 99 ACC)
+0007: (LSHIFT 95 ACC)
+0008: (ADD 92 ACC)
+0009: (STORE ACC 91)
+000A: (LOAD 1 ACC)
+000B: (LSHIFT 95 ACC)
+000C: (ADD 93 ACC)
+000D: (STORE ACC 14)
+000E: (LOAD 108 ACC)
+000F: (STORE ACC 101)
+0010: (AND 46 ACC)
+0011: (JZERO 19)
+0013: (LOAD 101 ACC)
+0014: (AND 44 ACC)
+0015: (RSHIFT 45 ACC)
+0016: (NOT ACC)
+0017: (ADD 99 ACC)
+0018: (STORE ACC 43)
+0019: (LOAD 43 ACC)
+001A: (ADD 37 ACC)
+001B: (JZERO 78)
+001C: (LOAD 43 ACC)
+001D: (ADD 38 ACC)
+001E: (JZERO 54)
+001F: (LOAD 43 ACC)
+0020: (ADD 41 ACC)
+0021: (JZERO 49)
+0031: (LOAD 100 ACC)
+0032: (NOT ACC)
+0033: (ADD 99 ACC)
+0034: (STORE ACC 100)
+0035: (JUMP 90)
+005A: (LOAD 100 ACC)
+005B: (JUMP 109)
+006D: (STORE ACC 128)
+006E: (LOAD 129 ACC)
+006F: (OR 130 ACC)
+0070: (STORE ACC 131)
+0071: (LOAD 125 ACC)
+0072: Illegal instruction trap
+0004: (STORE ACC 100)
+0005: (LOAD 1 ACC)
+0006: (ADD 99 ACC)
+0007: (LSHIFT 95 ACC)
+0008: (ADD 92 ACC)
+0009: (STORE ACC 91)
+000A: (LOAD 1 ACC)
+000B: (LSHIFT 95 ACC)
+000C: (ADD 93 ACC)
+000D: (STORE ACC 14)
+000E: (LOAD 114 ACC)
+000F: (STORE ACC 101)
+0010: (AND 46 ACC)
+0011: (JZERO 19)
+0013: (LOAD 101 ACC)
+0014: (AND 44 ACC)
+0015: (RSHIFT 45 ACC)
+0016: (NOT ACC)
+0017: (ADD 99 ACC)
+0018: (STORE ACC 43)
+0019: (LOAD 43 ACC)
+001A: (ADD 37 ACC)
+001B: (JZERO 78)
+001C: (LOAD 43 ACC)
+001D: (ADD 38 ACC)
+001E: (JZERO 54)
+0036: (LOAD 101 ACC)
+0037: (AND 97 ACC)
+0038: (ADD 93 ACC)
+0039: (STORE ACC 58)
+003A: (LOAD 126 ACC)
+003B: (NOT ACC)
+003C: (ADD 99 ACC)
+003D: (ADD 100 ACC)
+003E: (STORE ACC 100)
+003F: (JUMP 90)
+005A: (LOAD 100 ACC)
+005B: (JUMP 115)
+0073: (STORE ACC 127)
+0074: (HALT)
+0075: 1122334455667788  1234605616436508552
+0076: 00000000000000FF  255
+0077: 00000000DEADBEEF  3735928559
+0078: 00000000FEEDBABE  4276992702
+0079: 1122334455667788  1234605616436508552
+007A: 00000000000000FF  255
+007B: 00000000DEADBEEF  3735928559
+007C: 00000000FEEDBABE  4276992702
+007D: 000002DB75839F15  3141592653589
+007E: 000001F2A0DE8F15  2141592653589
+007F: 000000E8D4A51000  1000000000000
+0080: FFFFFD248A7C60EB  18446740932116898027
+0081: FFFFFFFF00000000  18446744069414584320
+0082: FFFF0000FFFF0000  18446462603027742720
+0083: FFFFFFFFFFFF0000  18446744073709486080
+
+||#
diff --git a/small-cl-pgms/geek-day/Makefile b/small-cl-pgms/geek-day/Makefile
new file mode 100644
index 0000000..47d6940
--- /dev/null
+++ b/small-cl-pgms/geek-day/Makefile
@@ -0,0 +1,65 @@
+#*****************************************************************************
+#FILE:               Makefile
+#LANGUAGE:           makefile
+#SYSTEM:             POSIX
+#USER-INTERFACE:     NONE
+#DESCRIPTION
+#
+#    XXX
+#
+#AUTHORS
+#    <PJB> Pascal Bourguignon <pjb@informatimago.com>
+#MODIFICATIONS
+#    2004-01-17 <PJB> Fixed Makefile.
+#    2004-01-17 <PJB> Created
+#BUGS
+#LEGAL
+#    GPL
+#
+#    Copyright Pascal Bourguignon 2004 - 2004
+#
+#    This program is free software; you can redistribute it and/or
+#    modify it under the terms of the GNU General Public License
+#    as published by the Free Software Foundation; either version
+#    2 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 General Public License for more details.
+#
+#    You should have received a copy of the GNU General Public
+#    License along with this program; if not, write to the Free
+#    Software Foundation, Inc., 59 Temple Place, Suite 330,
+#    Boston, MA 02111-1307 USA
+#*****************************************************************************
+
+CLISP_SCRIPTS = geek-day
+CLISP_SOURCES = geek-day.lisp
+
+geek-day_PKGNAME = COM.INFORMATIMAGO.COMMON-LISP.GEEK-DAY
+geek-day_ROOT    = geek-day.fas
+geek-day_CLISP_OBJECTS = $(geek-day_ROOT)
+
+
+SBCL_PROGRAMS = geek-day-sb
+SBCL_SOURCES  = geek-day.lisp
+
+geek-day-sb_PKGNAME = COM.INFORMATIMAGO.COMMON-LISP.GEEK-DAY
+geek-day-sb_ROOT    = geek-day.fasl
+geek-day-sb_SBCL_OBJECTS = $(geek-day-sb_ROOT)
+
+
+CLISP_LINKINGSET = full
+CLISP_FLAGS = $(CLISP_FLAGS_DEFAULT) -K $(CLISP_LINKINGSET)
+CMUCL_FLAGS = $(CMUCL_FLAGS_DEFAULT)
+SBCL_FLAGS = $(SBCL_FLAGS_DEFAULT)
+
+all :: scripts programs
+install :: all install-scripts install-programs
+
+include $(MAKEDIR)/lisp
+-include Makefile.depend
+
+
+#### Makefile                         --                     --          ####
diff --git a/small-cl-pgms/geek-day/README b/small-cl-pgms/geek-day/README
new file mode 100644
index 0000000..a49a28e
--- /dev/null
+++ b/small-cl-pgms/geek-day/README
@@ -0,0 +1,8 @@
+Get common/makedir makefiles with:
+
+    cvs -z3 -d :pserver:anonymous@cvs.informatimago.com:/local/cvs/public/chrooted-cvs/cvs co common/makedir
+
+and then compile with:
+
+    MAKEDIR=common/makedir make
+
diff --git a/small-cl-pgms/geek-day/geek-day.gif b/small-cl-pgms/geek-day/geek-day.gif
new file mode 100644
index 0000000..6e3d1dc
Binary files /dev/null and b/small-cl-pgms/geek-day/geek-day.gif differ
diff --git a/small-cl-pgms/geek-day/geek-day.lisp b/small-cl-pgms/geek-day/geek-day.lisp
new file mode 100644
index 0000000..9796ff9
--- /dev/null
+++ b/small-cl-pgms/geek-day/geek-day.lisp
@@ -0,0 +1,361 @@
+;;****************************************************************************
+;;FILE:              geek-day.lisp
+;;LANGUAGE:          Common-Lisp
+;;SYSTEM:            UNIX
+;;USER-INTERFACE:    UNIX
+;;DESCRIPTION
+;;    This programs plays geek-day
+;;    http://ars.userfriendly.org/cartoons/?id=20021215
+;;USAGE
+;;
+;;AUTHORS
+;;    <PJB> Pascal J. Bourguignon
+;;MODIFICATIONS
+;;    2002-12-15 <PJB> Created.
+;;BUGS
+;;LEGAL
+;;    Copyright Pascal J. Bourguignon 2002 - 2002
+;;
+;;    This script is free software; you can redistribute it and/or
+;;    modify it under the terms of the GNU  General Public
+;;    License as published by the Free Software Foundation; either
+;;    version 2 of the License, or (at your option) any later version.
+;;
+;;    This script 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
+;;    General Public License for more details.
+;;
+;;    You should have received a copy of the GNU General Public
+;;    License along with this library; see the file COPYING.LIB.
+;;    If not, write to the Free Software Foundation,
+;;    59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+;;****************************************************************************
+
+(DEFINE-PACKAGE COM.INFORMATIMAGO.COMMON-LISP.GEEK-DAY
+  (:NICKNAMES GEEK-DAY)
+  (:DOCUMENTATION "This programs plays geek-day.
+    http://ars.userfriendly.org/cartoons/?id=20021215")
+  (:FROM COMMON-LISP :IMPORT :ALL)
+  (:EXPORT
+   PLAY-GEEK-DAY MAIN
+   ;; low-level:
+   PLAYER LOST UPDATE-SANITY UPDATE-POPULARITY HAVE-BREAKFAST
+   HAVE-SHOWER CHOOSE-BACKWARD-OR-FORWARD RANDOMIZER SQUARE-LIST
+   GEEK-DAY  INITIALIZE PLAY )
+  );;COM.INFORMATIMAGO.COMMON-LISP.GEEK-DAY
+
+
+(DEFGENERIC LOST (A))
+(DEFGENERIC UPDATE-SANITY (A B))
+(DEFGENERIC UPDATE-POPULARITY (A B))
+(DEFGENERIC HAVE-BREAKFAST (A))
+(DEFGENERIC HAVE-SHOWER (A))
+(DEFGENERIC CHOOSE-BACKWARD-OR-FORWARD (A))
+(DEFGENERIC PLAY (A))
+(DEFGENERIC LANDING (A B C D))
+(DEFGENERIC TAKE-OFF (A B C D))
+(DEFGENERIC INITIALIZE (A))
+
+
+(DEFCLASS PLAYER NIL
+  (
+   (NAME
+    :INITFORM "Unnamed Player"
+    :INITARG :NAME
+    :ACCESSOR NAME
+    :TYPE STRING
+    :DOCUMENTATION "This player's name.")
+   (POPULARITY
+    :INITFORM 5
+    :INITARG :POPULARITY
+    :ACCESSOR POPULARITY
+    :TYPE INTEGER
+    :DOCUMENTATION "This player's popularity.")
+   (SANITY
+    :INITFORM 5
+    :INITARG :SANITY
+    :ACCESSOR SANITY
+    :TYPE INTEGER
+    :DOCUMENTATION "This player's sanity.")
+   (HAVE-HAD-BREAKFAST
+    :INITFORM NIL
+    :INITARG :HAVE-HAD-BREAKFAST
+    :ACCESSOR HAVE-HAD-BREAKFAST
+    :TYPE (OR NIL T)
+    :DOCUMENTATION "This player have had a breakfast.")
+   (HAVE-HAD-SHOWER
+    :INITFORM NIL
+    :INITARG :HAVE-HAD-SHOWER
+    :ACCESSOR HAVE-HAD-SHOWER
+    :TYPE (OR NIL T)
+    :DOCUMENTATION "This player have had a shower.")
+   )
+  (:DOCUMENTATION "A Player at Geek-Day."));;PLAYER
+
+
+(DEFMETHOD LOST ((SELF PLAYER))
+  (OR (<= (POPULARITY SELF) 0)
+      (<= (SANITY     SELF) 0))
+  );;LOST
+
+
+(DEFMETHOD UPDATE-SANITY ((SELF PLAYER) INCREMENT)
+  (SETF (SANITY SELF) (+ (SANITY SELF) INCREMENT))
+  (FORMAT T "    Your sanity is ~[increased~;decreased~] by ~A.~%"
+          (IF (< INCREMENT 0) 1 0) (ABS INCREMENT))
+  (IF (<=  (SANITY SELF) 0)
+      (FORMAT T "    YOU GO POSTAL AND LOSE!~%~%"))
+  );;UPDATE-SANITY
+
+
+(DEFMETHOD UPDATE-POPULARITY ((SELF PLAYER) INCREMENT)
+  (SETF (POPULARITY SELF) (+ (POPULARITY SELF) INCREMENT))
+  (FORMAT T "    Your popularity is ~[increased~;decreased~] by ~A.~%"
+          (IF (< INCREMENT 0) 1 0) (ABS INCREMENT))
+  (IF (<= (POPULARITY SELF) 0)
+      (FORMAT T "    YOU'RE FIRED!~%~%"))
+  );;UPDATE-POPULARITY
+
+
+(DEFMETHOD HAVE-BREAKFAST ((SELF PLAYER))
+  (SETF (HAVE-HAD-BREAKFAST SELF) T)
+  );;HAVE-BREAKFAST
+
+
+(DEFMETHOD HAVE-SHOWER ((SELF PLAYER))
+  (SETF (HAVE-HAD-SHOWER SELF) T)
+  );;HAVE-SHOWER
+
+
+(DEFMETHOD CHOOSE-BACKWARD-OR-FORWARD ((SELF PLAYER))
+  (FORMAT T "~%~A, please choose backward or forward? " (NAME SELF))
+  (FINISH-OUTPUT *STANDARD-OUTPUT*)
+  (DO ((REP (READ-LINE) (READ-LINE)))
+      ((OR (STRING-EQUAL REP "backward")
+           (STRING-EQUAL REP "forward"))
+       (STRING-EQUAL REP "backward"))
+    (FORMAT T "~%Becareful! Next time, pop-1!~&~A, ~
+               please choose backward or forward? "
+            (NAME SELF)))
+  );;CHOOSE-BACKWARD-OR-FORWARD
+
+
+
+(DEFVAR RANDOM-STATE (MAKE-RANDOM-STATE T))
+
+(DEFUN RANDOMIZER ()
+  (1+ (RANDOM 6 RANDOM-STATE))
+  );;RANDOMIZER
+
+
+
+
+;;("title" (before) (after))
+
+(DEFVAR SQUARE-LIST
+  '(
+    ("Starting blocks."
+     NIL
+     (LAMBDA (SQUARE DICE PLAYER)
+       (FORMAT T "~&    Therefore ~A."
+               (IF (<= 5 DICE) "get out of bed" "keep sleeping"))
+       (IF (<= 5 DICE)
+           (+ DICE SQUARE)
+         SQUARE)))
+
+    ("Ungum your eyes."            ( (POPULARITY +1) ) NIL)
+    ("Get a hot shower."           ( (POPULARITY +3)
+                                     (LAMBDA (PLAYER)
+                                       (HAVE-SHOWER PLAYER)) ) NIL)
+    ("Depilate."                   ( (POPULARITY +1) ) NIL)
+    ("Get a breakfast."            ( (SANITY +3)
+                                     (LAMBDA (PLAYER)
+                                       (HAVE-BREAKFAST PLAYER)) ) NIL)
+    ("Catch the bus."              ( (SANITY -1) (POPULARITY -1) ) NIL)
+    ("Oooh... Brain Engages."
+     NIL
+     (LAMBDA (SQUARE DICE PLAYER)
+       (IF (CHOOSE-BACKWARD-OR-FORWARD PLAYER)
+           (- SQUARE DICE)
+         (+ SQUARE DICE))))
+    ("Arrive \"late\"."            ( (POPULARITY +1) (SANITY -1) ) NIL)
+    ("First problem of the day."   ( (POPULARITY -2) (SANITY -3) ) NIL)
+    ("Called into meeting."        ( (SANITY -4) ) NIL)
+    ("Boss in bad mood."           ( (POPULARITY -2) ) NIL)
+    ("Water cooler break."         ( (LAMBDA (PLAYER)
+                                       (UNLESS (HAVE-HAD-SHOWER PLAYER)
+                                         (UPDATE-POPULARITY PLAYER -3))) ) NIL)
+    ("Caffeine break!"             ( (SANITY +3) ) NIL)
+    ("Caffeine break!"             ( (SANITY +3) ) NIL)
+    ("Co-worker gives you the blame."
+     ( (POPULARITY +2) ) NIL)
+    ("Nap."                        ( (SANITY +4) (POPULARITY -2) ) NIL)
+    ("Wooo! A thouht!"
+     NIL
+     (LAMBDA (SQUARE DICE PLAYER)
+       (IF (CHOOSE-BACKWARD-OR-FORWARD PLAYER)
+           (- SQUARE DICE)
+         (+ SQUARE DICE))))
+    ("Chair breaks."               ( (POPULARITY +2) (SANITY -1) ) NIL)
+    ("Machine locks up."           ( (SANITY -2) ) NIL)
+    ("Power outage."                   ( "It's okay, you're safe here." ) NIL)
+    ("Munchies!"                   ( (LAMBDA (PLAYER)
+                                       (UNLESS (HAVE-HAD-BREAKFAST PLAYER)
+                                         (UPDATE-SANITY PLAYER -2))) ) NIL)
+    ("Caffeine run."               ( (POPULARITY +1) ) NIL)
+    ("Sugar run."                  ( (SANITY +1) ) NIL)
+    ("Co-worker takes credit."     ( (SANITY -3) ) NIL)
+    ("Run to the loo."             ( (SANITY +1) ) NIL)
+    ("Collapse on the couch at home."
+     ("It's over. Start again tomorrow.")
+     (LAMBDA (SQUARE DICE PLAYER)
+       0))
+    ));;SQUARE-LIST
+
+
+(DEFCLASS GEEK-DAY  NIL
+  (
+   (BOARD
+    :INITFORM (MAKE-ARRAY (LENGTH SQUARE-LIST) :INITIAL-CONTENTS SQUARE-LIST)
+    :INITARG :BOARD
+    :ACCESSOR BOARD
+    :DOCUMENTATION "The array of square compounding the game.")
+   (PLAYERS
+    :INITFORM NIL
+    :INITARG :PLAYERS
+    :ACCESSOR PLAYERS
+    :DOCUMENTATION "The list of Player objects.")
+   (MARKERS
+    :INITFORM NIL
+    :ACCESSOR MARKERS
+    :DOCUMENTATION "A list of cons (player . square-index).")
+   )
+  (:DOCUMENTATION "A Geek-Day game."));;GEEK-DAY
+
+
+
+
+
+(DEFMETHOD PLAY ((SELF GEEK-DAY))
+  (DO ()
+      ((NULL (MARKERS SELF)))
+    ;; let's run a turn.
+    (DOLIST (MARKER (MARKERS SELF))
+      ;; let's run a player.
+      (LET* ((PLAYER      (CAR MARKER))
+             (SQUARE      (CDR MARKER))
+             (SQUARE-DATA (AREF (BOARD SELF) SQUARE))
+             )
+        (SETF (CDR MARKER) (TAKE-OFF SELF PLAYER SQUARE SQUARE-DATA))
+        (SETQ SQUARE       (CDR MARKER))
+        (SETQ SQUARE-DATA  (AREF (BOARD SELF) SQUARE))
+        (LANDING SELF PLAYER SQUARE SQUARE-DATA)
+        )) ;;dolist
+    (SETF (MARKERS SELF)
+          (DELETE-IF (LAMBDA (ITEM) (LOST (CAR ITEM))) (MARKERS SELF)))
+    (LET ((LINEFORM "~:(~20A~) ~16A ~16A ~16A~%"))
+      (FORMAT T "~%~%")
+      (FORMAT T LINEFORM  "--------------------"
+              "----------------"  "----------------"  "----------------")
+      (FORMAT T LINEFORM  "Name" "Popularity" "Sanity" "Square")
+      (FORMAT T LINEFORM  "--------------------"
+              "----------------"  "----------------"  "----------------")
+      (DOLIST (PLAYER (PLAYERS SELF))
+        (FORMAT T LINEFORM  (NAME PLAYER) (POPULARITY PLAYER) (SANITY PLAYER)
+                (IF (LOST PLAYER) "Lost" (CDR (ASSOC PLAYER (MARKERS SELF)))))
+        ) ;;dolist
+      (FORMAT T LINEFORM  "--------------------"
+              "----------------"  "----------------"  "----------------")
+      ) ;;let
+    ) ;;do
+  );;PLAY
+
+
+
+(DEFMACRO SQUARE-NAME (SQUARE-DATA) `(CAR   ,SQUARE-DATA))
+(DEFMACRO SQUARE-IN   (SQUARE-DATA) `(CADR  ,SQUARE-DATA))
+(DEFMACRO SQUARE-OUT  (SQUARE-DATA) `(CADDR ,SQUARE-DATA))
+
+
+(DEFUN LAMBDAP (ITEM)
+  (AND (CONSP ITEM) (EQ 'LAMBDA (CAR ITEM))));;LAMBDAP
+
+(DEFMACRO LAMCALL (LAMBDA-EXPR &REST ARGUMENTS)
+  `(FUNCALL  (COERCE ,LAMBDA-EXPR 'FUNCTION) ,@ARGUMENTS));;LAMCALL
+
+
+(DEFMETHOD LANDING ((SELF GEEK-DAY) PLAYER SQUARE SQUARE-DATA)
+  (DECLARE (IGNORE SQUARE))
+  (FORMAT T "~%~%~:(~A~):  ~A~%"
+          (NAME PLAYER) (SQUARE-NAME SQUARE-DATA))
+  (DOLIST (ACTION (SQUARE-IN SQUARE-DATA))
+    (COND
+     ((NULL ACTION))
+     ((STRINGP ACTION)              (FORMAT T "    ~A~%" ACTION) )
+     ((LAMBDAP ACTION)              (LAMCALL ACTION PLAYER) )
+     ((EQ 'POPULARITY (CAR ACTION)) (UPDATE-POPULARITY PLAYER (CADR ACTION)) )
+     ((EQ 'SANITY (CAR ACTION))     (UPDATE-SANITY PLAYER (CADR ACTION)) )
+     (T (ERROR "Invalid action in square-in ~W." ACTION)))
+    );;dolist
+  );;LANDING
+
+
+(DEFMETHOD TAKE-OFF ((SELF GEEK-DAY) PLAYER SQUARE SQUARE-DATA)
+  (LET ((DICE        (RANDOMIZER))
+        (OUT         (SQUARE-OUT SQUARE-DATA))
+        )
+    (FORMAT T "~%~%~:(~A~), you roll and get ~A.~%" (NAME PLAYER) DICE)
+    (MIN (1- (LENGTH (BOARD SELF)))
+               (IF OUT (LAMCALL OUT SQUARE DICE PLAYER)
+                 (+ SQUARE DICE)))
+    ));;TAKE-OFF
+
+
+
+(DEFMETHOD INITIALIZE ((SELF GEEK-DAY))
+  (UNLESS (PLAYERS SELF)
+    (ERROR "Please give me some player with make-instance!"))
+  (SETF (MARKERS SELF)
+        (MAPCAR (LAMBDA (PLAYER) (CONS PLAYER 0)) (PLAYERS SELF)))
+  (DOLIST (MARKER (MARKERS SELF))
+    ;; let's run a player.
+    (LET* ((PLAYER      (CAR MARKER))
+           (SQUARE      (CDR MARKER))
+           (SQUARE-DATA (AREF (BOARD SELF) SQUARE))
+           )
+      (LANDING SELF PLAYER SQUARE SQUARE-DATA)
+      )) ;;DOLIST
+  );;INITIALIZE
+
+
+(DEFUN PLAY-GEEK-DAY (&REST PLAYER-NAMES)
+  (LET ((GAME (MAKE-INSTANCE 'GEEK-DAY
+                  :PLAYERS (MAPCAR (LAMBDA (NAME)
+                                     (MAKE-INSTANCE 'PLAYER :NAME NAME))
+                                   PLAYER-NAMES))) )
+    (DECLARE (TYPE GEEK-DAY GAME))
+    (INITIALIZE GAME)
+    (PLAY GAME))
+  );;PLAY-GEEK-DAY
+
+
+
+(DEFUN MAIN (&rest args)
+  "
+DO:     Ask for the names of the players from the terminal
+        and call PLAY-GEEK-DAY.
+"
+  (declare (ignore args))
+  (FORMAT T "~24%+----------------------------------+~&~
+                 |          G E E K - D A Y         |~&~
+                 +----------------------------------+~&~
+             ~4%~
+             Please enter the names of the players, ~
+             or an empty line to abort: ~&")
+  (LET* ((NAMES-STR (READ-LINE))
+         (NAMES (READ-FROM-STRING (FORMAT NIL "(~A)" NAMES-STR) T '())))
+    (WHEN NAMES
+      (APPLY (FUNCTION PLAY-GEEK-DAY) NAMES))));;MAIN
+
+;;;; geek-day.lisp                    --                     --          ;;;;
diff --git a/small-cl-pgms/ibcl/ibcl-bootstrap.lisp b/small-cl-pgms/ibcl/ibcl-bootstrap.lisp
new file mode 100644
index 0000000..2d314fa
--- /dev/null
+++ b/small-cl-pgms/ibcl/ibcl-bootstrap.lisp
@@ -0,0 +1,75 @@
+;;;;**************************************************************************
+;;;;FILE:               ibcl-bootstrap.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    This script generates an executable saved image environment using
+;;;;    IMAGE-BASED-COMMON-LISP instead of COMMON-LISP.
+;;;;
+;;;;    IBCL Bootstrap
+;;;;
+;;;;    To create the executable image:
+;;;;
+;;;;      clisp -ansi -norc                -i     ibcl-bootstrap.lisp -p "IBCL"
+;;;;      sbcl        --userinit /dev/null --load ibcl-bootstrap.lisp
+;;;;
+;;;;    Then, to launch it, use:
+;;;;
+;;;;      ./ibcl
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2006-07-01 <PJB> Added support to SBCL.
+;;;;BUGS
+;;;;LEGAL
+;;;;    GPL
+;;;;
+;;;;    Copyright Pascal Bourguignon 2006 - 2006
+;;;;
+;;;;    This program is free software; you can redistribute it and/or
+;;;;    modify it under the terms of the GNU General Public License
+;;;;    as published by the Free Software Foundation; either version
+;;;;    2 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 General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU General Public
+;;;;    License along with this program; if not, write to the Free
+;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;;    Boston, MA 02111-1307 USA
+;;;;**************************************************************************
+
+(in-package "COMMON-LISP-USER")
+(load (merge-pathnames #P"ibcl.lisp" *load-pathname*))
+(in-package "COMMON-LISP")
+(rename-package (find-package "COMMON-LISP-USER") "OLD-CL-USER")
+(defpackage "COMMON-LISP-USER"
+  (:nicknames "CL-USER")
+  (:use "IBCL"))
+(in-package "IMAGE-BASED-COMMON-LISP-USER")
+
+
+#+clisp (ext:saveinitmem          "ibcl" :executable t)
+#+sbcl  (sb-ext:SAVE-LISP-AND-DIE
+         "ibcl" :executable t
+         :toplevel (lambda ()
+                     (setf *package* (find-package "COMMON-LISP-USER"))
+                     (delete-package (find-package "OLD-CL-USER"))
+                     (SB-POSIX:PUTENV
+                      (format nil "SBCL_HOME=~A"
+                              (namestring (user-homedir-pathname))))
+                     (SB-IMPL::TOPLEVEL-REPL nil)
+                     (sb-ext:quit 0)))
+#-(or clisp sbcl) (error "How do we save an image in ~A"
+                         (lisp-implementation-type))
+
+
+#+clisp (ext:quit)
+#+sbcl  (sb-ext:quit)
+#-(or clisp sbcl) (error "How do we quit from ~A" (lisp-implementation-type))
diff --git a/small-cl-pgms/ibcl/ibcl.lisp b/small-cl-pgms/ibcl/ibcl.lisp
new file mode 100644
index 0000000..24489ef
--- /dev/null
+++ b/small-cl-pgms/ibcl/ibcl.lisp
@@ -0,0 +1,485 @@
+;;;; Image Based Common Lisp
+;;;;**************************************************************************
+;;;;FILE:               ibcl.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    The package IBCL exports the same symbols as COMMON-LISP, but for
+;;;;    some of the functions of macros modified to track of the source
+;;;;    of the definitions and to be able to edit them from the image,
+;;;;    and to save them in files.
+;;;;
+;;;;    The package IBCL-USER is a virgin package using IBCL instead of CL.
+;;;;
+;;;;    One can work at the REPL, define variables with
+;;;;    DEFCONSTANT, DEFVAR, DEFPARAMETER, macros with DEFMACRO,
+;;;;    and functions with DEFUN, edit macro and function definitions
+;;;;    with ED, and save the image with SAVE-IMAGE.
+;;;;
+;;;;    The function LIST-PACKAGES-WITH-SOURCES returns a list of packages
+;;;;    where some of these variables or functions are defined.
+;;;;    The function GET-SOURCE returns the source form of the given
+;;;;    variable or function.
+;;;;    The function SAVE-SOURCES saves the definitions in a package,
+;;;;    or all the definitions to a file or stream.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2006-07-01 <PJB> Added deftype, defclass.
+;;;;    2006-05-04 <PJB> Added this header. Augmented.
+;;;;BUGS
+;;;;    Missing some def* macros, like define-symbol-macro,
+;;;;    defconditions, defmethod, defgeneric, etc.
+;;;;    Missing some functions, like make-package, rename-package, etc.
+;;;;    See also MOP functions.
+;;;;LEGAL
+;;;;    GPL
+;;;;
+;;;;    Copyright Pascal Bourguignon 2006 - 2006
+;;;;
+;;;;    This program is free software; you can redistribute it and/or
+;;;;    modify it under the terms of the GNU General Public License
+;;;;    as published by the Free Software Foundation; either version
+;;;;    2 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 General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU General Public
+;;;;    License along with this program; if not, write to the Free
+;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;;    Boston, MA 02111-1307 USA
+;;;;**************************************************************************
+
+(cl:defpackage "IMAGE-BASED-COMMON-LISP"
+  (:nicknames "IBCL")
+  (:use "COMMON-LISP")
+  ;; We some symbols from the package #+clisp "EXT" too.
+  (:shadow "DEFPACKAGE"
+           "DEFCONSTANT" "DEFVAR" "DEFPARAMETER"
+           "DEFSTRUCT" "DEFCLASS"
+           "DEFUN" "DEFMACRO" "LAMBDA" "DEFMETHOD"
+           "ED"  "DELETE-PACKAGE"
+           #| TODO: Add define-symbol-macro, defclass, define-condition, etc...
+           make-package, etc...
+           |#)
+  #| See exports at the end. |#)
+(in-package "IMAGE-BASED-COMMON-LISP")
+
+
+(cl:defparameter *map* (make-hash-table)
+  "Maps packages to (cons definitions order)")
+
+(cl:defun delete-package (package-designator)
+  (remhash (find-package package-designator) *map*)
+  (cl:delete-package package-designator))
+
+(cl:defmacro define-package-attribute
+    (name (package-designator record &optional (value nil value-p)) &body body)
+  (let ((pack (gensym)))
+    `(cl:defun ,name (,@(when value-p `(,value)) ,package-designator)
+       (let* ((,pack   (find-package ,package-designator))
+              (,record (gethash ,pack *map*)))
+         (if ,record
+             (progn ,@body)
+             (let ((,record (cons (make-hash-table :test (function equal)) '())))
+               (setf (gethash ,pack *map*) ,record)
+               ,@body))))))
+
+
+(define-package-attribute definitions  (package-designator record) (car record))
+(define-package-attribute order        (package-designator record) (cdr record))
+(define-package-attribute (setf order) (package-designator record value)
+  (setf (cdr record) value))
+
+#||
+(cl:defun definitions (package-designator)
+  (let ((record (gethash (find-package package-designator) *map*)))
+    (if record
+        (car record)
+        (let ((record (cons (make-hash-table :test (function equal)) '())))
+          (setf (gethash (find-package package-designator) *map*) record)
+          (car record)))))
+
+(cl:defun order (package-designator)
+  (let ((record (gethash (find-package package-designator) *map*)))
+    (if record
+        (cdr record)
+        (let ((record (cons (make-hash-table :test (function equal)) '())))
+          (setf (gethash (find-package package-designator) *map*) record)
+          (cdr record)))))
+
+(cl:defun (setf order) (value package-designator)
+  (let ((record (gethash (find-package package-designator) *map*)))
+    (if record
+        (setf (cdr record) value)
+        (let ((record (cons (make-hash-table :test (function equal)) '())))
+          (setf (gethash (find-package package-designator) *map*) record)
+          (setf (cdr record) value)))))
+||#
+
+(cl:defmacro push-on-top (value place &key (test (function eql))
+                                &environment env)
+  (multiple-value-bind (vars vals store-vars writer-form reader-form)
+      (get-setf-expansion place env)
+    (let ((vvalue (gensym)))
+      `(let* ((,vvalue ,value)
+              ,@(mapcar (function list) vars vals)
+              (,(car store-vars)  (cons ,vvalue (delete ,vvalue ,reader-form
+                                                        :test ,test))))
+         ,writer-form))))
+
+
+;;          makunbound                                 function
+;;          fmakunbound                                function
+;;          delete-package                             function
+;;          ...
+;;
+;; done     DEFCLASS                                   macro
+;; done     DEFCONSTANT                                macro
+;;          DEFGENERIC                                 macro
+;;          DEFINE-COMPILER-MACRO                      macro
+;;          DEFINE-CONDITION                           macro
+;;          DEFINE-METHOD-COMBINATION                  macro
+;;          DEFINE-MODIFY-MACRO                        macro
+;;          DEFINE-SETF-EXPANDER                       macro
+;;          DEFINE-SYMBOL-MACRO                        macro
+;; done     DEFMACRO                                   macro
+;;          DEFMETHOD                                  macro
+;; done     DEFPACKAGE                                 macro
+;; done     DEFPARAMETER                               macro
+;;          DEFSETF                                    macro
+;; done     DEFSTRUCT                                  macro
+;; done     DEFTYPE                                    macro
+;; done     DEFUN                                      macro
+;; done     DEFVAR                                     macro
+
+
+(cl:defmacro defconstant (name value
+                               &optional (documentation nil documentation-p))
+  (let ((key (gensym))
+        (def (gensym)))
+    `(let ((,key (cons 'variable ',name))
+           (,def (definitions ',(symbol-package name))))
+       (setf (gethash ,key ,def)
+             (list 'defconstant ',name ',value
+                   ,@(when documentation-p `(',documentation))))
+       (pushnew ,key (order ,(symbol-package name)) :test (function equal))
+       (cl:defconstant ,name ,value
+         ,@(when documentation-p `(,documentation))))))
+
+
+(cl:defmacro defvar (name &optional (value nil value-p)
+                          (documentation nil documentation-p))
+  (let ((key (gensym))
+        (def (gensym)))
+    `(let ((,key (cons 'variable ',name))
+           (,def (definitions ,(symbol-package name))))
+       (setf (gethash ,key ,def)
+             (list 'defvar ',name
+                   ,@ (when value-p
+                        `(',value ,@(when documentation-p `(',documentation))))))
+       (pushnew ,key (order ,(symbol-package name)) :test (function equal))
+       (cl:defvar ,name
+         ,@ (when value-p
+              `(,value ,@(when documentation-p `(,documentation))))))))
+
+
+(cl:defmacro defparameter (name value
+                                &optional (documentation nil documentation-p))
+  (let ((key (gensym))
+        (def (gensym)))
+    `(let ((,key (cons 'variable ',name))
+           (,def (definitions ,(symbol-package name))))
+       (setf (gethash ,key ,def)
+             (list 'defparameter ',name ',value
+                   ,@(when documentation-p `(',documentation))))
+       (pushnew ,key (order ,(symbol-package name)) :test (function equal))
+       (cl:defparameter ,name ,value
+         ,@(when documentation-p `(,documentation))))))
+
+
+
+(cl:defmacro defstruct (name-and-options &rest fields)
+  (let ((key (gensym))
+        (def (gensym))
+        (name (if (consp name-and-options)
+                  (first name-and-options)
+                  name-and-options)))
+    `(let ((,key (cons 'type ',name))
+           (,def (definitions ,(symbol-package name))))
+       (cl:defstruct ,name-and-options ,@fields)
+       (setf (gethash ,key ,def) '(defstruct ,name-and-options ,@fields))
+       (pushnew ,key (order ,(symbol-package name)) :test (function equal))
+       ',name)))
+
+
+(cl:defmacro defclass (name superclasses attributes &rest options)
+  (let ((key (gensym))
+        (def (gensym)))
+    `(let ((,key (cons 'type ',name))
+           (,def (definitions ,(symbol-package name))))
+       (cl:defclass ,name ,superclasses ,attributes ,@options)
+       (setf (gethash ,key ,def)
+             '(defclass ,name ,superclasses ,attributes ,@options))
+       (pushnew ,key (order ,(symbol-package name)) :test (function equal))
+       ',name)))
+
+
+;; Note: we compile the functions immediately, which may not be the
+;;       normal behavior when an interpreter is available, to
+
+(cl:defmacro defmacro (name args &body body)
+  (let ((key (gensym))
+        (def (gensym)))
+    `(let ((,key (cons 'function ',name))
+           (,def (definitions ,(symbol-package name))))
+       (cl:defmacro ,name ,args ,@body)
+       (eval-when (:execute)
+         (compile ',name))
+       (unless (compiled-function-p (macro-function ',name))
+         )
+       (setf (gethash ,key ,def) '(defmacro ,name ,args ,@body)
+             (gethash (cons 'function (fdefinition ',name)) ,def)
+             (gethash ,key ,def))
+       (pushnew ,key (order ,(symbol-package name)) :test (function equal))
+       ',name)))
+
+
+(cl:defmacro defun (name args &body body)
+  (let ((key (gensym))
+        (def (gensym)))
+    `(let ((,key (cons 'function ',name))
+           (,def (definitions ,(symbol-package name))))
+       (cl:defun ,name ,args ,@body)
+       (eval-when (:execute)
+         (compile ',name))
+       (unless (compiled-function-p (function ,name))
+         )
+       (setf (gethash ,key ,def) '(defun ,name ,args ,@body)
+             (gethash (cons 'function (fdefinition ',name)) ,def)
+             (gethash ,key ,def))
+       (pushnew ,key (order ,(symbol-package name)) :test (function equal))
+       ',name)))
+
+
+(cl:defmacro defmethod (name &body stuff-and-body)
+  (let ((key (gensym))
+        (def (gensym)))
+    ;; TODO: we should implement the overriding of methods!
+    `(let ((,key (cons 'method ',name))
+           (,def (definitions ,(symbol-package name))))
+       (cl:defmethod ,name ,@stuff-and-body)
+       (eval-when (:execute)
+         (compile ',name))
+       (unless (compiled-function-p (function ,name))
+         )
+       (setf (gethash ,key ,def) '(defmethod ,name ,@stuff-and-body)
+             (gethash (cons 'method (fdefinition ',name) #|add arg types here?|#) ,def)
+             (gethash ,key ,def))
+       (pushnew ,key (order ,(symbol-package name)) :test (function equal))
+       ',name)))
+
+
+
+;; (cl:defmacro lambda (args &body body)
+;;   `(cl:function (cl:lambda ,args ,@body)))
+
+(cl:defmacro lambda (args &body body)
+  (let ((key (gensym))
+        (def (gensym))
+        (fun (gensym))
+        (src (gensym)))
+    `(let ((,key (cons 'function ',fun))
+           (,def (definitions *package*))
+           (,fun (compile nil (cl:lambda ,args ,@body)))
+           (,src '(lambda ,args ,@body)))
+       (setf (gethash ,key ,def)                  ,src
+             (gethash (cons 'function ,fun) ,def) ,src)
+       ,fun)))
+
+
+(defmacro defpackage (name &rest options)
+  `(cl:defpackage ,name
+     ,@(mapcar
+        (lambda (option)
+          (if (listp option)
+              (case (first option)
+                ((:use)
+                 (substitute "IBCL" "COMMON-LISP"
+                             (substitute "IBCL" "CL" option)))
+                ((:shadowing-import-from :import-from)
+                 (if (member (string (second option))
+                             '("CL" "COMMON-LISP")
+                             :test (function string=))
+                     (list* (first option)
+                            "IBCL"
+                            (cddr option))
+                     option))
+                (otherwise option))))
+        options)))
+
+(cl:defun list-packages-with-sources ()
+  (let ((result '()))
+    (maphash (lambda (k v) (declare (ignore v)) (push k result)) *map*)
+    result))
+
+(cl:defun get-source (name &optional kind)
+  ;; TODO: with symbol-package we cannot find fdefinitions...
+  (if (null kind)
+      (loop
+         :for kind :in '(type variable function)
+         :collect (get-source name kind))
+      (gethash (cons kind name) (definitions (symbol-package name)))))
+
+(cl:defun save-sources (path-or-stream &key package)
+  (labels ((save-one-package (out package)
+             (let ((*print-readably* nil)
+                   (*package* (find-package package)))
+               (loop
+                  :with def = (definitions package)
+                  :with processed = (make-hash-table :test (function equal))
+                  :for item :in (reverse (order package))
+                  :initially (pprint `(in-package ,(package-name package)) out)
+                  :unless (gethash item processed)
+                  :do (progn
+                        (setf (gethash item processed) t)
+                        (pprint (gethash item def) out)))))
+           (save-packages (out package)
+             (if package
+                 (save-one-package out package)
+                 (dolist (package (list-packages-with-sources))
+                   (save-one-package out package)))))
+    (if (streamp path-or-stream)
+        (save-packages path-or-stream package)
+        (with-open-file (out path-or-stream
+                             :direction :output :if-exists :Supersede
+                             :if-does-not-exist :create)
+          (save-packages out package))))
+  (values))
+
+#+sbcl (require :sb-posix)
+(cl:defun save-image (&rest args)
+  #+clisp
+  (labels ((key-present-p (key plist)
+             (and (not (null plist))
+                  (or (eq key (car plist)) (key-present-p key (cddr plist))))))
+    (let* ((keys (rest args)))
+      (unless (key-present-p :start-package keys)
+        (setf (getf keys :start-package) (find-package "IBCL-USER")))
+      (unless (key-present-p :norc keys)
+        (setf (getf keys :norc) t))
+      (apply (function ext:saveinitmem)
+             (first args)
+             keys)))
+  #+sbcl
+  (when (zerop (SB-POSIX:FORK))
+      (apply (function sb-ext:SAVE-LISP-AND-DIE) args))
+  #-(or clisp sbcl) (error "I don't know how to save an image in ~A"
+                           (lisp-implementation-type))
+  (values))
+
+
+(cl:defun make-temporary-pathname ()
+  "Generate a rather unlikely filename."
+  (loop
+     :for path = (make-pathname :name (format nil "~36R" (get-universal-time))
+                                :type "LISP"
+                                :case :COMMON
+                                :defaults (user-homedir-pathname))
+     :while (probe-file path)
+     :finally (return path)))
+
+
+(cl:defmacro handling-errors (&body body)
+  `(HANDLER-CASE (progn ,@body)
+     (simple-condition
+         (ERR)
+       (format *error-output* "~&~A: ~%" (class-name (class-of err)))
+       (apply (function format) *error-output*
+              (simple-condition-format-control   err)
+              (simple-condition-format-arguments err))
+       (format *error-output* "~&"))
+     (condition
+         (ERR)
+       (format *error-output* "~&~A: ~%  ~S~%"
+               (class-name (class-of err)) err))))
+
+
+(cl:defun ed (&optional x)
+  (typecase x
+    (null                 (cl:ed))      ; edit whatever.
+    ((or pathname string) (cl:ed x))    ; edit an external file.
+    (otherwise
+     (let ((def (get-source x 'function)))
+       (if def
+           (let ((path (make-temporary-pathname))
+                 ;; TODO: with symbol-package we cannot find fdefinitions...
+                 (*package* (symbol-package x)))
+             (unwind-protect
+                  (progn
+                    (with-open-file (out path
+                                         :direction :output
+                                         :if-does-not-exist :create
+                                         :if-exists :error)
+                      (pprint def out))
+                    (cl:ed path)
+                    (handling-errors
+                     (with-open-file (in path)
+                       (loop
+                          :for form = (read in nil in)
+                          :until (eq form in)
+                          :do
+                          (when *load-verbose* (print form *trace-output*))
+                          (print (eval form))))))
+               (delete-file path)))
+           (cl:ed x))))))          ; try to edit the function anyways.
+
+
+(cl:defun repl ()
+  (do ((+eof+ (gensym))
+       (hist 1 (1+ hist)))
+      (nil)
+    (format t "~%~A[~D]> " (package-name *package*) hist)
+    (handling-errors
+     (setf +++ ++   ++ +   + -   - (read *standard-input* nil +eof+))
+     (when (or (eq - +eof+)
+               (member - '((quit)(exit)(continue)) :test (function equal)))
+       (return-from repl))
+     (setf /// //   // /   / (multiple-value-list (eval -)))
+     (setf *** **   ** *   * (first /))
+     (format t "~& --> ~{~S~^ ;~%     ~}~%" /))))
+
+
+
+;; We must pass the symbol in a list to export CL:NIL.
+(export (mapcar (lambda (name) (intern name "IBCL"))
+                (append '("SAVE-IMAGE" "SAVE-SOURCES"
+                          "GET-SOURCE" "LIST-PACKAGES-WITH-SOURCES")
+                        (let ((symbols '()))
+                          (do-external-symbols (sym "COMMON-LISP")
+                            (push (string sym) symbols))
+                          symbols))))
+
+
+
+(let ((*error-output* (make-broadcast-stream)))
+  (defpackage "IMAGE-BASED-COMMON-LISP-USER"
+    (:nicknames "IBCL-USER")
+    (:use "IMAGE-BASED-COMMON-LISP")))
+
+(in-package "IBCL-USER")
+
+
+
+
+
+
+
+
+
diff --git a/small-cl-pgms/ibcl/index.html b/small-cl-pgms/ibcl/index.html
new file mode 100644
index 0000000..c4c4bee
--- /dev/null
+++ b/small-cl-pgms/ibcl/index.html
@@ -0,0 +1,99 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">
+
+<HTML>
+ <HEAD>
+  <link rel="icon"          href="/favicon.ico" type="image/x-icon">
+  <link rel="shortcut icon" href="/favicon.ico" type="image/x-icon">
+  <link rel="stylesheet"    href="default.css"  type="text/css">
+
+  <TITLE>Common Lisp - Image Based Development</TITLE>
+
+  <META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=iso-8859-1">
+  <META HTTP-EQUIV="Description"
+        NAME="description" CONTENT="Common Lisp - Image Based Development">
+  <META NAME="author"      CONTENT="Pascal J. Bourguignon">
+
+  <META NAME="keywords"    CONTENT="Common Lisp, Lisp, Lisp Image">
+ </HEAD>
+<BODY>
+<!--TOP-BEGIN-->
+<!-- This section is automatically generated by html-update, -->
+<!-- from data in 'node.el'.    Please, do not edit it here. -->
+<DIV CLASS="TOP">
+
+</DIV>
+<!--TOP-END-->
+<!--MENU-BEGIN-->
+<!-- This section is automatically generated by html-update, -->
+<!-- from data in 'node.el'.    Please, do not edit it here. -->
+<DIV CLASS="MENU"><HR><P>|
+ <A HREF="../../../../toc.html">Contents</a> |
+ <A HREF="../../../../index.html">Home</a> |
+ <A HREF="../wang.html">Previous</a> |
+ <A HREF="../../index.html">Up</a> |
+ <A HREF="../sedit/index.html">Next</a> |
+</P><HR></DIV>
+<!--MENU-END-->
+
+<H1>Image Based Development</H1>
+
+<p>The package IBCL exports the same symbols as COMMON-LISP, but for
+   some of the functions of macros modified to track of the source
+   of the definitions and to be able to edit them from the image,
+   and to save them in files.</p>
+
+<p>The package IBCL-USER is a virgin package using IBCL instead of CL.</p>
+
+<p>One can work at the REPL, define variables with
+   DEFCONSTANT, DEFVAR, DEFPARAMETER, macros with DEFMACRO,
+   and functions with DEFUN, edit macro and function definitions
+   with ED, and save the image with SAVE-IMAGE.</p>
+
+<p>The function LIST-PACKAGES-WITH-SOURCES returns a list of packages
+   where some of these variables or functions are defined.
+   The function GET-SOURCE returns the source form of the given
+   variable or function.
+   The function SAVE-SOURCES saves the definitions in a package,
+   or all the definitions to a file or stream.</p>
+
+<UL>
+<LI><A HREF="ibcl.lisp">ibcl.lisp</A></LI>
+<LI><A HREF="ibcl-bootstrap.lisp">ibcl-bootstrap.lisp</A>
+      A script to generate an executable image using
+      IMAGE-BASED-COMMON-LISP instead of COMMON-LISP.
+      For <a href="http://clisp.cons.org/">clisp</a>
+      or  <a href="http://sbcl.sourceforge.net/">sbcl</a>.</LI>
+</UL>
+
+<!--MENU-BEGIN-->
+<!-- This section is automatically generated by html-update, -->
+<!-- from data in 'node.el'.    Please, do not edit it here. -->
+<DIV CLASS="MENU"><HR><P>|
+ <A HREF="../../../../toc.html">Contents</a> |
+ <A HREF="../../../../index.html">Home</a> |
+ <A HREF="../wang.html">Previous</a> |
+ <A HREF="../../index.html">Up</a> |
+ <A HREF="../sedit/index.html">Next</a> |
+</P><HR></DIV>
+<!--MENU-END-->
+<!--BOTTOM-BEGIN-->
+<!-- This section is automatically generated by html-update, -->
+<!-- from data in 'node.el'.    Please, do not edit it here. -->
+<DIV CLASS="BOTTOM">
+<hr><code><small>
+ | <a href="http://www.informatimago.com//develop/lisp/small-cl-pgms/ibcl/index.html">Mirror on informatimago.com</a>
+ | <a href="http://informatimago.free.fr/i//develop/lisp/small-cl-pgms/ibcl/index.html">Mirror on free.fr</a>
+ | </small></code>
+
+<BR><SMALL>Last update : <!--MODIFICATION-DATE--> 2011-01-19 02:07:15
+     by : <!--MODIFICATION-AUTEUR--> Pascal J. Bourguignon
+    </SMALL>
+<BR><SMALL>
+      <a href="http://validator.w3.org/check?uri=referer"><img
+          src="http://www.w3.org/Icons/valid-html401"
+          alt="Valid HTML 4.01!" height="31" width="88"></a>
+   </SMALL>
+</DIV>
+<!--BOTTOM-END-->
+</BODY>
+</HTML>
diff --git a/small-cl-pgms/index.html b/small-cl-pgms/index.html
new file mode 100644
index 0000000..bb4633b
--- /dev/null
+++ b/small-cl-pgms/index.html
@@ -0,0 +1,168 @@
+
+
+
+
+
+
+
+
+<html><!-- PLEASE DO NOT EDIT THIS FILE! -->
+<!-- PLEASE DO NOT EDIT THIS FILE! -->
+<!-- The source of this file is index.lisp -->
+<!-- The source of this file is index.lisp -->
+<head>
+<title>Common-Lisp Small Programs and Tidbits</title>
+<meta HTTP-EQUIV="Content-Type" content="text/html; charset=iso-8859-1">
+<meta name="author" content="Pascal J. Bourguignon">
+<meta HTTP-EQUIV="Description" name="description" content="Small Common-Lisp Programs and Tidbits">
+<meta name="keywords" content="software,logiciel,programas,GPL,LGPL,Lisp,Common-Lisp"></head>
+<body><!--TOP-BEGIN-->
+<!-- This section is automatically generated by html-update, -->
+<!-- from data in 'node.el'.    Please, do not edit it here. -->
+<DIV CLASS="TOP">
+
+</DIV>
+<!--TOP-END-->
+<!-- TOP-END -->
+<!--MENU-BEGIN-->
+<!-- This section is automatically generated by html-update, -->
+<!-- from data in 'node.el'.    Please, do not edit it here. -->
+<DIV CLASS="MENU"><HR><P>|
+ <A HREF="../../../toc.html">Contents</a> |
+ <A HREF="../../../index.html">Home</a> |
+ <A HREF="../index.html">Previous</a> |
+ <A HREF="../index.html">Up</a> |
+ <A HREF="aim-8/index.html">Next</a> |
+</P><HR></DIV>
+<!--MENU-END-->
+<!-- MENU-END -->
+<h1>Common-Lisp Small Programs and Tidbits</h1>
+<h2>Downloading the sources</h2>
+<p>The sources of these small Common-Lisp
+                                  programs can be downloaded via
+<a href="http://git-scm.com/">git</a>. Use the following command to fetch them:</p>
+<pre>git clone git://git.informatimago.com/public/small-cl-pgms</pre>
+<h2>Lisp History</h2>
+<p></p>
+<h3>The original LISP</h3>
+<p>Implements the lisp of AIM-8 (4 MARCH 1959 by John McCarthy).</p>
+<ul>
+<li>
+<a href="aim-8/">The LISP of the AI Memo 8</a></li></ul>
+<h3>LISP 1.5 Sources</h3>
+<p>The sources of LISP 1.5 in machine readable form. See "More information" for perhaps the latest version.</p>
+<ul>
+<li>
+<a href="ftp://ftp.informatimago.com/pub/free/develop/lisp/lisp15-0.0.2.tar.gz">The sources of LISP 1.5</a></li>
+<li>
+<a href="http://groups.google.com/group/comp.lang.lisp/browse_frm/thread/67b1cabdf271870c?pli=1">More information</a></li>
+<li>
+<a href="http://www.softwarepreservation.org/projects/LISP/index.html#LISP_I_and_LISP_1.5_for_IBM_704,_709,_7090_">Software preservation</a></li></ul>
+<h3>A Parser for M-expressions</h3>
+<p>Implements a parser and a REPL for the M-expressions defined
+                 in  AIM-8 (4 MARCH 1959 by John McCarthy).</p>
+<ul>
+<li>
+<a href="m-expression/">A Parser for M-expressions</a></li></ul>
+<h3>Old LISP programs still run in Common Lisp</h3>
+<p>The Wang's algorithm, implemented in LISP 1 on IBM 704
+                  in March 1960 still runs well on Common Lisp in 2006.</p>
+<ul>
+<li>
+<a href="wang.html">Wang's Algorithm in LISP 1, runs on COMMON-LISP</a></li></ul>
+<h2>Lisp Cookbook</h2>
+<p></p>
+<h3>Image Based Development</h3>
+<p></p>
+<ul>
+<li>
+<a href="ibcl/">A package that saves the definitions typed at the REPL</a></li></ul>
+<h3>Small Simple Structural Editor</h3>
+<p>This is a simple structural editor to edit lisp sources considered as syntactic forests.</p>
+<ul>
+<li>
+<a href="sedit/">A Structural Editor</a></li></ul>
+<h3>Recursive Descent Parser Generator</h3>
+<p>But not so ugly.
+ Can generate the parser in lisp and in pseudo-basic.</p>
+<ul>
+<li>
+<a href="rdp/">A Quick and Dirty Recursive Descent Parser Generator</a></li></ul>
+<h2>Lisp Tidbits</h2>
+<p></p>
+<h3>Author Signature</h3>
+<p>This program computes an "author signature" from a text, with
+ the algorithm from  http://unix.dsu.edu/~johnsone/comp.html</p>
+<ul>
+<li>
+<a href="author-signature.lisp">author-signature.lisp</a></li></ul>
+<h3>Demographic Simulator</h3>
+<p>Assuming an Adam and an Eve 20 years old each,
+ assuming the current US life table,
+ and assuming an "intensive" reproduction rate, with gene selection,
+ simulate the population growth during 80 years
+ and draw the final age pyramid.</p>
+<ul>
+<li>
+<a href="douze.lisp">douze.lisp</a></li></ul>
+<h3>Solitaire</h3>
+<p>A solitaire playing program. The user just watch the program play solitaire.</p>
+<ul>
+<li>
+<a href="solitaire.lisp">solitaire.lisp</a></li></ul>
+<h3>Conway's Life Game</h3>
+<p>A small life game program.</p>
+<ul>
+<li>
+<a href="life.lisp">life.lisp</a></li></ul>
+<h3>Cube Puzzle</h3>
+<p>This program tries to resolve the Cube Puzzle, where a cube
+  composed of 27 smaller cubes linked with a thread  must be recomposed.</p>
+<ul>
+<li>
+<a href="cube.lisp">cube.lisp</a></li></ul>
+<h3>Common-Lisp quines</h3>
+<p>Three Common-Lisp quines (autogenerating programs).</p>
+<ul>
+<li>
+<a href="quine.lisp">quine.lisp</a></li></ul>
+<h3>Geek Day</h3>
+<p>The famous Geek Day games by userfriendly.org's Illiad.
+    See: http://ars.userfriendly.org/cartoons/?id=20021215</p>
+<ul>
+<li>
+<a href="geek-day/geek-day.lisp">geek-day/geek-day.lisp</a></li>
+<li>
+<a href="geek-day/Makefile">geek-day/Makefile</a></li>
+<li>
+<a href="geek-day/README">geek-day/README</a></li></ul>
+<h3>BASIC</h3>
+<p></p>
+<ul>
+<li>
+<a href="basic/">A Quick, Dirty and Ugly Basic interpreter.</a></li></ul>
+<h3>Brainfuck</h3>
+<p></p>
+<ul>
+<li>
+<a href="brainfuck/">A brainfuck virtual machine, and brainfuck compiler.</a></li></ul><!--BOTTOM-BEGIN-->
+<!-- This section is automatically generated by html-update, -->
+<!-- from data in 'node.el'.    Please, do not edit it here. -->
+<DIV CLASS="BOTTOM">
+<hr><code><small>
+ | <a href="http://www.informatimago.com//develop/lisp/small-cl-pgms/index.html">Mirror on informatimago.com</a>
+ | <a href="http://informatimago.free.fr/i//develop/lisp/small-cl-pgms/index.html">Mirror on free.fr</a>
+ | </small></code>
+
+<BR><SMALL>Last update : <!--MODIFICATION-DATE--> 2011-01-19 02:07:14
+     by : <!--MODIFICATION-AUTEUR--> Pascal J. Bourguignon
+    </SMALL>
+<BR><SMALL>
+      <a href="http://validator.w3.org/check?uri=referer"><img
+          src="http://www.w3.org/Icons/valid-html401"
+          alt="Valid HTML 4.01!" height="31" width="88"></a>
+   </SMALL>
+</DIV>
+<!--BOTTOM-END-->
+<!-- BOTTOM-END -->
+</body></html>
diff --git a/small-cl-pgms/index.lisp b/small-cl-pgms/index.lisp
new file mode 100644
index 0000000..ef6885f
--- /dev/null
+++ b/small-cl-pgms/index.lisp
@@ -0,0 +1,207 @@
+;;;; -*- mode:lisp; coding:utf-8 -*-
+;;;;****************************************************************************
+;;;;FILE:               index.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    Generate the index.html for small-cl-pgms.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2004-03-14 <PJB> Created.
+;;;;BUGS
+;;;;LEGAL
+;;;;    GPL
+;;;;
+;;;;    Copyright Pascal Bourguignon 2004 - 2004
+;;;;
+;;;;    This program is free software; you can redistribute it and/or
+;;;;    modify it under the terms of the GNU General Public License
+;;;;    as published by the Free Software Foundation; either version
+;;;;    2 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 General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU General Public
+;;;;    License along with this program; if not, write to the Free
+;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;;    Boston, MA 02111-1307 USA
+;;;;****************************************************************************
+
+(com.informatimago.common-lisp.cesarum.package:add-nickname
+ "COM.INFORMATIMAGO.COMMON-LISP.HTML-GENERATOR.HTML" "<")
+
+;; (<:INITIALIZE)
+(<:with-html-output (*standard-output* :kind :strict :encoding :iso-8859-1)
+  (<:HTML ()
+          (<:comment "PLEASE DO NOT EDIT THIS FILE!")
+          (<:comment "The source of this file is index.lisp")
+          (<:HEAD ()
+                  ;; (<:link (:rel "SHORTCUT ICON" :HREF "informatimago.ico" :TITLE "EXTERNAL:informatimago.ico"))
+                  (<:TITLE () (<:pcdata
+                               "Common-Lisp Small Programs and Tidbits"))
+                  (<:META (:HTTP-EQUIV "Content-Type"
+                                       :CONTENT "text/html; charset=iso-8859-1"))
+                  (<:META (:NAME "author" :CONTENT "Pascal J. Bourguignon"))
+                  (<:META (:HTTP-EQUIV "Description" :NAME "description"
+                                       :CONTENT "Small Common-Lisp Programs and Tidbits"))
+                  (<:META (:NAME "keywords"
+                                 :CONTENT "software,logiciel,programas,GPL,LGPL,Lisp,Common-Lisp")))
+          (<:BODY ()
+                  (<:COMMENT "TOP-BEGIN")
+                  (<:COMMENT "TOP-END")
+                  (<:COMMENT "MENU-BEGIN")
+                  (<:COMMENT "MENU-END")
+
+                  (<:H1 () (<:PCDATA "Common-Lisp Small Programs and Tidbits"))
+
+                  (<:h2 () (<:pcdata "Downloading the sources"))
+                  (<:p ()
+                       (<:pcdata "The sources of these small Common-Lisp
+                                  programs can be downloaded via ")
+                       (<:a (:href "http://git-scm.com/") (<:pcdata "git"))
+                       (<:pcdata ". Use the following command to fetch them:"))
+                  (<:pre ()
+                         (<:pcdata "git clone git://git.informatimago.com/public/small-cl-pgms"))
+
+                  (DOLIST
+                      (SECTION
+                        '(
+                          ("Lisp History"
+                           ;;===========
+                           ""
+
+                           ("The original LISP"
+                            ;;----------------
+                            (("aim-8/" "The LISP of the AI Memo 8"))
+                            "Implements the lisp of AIM-8 (4 MARCH 1959 by John McCarthy).")
+
+                           ("LISP 1.5 Sources"
+                            ;;----------------
+                            (("ftp://ftp.informatimago.com/pub/free/develop/lisp/lisp15-0.0.2.tar.gz"
+                              "The sources of LISP 1.5")
+                             ("http://groups.google.com/group/comp.lang.lisp/browse_frm/thread/67b1cabdf271870c?pli=1"
+                              "More information")
+                             ("http://www.softwarepreservation.org/projects/LISP/index.html#LISP_I_and_LISP_1.5_for_IBM_704,_709,_7090_"
+                              "Software preservation"))
+                            "The sources of LISP 1.5 in machine readable form. See \"More information\" for perhaps the latest version.")
+
+                           ("A Parser for M-expressions"
+                            ;;-------------------------
+                            (("m-expression/" "A Parser for M-expressions"))
+                            "Implements a parser and a REPL for the M-expressions defined
+                 in  AIM-8 (4 MARCH 1959 by John McCarthy).")
+
+                           ("Old LISP programs still run in Common Lisp"
+                            ;;-----------------------------------------
+                            (("wang.html" "Wang's Algorithm in LISP 1, runs on COMMON-LISP"))
+                            "The Wang's algorithm, implemented in LISP 1 on IBM 704
+                  in March 1960 still runs well on Common Lisp in 2006."))
+
+                          ("Lisp Cookbook"
+                           ;;============
+                           ""
+
+                           ("Image Based Development"
+                            ;;----------------------
+                            (("ibcl/"
+                              "A package that saves the definitions typed at the REPL"))
+                            "")
+
+                           ("Small Simple Structural Editor"
+                            ;;----------------------
+                            (("sedit/"
+                              "A Structural Editor"))
+                            "This is a simple structural editor to edit lisp sources considered as syntactic forests.")
+
+                           ("Recursive Descent Parser Generator"
+                            ;;---------------------------------
+                            (("rdp/"
+                              "A Quick and Dirty Recursive Descent Parser Generator"))
+                            "But not so ugly.
+ Can generate the parser in lisp and in pseudo-basic."))
+
+
+                          ("Lisp Tidbits"
+                           ;;============
+                           ""
+
+                           ("Author Signature"
+                            ;;---------------
+                            ("author-signature.lisp")
+                            "This program computes an \"author signature\" from a text, with
+ the algorithm from  http://unix.dsu.edu/~~johnsone/comp.html")
+
+                           ("Demographic Simulator"
+                            ;;--------------------
+                            ("douze.lisp")
+                            "Assuming an Adam and an Eve 20 years old each,
+ assuming the current US life table,
+ and assuming an \"intensive\" reproduction rate, with gene selection,
+ simulate the population growth during 80 years
+ and draw the final age pyramid.")
+
+                           ("Solitaire"
+                            ;;--------------------
+                            ("solitaire.lisp")
+                            "A solitaire playing program. The user just watch the program play solitaire.")
+
+                           ("Conway's Life Game"
+                            ;;-----------------
+                            ("life.lisp")
+                            "A small life game program.")
+
+                           ("Cube Puzzle"
+                            ;;----------
+                            ("cube.lisp")
+                            "This program tries to resolve the Cube Puzzle, where a cube
+  composed of 27 smaller cubes linked with a thread  must be recomposed.")
+
+                           ("Common-Lisp quines"
+                            ;;-----------------
+                            ("quine.lisp")
+                            "Three Common-Lisp quines (autogenerating programs).")
+
+                           ("Geek Day"
+                            ;;-------
+                            ("geek-day/geek-day.lisp" "geek-day/Makefile" "geek-day/README")
+                            "The famous Geek Day games by userfriendly.org's Illiad.
+    See: http://ars.userfriendly.org/cartoons/?id=20021215")
+
+                           ("BASIC"
+                            ;;----
+                            (("basic/"  "A Quick, Dirty and Ugly Basic interpreter."))
+                            "")
+
+                           ("Brainfuck"
+                            ;;--------
+                            (("brainfuck/"  "A brainfuck virtual machine, and brainfuck compiler."))
+                            ""))))
+
+
+                    (<:H2 () (<:PCDATA (FIRST SECTION)))
+                    (<:P  () (<:PCDATA (SECOND SECTION)))
+                    (DOLIST (SOFT (CDDR SECTION))
+                      (<:H3 () (<:PCDATA (FIRST SOFT)))
+                      (<:P  () (<:PCDATA (THIRD SOFT)))
+                      (<:UL ()
+                            (DOLIST (FILE (SECOND SOFT))
+                              (<:LI ()
+                                    (if (stringp file)
+                                        (<:A (:HREF FILE)
+                                             (<:PCDATA FILE))
+                                        (<:A (:HREF (first FILE))
+                                             (<:PCDATA (second FILE)))))))))
+
+                  ;; (<:COMMENT "MENU-BEGIN")
+                  ;; (<:COMMENT "MENU-END")
+                  (<:COMMENT "BOTTOM-BEGIN")
+                  (<:COMMENT "BOTTOM-END"))))
+
+;;;; THE END ;;;;
diff --git a/small-cl-pgms/init.lisp b/small-cl-pgms/init.lisp
new file mode 100644
index 0000000..cdce918
--- /dev/null
+++ b/small-cl-pgms/init.lisp
@@ -0,0 +1,169 @@
+;;;; -*- mode:lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE:               init-asdf.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    Compile the com.informatimago.common-lisp libraries with ASDF.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2010-11-01 <PJB> Created.
+;;;;BUGS
+;;;;LEGAL
+;;;;    GPL
+;;;;
+;;;;    Copyright Pascal J. Bourguignon 2010 - 2010
+;;;;
+;;;;    This program is free software; you can redistribute it and/or
+;;;;    modify it under the terms of the GNU General Public License
+;;;;    as published by the Free Software Foundation; either version
+;;;;    2 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 General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU General Public
+;;;;    License along with this program; if not, write to the Free
+;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;;    Boston, MA 02111-1307 USA
+;;;;**************************************************************************
+
+(in-package :cl-user)
+
+(defvar *asdf-source*
+  #P"/data/lisp/packages/net/common-lisp/projects/asdf/asdf/asdf.lisp")
+
+(defvar *asdf-binary-locations-directory*
+  #P"/data/lisp/packages/net/common-lisp/projects/asdf-binary-locations/asdf-binary-locations/")
+
+
+;;;----------------------------------------------------------------------
+;;;
+;;; Directories.
+;;;
+
+(defvar *directories*  '())
+
+(defun list-directories ()
+  "Returns the list of named directories."
+  (copy-seq *directories*))
+
+(defun get-directory (key &optional (subpath ""))
+  "
+Caches the ~/directories.txt file that contains a map of
+directory keys to pathnames, into *DIRECTORIES*.
+
+Then builds and returns a pathname made by merging the directory
+selected by KEY, and the given SUBPATH.
+"
+  (unless *directories*
+    (with-open-file (dirs (merge-pathnames
+                           (make-pathname :name "DIRECTORIES" :type "TXT"
+                                          :version nil :case :common)
+                           (user-homedir-pathname)
+                           nil))
+      (loop
+         :for k = (read dirs nil dirs)
+         :until (eq k dirs)
+         :do (push (string-trim " " (read-line dirs)) *directories*)
+         :do (push (intern (substitute #\- #\_ (string k))
+                           "KEYWORD") *directories*))))
+  (unless (getf *directories* key)
+    (error "~S: No directory keyed ~S" 'get-directory key))
+  (merge-pathnames subpath (getf *directories* key) nil))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; ASDF
+;;;
+
+(unless (find-package :asdf)
+  (handler-case (require :asdf)
+    (error ()   (load (compile-file *asdf-source*)))))
+
+(defun push-asdf-repository (path)
+  (pushnew path asdf:*central-registry* :test #'equal))
+
+(defun asdf-load (&rest systems)
+  (mapcar (lambda (system) (asdf:operate 'asdf:load-op system))
+          systems))
+
+(defun asdf-delete-system (&rest systems)
+  (mapc (lambda (system) (remhash (string-downcase system) asdf::*defined-systems*))
+        systems)
+  (values))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; ASDF-BINARY-LOCATIONS
+;;;
+
+(defun hostname ()
+  (let ((outpath (format nil "/tmp/hostname-~8,'0X.txt" (random #x100000000))))
+    (asdf:run-shell-command
+     "( hostname --fqdn 2>/dev/null || hostname --long 2>/dev/null || hostname ) > ~A"
+     outpath)
+    (prog1 (with-open-file (hostname outpath)
+             (read-line hostname))
+      (delete-file outpath))))
+
+(let ((sym (find-symbol "ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY" "ASDF")))
+  (when (and sym (fboundp sym))
+    (push :HAS-ASDF-ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY *features*)))
+
+#+HAS-ASDF-ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY
+(progn
+  ;; (format *trace-output* "enable-asdf-binary-locations-compatibility ~%")
+  (asdf:enable-asdf-binary-locations-compatibility
+   :centralize-lisp-binaries     t
+   :default-toplevel-directory   (merge-pathnames (format nil ".cache/common-lisp/~A/" (hostname))
+                                                  (truename (user-homedir-pathname)) nil)
+   :include-per-user-information nil
+   :map-all-source-files t
+   :source-to-target-mappings    nil))
+
+;; We need (truename (user-homedir-pathname)) because in cmucl (user-homedir-pathname)
+;; is a search path, and that cannot be merged...
+
+#-HAS-ASDF-ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY
+(progn
+ (push-asdf-repository *asdf-binary-locations-directory*)
+ (asdf-load :asdf-binary-locations))
+
+#-HAS-ASDF-ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY
+(progn
+  (format *trace-output* "enable-asdf-binary-locations-compatibility ~%")
+  (setf asdf:*centralize-lisp-binaries*     t
+        asdf:*include-per-user-information* nil
+        asdf:*default-toplevel-directory*
+        (merge-pathnames (format nil ".cache/common-lisp/~A/" (hostname))
+                         (truename (user-homedir-pathname)) nil)
+        asdf:*source-to-target-mappings* '()))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Compiling com.informatimago.common-lisp
+;;;
+
+
+(setf asdf:*central-registry*
+      (append (remove-duplicates
+               (mapcar (lambda (path)
+                         (make-pathname :name nil :type nil :version nil :defaults path))
+                       (directory  (get-directory :share-lisp "packages/com/informatimago/common-lisp/**/*.asd")))
+               :test (function equalp))
+              asdf:*central-registry*))
+
+
+;; (print asdf:*central-registry*) (finish-output)
+
+(asdf-load  :com.informatimago.common-lisp.cesarum)
+(asdf-load  :com.informatimago.common-lisp.html-generator)
+
+;;;; THE END ;;;;
diff --git a/small-cl-pgms/life.lisp b/small-cl-pgms/life.lisp
new file mode 100644
index 0000000..5823e6b
--- /dev/null
+++ b/small-cl-pgms/life.lisp
@@ -0,0 +1,156 @@
+;;;; -*- mode:lisp; coding:utf-8 -*-
+;;;;****************************************************************************
+;;;;FILE:               life.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    Conway's Life Game.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2005-09-20 <PJB> Created.
+;;;;BUGS
+;;;;LEGAL
+;;;;    GPL
+;;;;
+;;;;    Copyright Pascal Bourguignon 2005 - 2005
+;;;;
+;;;;    This program is free software; you can redistribute it and/or
+;;;;    modify it under the terms of the GNU General Public License
+;;;;    as published by the Free Software Foundation; either version
+;;;;    2 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 General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU General Public
+;;;;    License along with this program; if not, write to the Free
+;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;;    Boston, MA 02111-1307 USA
+;;;;****************************************************************************
+
+(defstruct (world (:constructor %make-world))
+  current
+  next)
+
+
+(defun make-world (width height)
+  (flet ((make-plane (width height)
+           (make-array (list width height)
+                       :element-type 'bit
+                       :initial-element 0)))
+    (%make-world
+     :current (make-plane  width height)
+     :next    (make-plane  width height))))
+
+
+(defun sum-neighbors (plane i j)
+  (let ((width  (array-dimension plane 0))
+        (height (array-dimension plane 1)))
+    (+ (aref plane (mod (- i 1) width)  (mod (- j 1) height))
+       (aref plane (mod (- i 1) width)  j)
+       (aref plane (mod (- i 1) width)  (mod (+ j 1) height))
+       (aref plane i                    (mod (- j 1) height))
+       (aref plane i                    (mod (+ j 1) height))
+       (aref plane (mod (+ i 1) width)  (mod (- j 1) height))
+       (aref plane (mod (+ i 1) width)  j)
+       (aref plane (mod (+ i 1) width)  (mod (+ j 1) height)))))
+
+
+(defun simple-sum-neighbors (plane i j)
+  (let ((width  (array-dimension plane 0))
+        (height (array-dimension plane 1)))
+    (+ (aref plane (- i 1)  (- j 1))
+       (aref plane (- i 1)  j)
+       (aref plane (- i 1)  (+ j 1))
+       (aref plane i        (- j 1))
+       (aref plane i        (+ j 1))
+       (aref plane (+ i 1)  (- j 1))
+       (aref plane (+ i 1)  j)
+       (aref plane (+ i 1)  (+ j 1)))))
+
+
+(defun life-step (world)
+  (loop
+     with old = (world-current world)
+     with new = (world-next    world)
+     for i from 1 below (1- (array-dimension old 0))
+     do (loop for j from 1 below (1- (array-dimension old 1))
+           do (setf (aref new i j)
+                    (if (zerop (aref old i j))
+                        (if (= 3  (simple-sum-neighbors old i j)) 1 0)
+                        (if (<= 2 (simple-sum-neighbors old i j) 3) 1 0)))))
+  (loop
+     with old = (world-current world)
+     with new = (world-next    world)
+     for i from 0 below (array-dimension old 0)
+     do
+     (let ((j 0))
+       (setf (aref new i j)
+             (if (zerop (aref old i j))
+                 (if (= 3  (sum-neighbors old i j)) 1 0)
+                 (if (<= 2 (sum-neighbors old i j) 3) 1 0))))
+     (let ((j (1- (array-dimension old 1))))
+       (setf (aref new i j)
+             (if (zerop (aref old i j))
+                 (if (= 3  (sum-neighbors old i j)) 1 0)
+                 (if (<= 2 (sum-neighbors old i j) 3) 1 0)))))
+  (loop
+     with old = (world-current world)
+     with new = (world-next    world)
+     for j from 1 below (1- (array-dimension old 1))
+     do
+     (let ((i 0))
+       (setf (aref new i j)
+             (if (zerop (aref old i j))
+                 (if (= 3  (sum-neighbors old i j)) 1 0)
+                 (if (<= 2 (sum-neighbors old i j) 3) 1 0))))
+     (let ((i (1- (array-dimension old 0))))
+       (setf (aref new i j)
+             (if (zerop (aref old i j))
+                 (if (= 3  (sum-neighbors old i j)) 1 0)
+                 (if (<= 2 (sum-neighbors old i j) 3) 1 0)))))
+  (rotatef (world-current world) (world-next world))
+  world)
+
+
+(defun set-random (world)
+  (loop
+     with plane = (world-current world)
+     for i from 0 below (array-dimension plane 0)
+     do (loop for j from 0 below (array-dimension plane 1)
+           do (setf (aref plane i j) (random 2))))
+  world)
+
+
+(defun print-world (world)
+  (loop
+     with old = (world-current world)
+     for j  below (array-dimension old 1)
+     do (loop for i below (array-dimension old 0)
+           do (princ (aref ".o" (aref old i j)))
+           finally (terpri)))
+  world)
+
+
+(defun terminal-size ()
+  #+clisp (let ((s (ext:run-program "stty"
+                     :arguments '("size") :output :stream)))
+            (nreverse (list (1- (read s)) (1- (read s)))))
+  #-clisp (list 78 23))
+
+
+(defun random-game ()
+  (let ((world (apply (function make-world) (terminal-size))))
+    (set-random world)
+    (format t "~Cc" (code-char 27))
+    (loop
+       (format t "~C[0;0H" (code-char 27)) ; CUP
+       (print-world (life-step world))
+       (finish-output))))
+
diff --git a/small-cl-pgms/m-expression/index.html b/small-cl-pgms/m-expression/index.html
new file mode 100644
index 0000000..555d7e7
--- /dev/null
+++ b/small-cl-pgms/m-expression/index.html
@@ -0,0 +1,155 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">
+
+<HTML>
+ <HEAD>
+  <link rel="icon"          href="/favicon.ico" type="image/x-icon">
+  <link rel="shortcut icon" href="/favicon.ico" type="image/x-icon">
+  <link rel="stylesheet"    href="default.css"  type="text/css">
+
+  <TITLE>The Original LISP</TITLE>
+
+  <META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=utf-8">
+  <META HTTP-EQUIV="Description"
+        NAME="description" CONTENT="M-Expressions, The Original LISP">
+  <META NAME="author"      CONTENT="Pascal J. Bourguignon">
+  <META NAME="keywords"    CONTENT="LISP, Common Lisp, M-Expressions">
+ </HEAD>
+ <BODY>
+<!--TOP-BEGIN-->
+<!-- This section is automatically generated by html-update, -->
+<!-- from data in 'node.el'.    Please, do not edit it here. -->
+<DIV CLASS="TOP">
+
+</DIV>
+<!--TOP-END-->
+<!--MENU-BEGIN-->
+<!-- This section is automatically generated by html-update, -->
+<!-- from data in 'node.el'.    Please, do not edit it here. -->
+<DIV CLASS="MENU"><HR><P>|
+ <A HREF="../../../../toc.html">Contents</a> |
+ <A HREF="../../../../index.html">Home</a> |
+ <A HREF="../aim-8/aim-8.html">Previous</a> |
+ <A HREF="../../index.html">Up</a> |
+ <A HREF="../wang.html">Next</a> |
+</P><HR></DIV>
+<!--MENU-END-->
+  <h1>A Parser for M-Expressions</h1>
+  <p>Here is a parser for Lisp M-Expressions as documented in the
+     <a href="../aim-8/index.html">Memo 8, AIM-8</a></p>
+
+  <p>
+    A lot of lisp newbies ask for more conventionnal syntax for lisp.
+    Since day one, lisp was intended to have such a syntax: M-expressions.
+  </p>
+  <p>
+    Let's newbies play with them, and realize how impractical they are.
+    Note for example, that we cannot use macros anymore because
+    their syntax would need to be known by the M-expression parser,
+    like it's the case for <tt>lambda[[...];...]</tt>.
+    Macros were added later in lisp history.
+  </p>
+  <p>
+    Note that S-expressions can still be entered, as literal objects,
+    but using comma instead of space to separate the items in lists.
+  </p>
+  <p>The file <A HREF="m-expression.lisp">m-expression.lisp</A>
+     contains the M-expression parser and a REPL, in Common-Lisp.</p>
+
+   <h2>Exemple</h2>
+
+<pre>
+% <b>/usr/local/bin/clisp -q -norc -ansi </b>
+
+[1]&gt; <b>(load"m-expression.lisp" :external-format #+clisp charset:utf-8 #+sbcl :utf-8)</b>
+;; Loading file m-expression.lisp ...
+;; Loaded file m-expression.lisp
+T
+[2]&gt; <b>(m-repl)</b>
+
+;; We are going to define a function that is exported by COMMON-LISP,
+;; so let's shadow it first:
+
+COMMON-LISP-USER[1]M-REPL&gt; <b>shadow[SUBST];</b>
+ --&gt; T
+
+COMMON-LISP-USER[2]M-REPL&gt; <b>label[subst;λ[[x;y;s];[null[s]-&gt;nil;atom[s]⟶
+           [y=s-&gt;x;1-&gt;s];1-&gt;combine[subst[x;y;first[s]];
+                subst[x;y;rest[s]]]]]];</b>
+ --&gt; SUBST
+
+;; S-expressions embedded in M-expressions must use comma as separator:
+COMMON-LISP-USER[3]M-REPL&gt; <b>subst[WATER;WINE;(MIX WATER AND WINE
+                                  INTO (MIXED WATER AND WINE))];</b>
+SIMPLE-ERROR:
+Unexpected S-CLOSE, not (:S-SYMBOL WATER)
+ at " AND WINE"
+
+COMMON-LISP-USER[4]M-REPL&gt; SIMPLE-ERROR:
+Please terminate your m-expressions with a semi-colon, not (:S-OPEN)
+
+COMMON-LISP-USER[5]M-REPL&gt;
+SIMPLE-ERROR:
+Please terminate your m-expressions with a semi-colon, not (:S-SYMBOL WATER)
+
+COMMON-LISP-USER[6]M-REPL&gt;
+SIMPLE-ERROR:
+Please terminate your m-expressions with a semi-colon, not (:S-SYMBOL WINE)
+
+COMMON-LISP-USER[7]M-REPL&gt;
+SIMPLE-ERROR:
+Unexpected token in m-term: (:S-CLOSE)
+ at ")];"
+
+COMMON-LISP-USER[8]M-REPL&gt; <b>subst[WATER;WINE;(MIX,WATER,AND,WINE,
+                                 INTO,(MIXED,WATER,AND,WINE))];</b>
+ --&gt; (MIX WATER AND WATER INTO (MIXED WATER AND WATER))
+
+COMMON-LISP-USER[9]M-REPL&gt; <b>subst[WINE;WATER;(MIX,WATER,AND,WINE,
+                                 INTO,(MIXED,WATER,AND,WINE))];</b>
+ --&gt; (MIX WINE AND WINE INTO (MIXED WINE AND WINE))
+
+COMMON-LISP-USER[10]M-REPL&gt; <b>first[((A,B),C,D)]=(A,B);</b>
+
+ --&gt; NIL
+
+COMMON-LISP-USER[11]M-REPL&gt; <b>combine[A;⋀];</b>
+ --&gt; (A)
+
+COMMON-LISP-USER[12]M-REPL&gt; <b>quit[];</b>
+NIL
+[3]&gt;
+
+  </pre>
+
+<!--MENU-BEGIN-->
+<!-- This section is automatically generated by html-update, -->
+<!-- from data in 'node.el'.    Please, do not edit it here. -->
+<DIV CLASS="MENU"><HR><P>|
+ <A HREF="../../../../toc.html">Contents</a> |
+ <A HREF="../../../../index.html">Home</a> |
+ <A HREF="../aim-8/aim-8.html">Previous</a> |
+ <A HREF="../../index.html">Up</a> |
+ <A HREF="../wang.html">Next</a> |
+</P><HR></DIV>
+<!--MENU-END-->
+<!--BOTTOM-BEGIN-->
+<!-- This section is automatically generated by html-update, -->
+<!-- from data in 'node.el'.    Please, do not edit it here. -->
+<DIV CLASS="BOTTOM">
+<hr><code><small>
+ | <a href="http://www.informatimago.com//develop/lisp/small-cl-pgms/m-expression/index.html">Mirror on informatimago.com</a>
+ | <a href="http://informatimago.free.fr/i//develop/lisp/small-cl-pgms/m-expression/index.html">Mirror on free.fr</a>
+ | </small></code>
+
+<BR><SMALL>Last update : <!--MODIFICATION-DATE--> 2011-01-19 02:07:15
+     by : <!--MODIFICATION-AUTEUR--> Pascal J. Bourguignon
+    </SMALL>
+<BR><SMALL>
+      <a href="http://validator.w3.org/check?uri=referer"><img
+          src="http://www.w3.org/Icons/valid-html401"
+          alt="Valid HTML 4.01!" height="31" width="88"></a>
+   </SMALL>
+</DIV>
+<!--BOTTOM-END-->
+ </BODY>
+</HTML>
diff --git a/small-cl-pgms/m-expression/m-expression.lisp b/small-cl-pgms/m-expression/m-expression.lisp
new file mode 100644
index 0000000..7fe038b
--- /dev/null
+++ b/small-cl-pgms/m-expression/m-expression.lisp
@@ -0,0 +1,571 @@
+;;;;  -*- mode:lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE:               m-expression.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    Here is a M-expression parser.
+;;;;
+;;;;    A lot of lisp newbies ask for more conventionnal syntax for lisp.
+;;;;    Since day one, lisp was intended to have such a syntax: M-expressions.
+;;;;
+;;;;    Let's newbies play with them, and realize how impractical they are.
+;;;;    Note for example, that we cannot use macros anymore because
+;;;;    their syntax would need to be known by the M-expression parser,
+;;;;    like it's the case for lambda[[...];...].
+;;;;    Macros were added later in lisp history.
+;;;;
+;;;;
+;;;;    Note that S-expressions can still be entered, as literal objects,
+;;;;    but using comma instead of space to separate the items in lists.
+;;;;
+;;;;
+;;;;    http://www.informatimago.com/develop/lisp/small-cl-pgms/aim-8/
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2006-09-28 <PJB> Created.
+;;;;BUGS
+;;;;
+;;;;    Symbols are restricted to alphanumeric characters.
+;;;;    This prevents using a lot of Common Lisp symbols.
+;;;;    A more modern syntax for M-expressions could be designed,
+;;;;    but this wasn't the point of the exercise.
+;;;;
+;;;;    In my old transcription of AIM-8, I've used two characters to write
+;;;;    the arrows: ⎯⟶, but in this parser, the first is not accepted,
+;;;;    and arrows must be written either as: ⟶ or as ->.
+;;;;    A new version of the transcription only uses ⟶.
+;;;;
+;;;;LEGAL
+;;;;    GPL
+;;;;
+;;;;    Copyright Pascal Bourguignon 2006 - 2011
+;;;;
+;;;;    This program is free software; you can redistribute it and/or
+;;;;    modify it under the terms of the GNU General Public License
+;;;;    as published by the Free Software Foundation; either version
+;;;;    2 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 General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU General Public
+;;;;    License along with this program; if not, write to the Free
+;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;;    Boston, MA 02111-1307 USA
+;;;;**************************************************************************
+
+(defpackage "COM.INFORMATIMAGO.COMMON-LISP.M-EXPRESSION"
+  (:nicknames "M-EXPR")
+  (:use "COMMON-LISP")
+  (:export "READ-M-EXPRESSION" "PARSE-M-EXPRESSION" "LABEL" "COMBINE"
+           "*LOAD-STREAM*" "M-EXPRESSION"
+           "DRIVER" "DEFINE-M-FUNCTION"
+           "M-REPL"
+           "QUIT" "EXIT" "CONTINUE"))
+(defpackage "M-LISP-USER"
+  (:use "COMMON-LISP")
+  (:import-from "COM.INFORMATIMAGO.COMMON-LISP.M-EXPRESSION"
+                "LABEL" "COMBINE" "QUIT" "EXIT" "CONTINUE"))
+(in-package "COM.INFORMATIMAGO.COMMON-LISP.M-EXPRESSION")
+
+
+
+;; To load this utf-8 file, specify the utf-8 external format:
+;; (load"m-expression.lisp" :external-format #+clisp charset:utf-8 #+sbcl :utf-8)
+;; or convert it first to ASCII...
+
+
+;;      The S-functions have been described by a class of expres-
+;; sions which has been informally introduced.  Let us call these
+;; expressions F-expressions.  If we provide a way of translating
+;; F-expressions into S-expressions, we can use S-functions to
+;; repreent certain functions and predicates of S-expressions.
+;;      First we shall describe this translation.
+;;      3.1  Representation of S-functions as S-expressions.
+;;      The representation is determined by the following rules.
+;;      1.  Constant S-expressions can occur as parts of the
+;; F-expressions representing S-functions.  An S-expression ℰ is
+;; represented by the S-expression.  (QUOTE,ℰ)
+;;      2.  Variables and function names which were represented
+;; by strings of lower case letters are represented by the cor-
+;; responding strings of the corresponding upper case letters.
+;; Thus we have FIRST, REST and COMBINE, and we shall use X,Y
+;; etc. for variables.
+;;      3.  A form is represented by an S-expression whose first
+;; term is the name of the main funcntion and whose remaining terms
+;; are the argumetns of the function.  Thus combin[first[x];
+;; rest[x]] is represented by (COMBINE,(FIRST,X),(REST,X))
+;;      4.  The null S-expression ⋀ is named NIL.
+;;      5.  The truth values  1  and 0  are denoted by T and F.
+;;          The conditional expressoin
+;;      write[p₁⎯⟶e₁,p₂⎯⟶e₂,...pk⎯⟶ek]
+;; is repersented by
+;;           (COND,(p₁,e₁),(p₂,e₂),...(pk,ek))
+;;      6.  λ[[x;..;s];ℰ] is represented by (LAMBDA,(X,...,S),ℰ)
+;;      7.  label[α;ℰ] is represented by (LABEL,α,ℰ)
+;;      8.  x=y is represented by (EQ,X,Y)
+;;      With these conventions the substitution function mentioned
+;; earlier whose F-expression is
+;;      label[subst;λ[[x;y;s];[null[s]⎯⟶⋀;atom[s]⎯⟶
+;;           [y=s⎯⟶x;1⎯⟶s];1⎯⟶combine[subst[x;y;first[s]];
+;;                subst[x;y;rest[s]]]]]]
+;; is represented by the S-expression.
+;;           (LABEL,SUBST,(LAMBDA,(X,Y,Z),(COND,((NULL,
+;;                Z),NIL),((ATOM,Z),(COND)((EQ,Y,Z),X),(1,Z))),
+;;                     (1,(COMBINE,(SUBST,X,Y,(FIRST,Z)),
+;;                          (SUBST,X,Y,(REST,Z))))))
+
+
+
+(defun read-s-number (stream)
+  (let ((sign +1)
+        (int   0)
+        (ch (read-char stream nil nil)))
+    (case ch
+      ((#\+) (setf ch (read-char stream nil nil)))
+      ((#\-) (setf ch (read-char stream nil nil)) (setf sign -1)))
+    (loop
+       :while (and ch (digit-char-p ch))
+       :do (setf int (+ (* 10 int) (digit-char-p ch))
+                 ch  (read-char stream nil nil)))
+    (case ch
+      ((nil) `(:s-integer ,(* sign int)))
+      ((#\.) (let ((frac 0.0)
+                   (weight 0.1))
+               (loop
+                  :initially (setf ch (read-char stream nil nil))
+                  :while (and ch (digit-char-p ch))
+                  :do (setf frac (+ frac (* weight (digit-char-p ch)))
+                            weight (/ weight 10)
+                            ch (read-char stream nil nil)))
+               (case ch
+                 ((nil) `(:s-float ,(* sign (+ int frac))))
+                 ((#\E) (let ((exps +1)
+                              (expo  0))
+                          (setf ch (read-char stream nil nil))
+                          (case ch
+                            ((#\+)
+                             (setf ch (read-char stream nil nil)))
+                            ((#\-)
+                             (setf ch (read-char stream nil nil))
+                             (setf exps -1)))
+                          (loop
+                             :while (and ch (digit-char-p ch))
+                             :do (setf expo (+ (* 10 expo) (digit-char-p ch))
+                                       ch  (read-char stream nil nil)))
+                          (when ch (unread-char ch stream))
+                          `(:s-float ,(* sign
+                                         (+ int frac)
+                                         (expt 10.0 (* exps expo))))))
+                 (otherwise (unread-char ch stream)
+                            (if (alpha-char-p ch)
+                                (error "Invalid token at ~S"
+                                       (read-line stream nil nil))
+                                `(:s-float ,(* sign (+ int frac))))))))
+      (otherwise
+       (unread-char ch stream)
+       (if (alpha-char-p ch)
+           (error "Invalid token at ~S" (read-line stream nil nil))
+           `(:s-integer ,(* sign int)))))))
+
+(defun m-sym-first-char-p (ch)
+  (find ch "abcdefghijklmnopqrstuvwxyz" :test (function char=)))
+(defun m-sym-follow-char-p (ch)
+  (find ch "abcdefghijklmnopqrstuvwxyz0123456789" :test (function char=)))
+(defun s-sym-first-char-p (ch)
+  (find ch "ABCDEFGHIJKLMNOPQRSTUVWXYZ" :test (function char=)))
+(defun s-sym-follow-char-p (ch)
+  (find ch "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" :test (function char=)))
+
+(defun read-m-symbol (stream)
+  (loop
+     :with buffer = (make-array 16 :adjustable t :fill-pointer 0
+                                :element-type 'character)
+     :for ch = (read-char stream nil nil)
+     :while (and ch (m-sym-follow-char-p ch))
+     :do (vector-push-extend ch buffer)
+     :finally (when ch (unread-char ch stream))
+     (return `(:m-symbol ,(intern buffer "M-LISP-USER")))))
+
+(defun read-s-symbol (stream)
+  (loop
+     :with buffer = (make-array 16 :adjustable t :fill-pointer 0
+                                :element-type 'character)
+     :for ch = (read-char stream nil nil)
+     :while (and ch (s-sym-follow-char-p ch))
+     :do (vector-push-extend ch buffer)
+     :finally (when ch (unread-char ch stream))
+     (return `(:s-symbol ,(intern buffer "M-LISP-USER")))))
+
+(defun skip-spaces (stream)
+  (loop
+     :with ch = (read-char stream nil nil)
+     :while (and ch (find ch #(#\space #\newline #\tab
+                               #\return #\linefeed
+                               ;; #\vt
+                               )))
+     :do (setf ch (read-char stream nil nil))
+     :finally (when ch (unread-char ch stream))))
+
+(defun get-token (stream)
+  (skip-spaces stream)
+  (let ((ch (read-char stream nil nil)))
+    (case ch
+      ((nil)  '(:eof))
+      ((#\[)  '(:m-open))
+      ((#\])  '(:m-close))
+      ((#\⟶)  '(:m-arrow))
+      ((#\⋀)  '(:m-symbol |nil|))
+      ((#\λ)  '(:m-symbol |lambda|))
+      ((#\;)  '(:m-sep))
+      ((#\=)  '(:m-equal))
+      ((#\()  '(:s-open))
+      ((#\))  '(:s-close))
+      ((#\,)  '(:s-sep))
+      ((#\+)   (read-s-number stream))
+      ((#\-)
+       (let ((ch (peek-char nil stream nil nil)))
+         (case ch
+           ((nil) (error "Invalid character '-' at ~S"
+                         (read-line stream nil nil)))
+           ((#\>)
+            (read-char stream)
+            '(:m-arrow))
+           ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
+            (unread-char ch stream)
+            (read-s-number stream))
+           (otherwise (error "Invalid character '-' at ~S"
+                             (read-line stream nil nil))))))
+      (otherwise
+       (unread-char ch stream)
+       (cond
+         ((digit-char-p ch)
+          (read-s-number stream))
+         ((m-sym-first-char-p ch) (let ((sym (read-m-symbol stream)))
+                                    (case (second sym)
+                                      ((m-lisp-user::|nil|)   '(:m-nil))
+                                      ((m-lisp-user::|t|)     '(:m-true))
+                                      ((m-lisp-user::|f|)     '(:m-false))
+                                      (otherwise sym))))
+         ((s-sym-first-char-p ch) (read-s-symbol stream))
+         (t  (error "Invalid character '~C' at ~S"
+                    ch (read-line stream nil nil))))))))
+
+(defvar *test-source* "")
+
+(defun test-scanner ()
+  (with-input-from-string (input *test-source*)
+    (loop
+       :for token = (get-token input)
+       :do (print token)
+       :until (eq :eof (first token)))))
+
+;;  (test-scanner)
+
+(defstruct parser current-token stream)
+
+(defun advance (parser)
+  (setf (parser-current-token parser) (get-token (parser-stream parser))))
+
+(defun token-p (token parser)
+    (eql token (first (parser-current-token parser))))
+
+;; m-expr           ::= m-eq | m-term .
+;; m-eq             ::= m-term m-equal m-term .
+;; m-term           ::= m-var | m-call | m-cond | s-expr | m-lambda-list .
+;; m-lambda-list         ::= m-lambda '[' '[' m-pars ']' ';' m-expr ']' .
+;; m-pars           ::= | m-pars-items .
+;; m-pars-items     ::= m-symbol | m-symbol ';' m-pars-items .
+;; m-var            ::= m-symbol .
+;; m-function       ::= m-symbol | m-lambda-list .
+;; m-call           ::= m-function '[' m-args ']' .
+;; m-args           ::= | m-arg-item .
+;; m-arg-items      ::= m-expr | m-expr '   ;' m-args .
+;; m-cond           ::= '[' m-clauses ']' .
+;; m-clauses        ::= | m-clause-items .
+;; m-clause-items   ::= m-clause | m-clause ';' m-clauses .
+;; m-clause         ::= m-expr m-arrow m-expr .
+;; s-expr           ::= s-atom | '(' s-list ')' .
+;; s-list           ::= | s-list-items .
+;; s-list-items     ::= s-expr | s-expr ',' s-list-items .
+;; s-atom           ::= s-symbol | s-integer | s-float | s-string .
+
+;; m-lambda              ::= 'lambda' .
+;; m-nil            ::= 'nil' .
+;; m-true           ::= 't' .
+;; m-false          ::= 'f' .
+;; m-equal          ::= '=' .
+;; m-arrow          ::= '->' .
+;; m-symbol         ::= "[a-z][a-z0-9]*" .
+;; s-symbol         ::= "[A-Z][A-Z0-9]*" .
+;; s-integer        ::= "[-+]?[0-9]+" .
+;; s-float          ::= "[-+]?[0-9]+.[0-9]+(E[-+]?[0-9]+)?" .
+
+
+(defun parse-m-expr (parser)
+  ;; m-expr       ::= m-eq | m-term .
+  ;; m-eq         ::= m-term m-equal m-term .
+  (if (token-p :eof parser)
+      :eof
+      (let ((term1 (parse-m-term parser)))
+        (if (token-p :m-equal parser)
+            (progn (advance parser)
+                   (let ((term2 (parse-m-term parser)))
+                     `(equal ,term1 ,term2)))
+            term1))))
+
+(defun m-to-s-symbol (m-symbol)
+  (intern (string-upcase (second m-symbol)) "M-LISP-USER"))
+
+(defun parse-m-args (parser)
+  ;; m-args           ::= | m-arg-item .
+  ;; m-arg-items      ::= m-expr | m-expr '   ;' m-args .
+  (unless (token-p :m-close parser)
+    (loop
+       :collect (parse-m-expr parser)
+       :while (token-p :m-sep parser)
+       :do (advance parser))))
+
+(defun parse-m-pars (parser)
+  ;; m-pars           ::= | m-pars-items .
+  ;; m-pars-items     ::= m-symbol | m-symbol ';' m-pars-items .
+  (unless (token-p :m-close parser)
+    (loop
+       :collect (parse-m-expr parser)
+       :while (token-p :m-sep parser)
+       :do (advance parser))))
+
+(defun parse-m-clause (parser)
+  ;; m-clause     ::= m-expr m-arrow m-expr .
+  (let ((antecedent (parse-m-expr parser))
+        (consequent (progn
+                      (if (token-p :m-arrow parser)
+                          (advance parser)
+                          (error "Expected an arrow in m-clause, not ~S~% at ~S~
+                               (check your brackets)"
+                                 (parser-current-token parser)
+                                 (read-line (parser-stream parser) nil nil)))
+                      (parse-m-expr parser))))
+    `(,antecedent ,consequent)))
+
+(defun parse-m-clauses (parser)
+  ;; m-clauses    ::= m-clause | m-clause ';' m-clauses .
+  (loop
+     :collect (parse-m-clause parser)
+     :while (token-p :m-sep parser)
+     :do (advance parser)))
+
+
+(defmacro with-parens ((parser open close) &body body)
+  (let ((vparser (gensym)) (vopen (gensym)) (vclose (gensym)))
+    `(let ((,vparser ,parser)
+           (,vopen   ,open)
+           (,vclose  ,close))
+       (unless (token-p ,vopen ,vparser)
+         (error "Expected ~A, not ~S~% at ~S" ,vopen
+                (parser-current-token ,vparser)
+                (read-line (parser-stream ,vparser) nil nil)))
+       (advance ,vparser)
+       (prog1 (progn ,@body)
+         (if (token-p ,vclose ,vparser)
+             (advance ,vparser)
+             (error "Expected ~A, not ~S~% at ~S" ,vclose
+                    (parser-current-token ,vparser)
+                    (read-line (parser-stream ,vparser) nil nil)))))))
+
+
+(defun parse-m-term (parser)
+  ;; m-term       ::= m-var | m-call | m-cond | s-expr | m-lambda-list .
+  (cond
+    ((token-p :m-open parser)           ; m-cond
+     (with-parens (parser :m-open :m-close)
+       `(cond ,@(parse-m-clauses parser))))
+    ((token-p :s-open    parser)       ; S-expr
+     `(quote ,(parse-s-expr parser)))
+    ((or (token-p :s-symbol  parser)
+         (token-p :s-integer parser)
+         (token-p :s-float   parser)
+         (token-p :s-string  parser))
+     (prog1
+         `(quote ,(second (parser-current-token parser)))
+       (advance parser)))
+    ((or (token-p :m-symbol parser) ; M-expr
+         (token-p :m-nil    parser)
+         (token-p :m-true   parser)
+         (token-p :m-false  parser))     ; m-var or m-call
+     (let* ((name (parser-current-token parser))
+            (sname  (cond
+                      ((or (token-p :m-false parser)
+                           (token-p :m-nil parser)) 'nil)
+                      ((token-p :m-true parser)       't)
+                      (t             (m-to-s-symbol name)))))
+       (advance parser)
+       (if (token-p :m-open parser)
+           (with-parens (parser :m-open :m-close)
+             (if (eql 'lambda sname)
+                 `(lambda ,(with-parens (parser :m-open :m-close)
+                                   (parse-m-pars parser))
+                    ,(progn (unless (token-p :m-sep parser)
+                              (error "Expected a semi-colon, not ~S~% at ~S"
+                                     (parser-current-token parser)
+                                     (read-line (parser-stream parser) nil nil)))
+                            (advance parser)
+                            (parse-m-expr parser)))
+                 `(,sname ,@(parse-m-args parser))))
+           sname)))
+    (t (error "Unexpected token in m-term: ~S~% at ~S"
+              (parser-current-token parser)
+              (read-line (parser-stream parser) nil nil)))))
+
+(defun parse-s-list (parser)
+  ;; s-list           ::= | s-list-items .
+  ;; s-list-items     ::= s-expr | s-expr [','] s-list-items .
+  ;; We make comma optional since later m-expression programs (like AIM-16)
+  ;; didn't use it...
+  (unless (token-p :s-close parser)
+    (loop
+       :until (token-p :s-close parser)
+       :collect (parse-s-expr parser)
+       :do (when (token-p :s-sep parser) (advance parser)))))
+
+(defun parse-s-expr (parser)
+  ;; s-expr       ::= s-atom | '(' s-list ')' .
+  ;; s-atom       ::= s-symbol | s-integer | s-float | s-string .
+  (cond
+    ((token-p :s-open parser)
+     (with-parens (parser :s-open :s-close)
+        (parse-s-list parser)))
+    ((or (token-p :s-symbol  parser)
+         (token-p :s-integer parser)
+         (token-p :s-float   parser)
+         (token-p :s-string  parser))
+     (prog1 (second (parser-current-token parser))
+       (advance parser)))
+    (t  (error "Unexpected token in a s-expr: ~S~% at ~S"
+               (parser-current-token parser)
+               (read-line (parser-stream parser) nil nil)))))
+
+
+
+(defparameter *test-source* "
+     label[subst;λ[[x;y;s];[null[s]->nil;atom[s]⟶
+           [y=s->x;1->s];1->combine[subst[x;y;first[s]];
+                subst[x;y;rest[s]]]]]]
+        =
+           (LABEL,SUBST,(LAMBDA,(X,Y,Z),(COND,((NULL,
+                Z),NIL),((ATOM,Z),(COND,((EQ,Y,Z),X),(1,Z))),
+                     (1,(COMBINE,(SUBST,X,Y,(FIRST,Z)),
+                                (SUBST,X,Y,(REST,Z)))))))")
+
+
+(defmacro handling-errors (&body body)
+  `(HANDLER-CASE (progn ,@body)
+     (simple-condition
+         (ERR)
+       (format *error-output* "~&~A: ~%" (class-name (class-of err)))
+       (apply (function format) *error-output*
+              (simple-condition-format-control   err)
+              (simple-condition-format-arguments err))
+       (format *error-output* "~&")
+       (finish-output))
+     (condition
+         (ERR)
+       (format *error-output* "~&~A: ~%  ~S~%"
+               (class-name (class-of err)) err)
+       (finish-output))))
+
+
+(defun m-repl (&key ((input *standard-input*) *standard-input*)
+               ((output *standard-output*) *standard-output*))
+  (let ((parser (make-parser :stream *standard-input*))
+        (*package* (find-package "M-LISP-USER")))
+    (loop
+       :named repl
+       :for history :from 1
+       :do (progn
+             (format t "~%~A[~D]M-REPL> " (package-name *package*) history)
+             (finish-output)
+             (handling-errors
+               (advance parser)
+               (setf - (parse-m-expr parser))
+               (unless (token-p :m-sep parser)
+                 (error "Please terminate your m-expressions with a semi-colon, ~
+                        not ~S" (parser-current-token parser)))
+               (when (or (eq - :eof) (member - '((quit)(exit)(continue))
+                                             :test (function equalp)))
+                 (return-from repl))
+               (let ((results (multiple-value-list (eval -))))
+                 (setf +++ ++   ++ +   + -
+                       /// //   // /   / results
+                       *** **   ** *   * (first /)))
+               (format t "~& --> ~{~S~^ ;~%     ~}~%" /)
+               (finish-output))))))
+
+
+(defun test-parser ()
+  (assert (eql :eof (with-input-from-string (src "")
+                      (let ((parser (make-parser :stream src)))
+                        (advance parser)
+                        (parse-m-expr parser)))))
+  (with-input-from-string (src *test-source*)
+    (let ((parser (make-parser :stream src)))
+      (advance parser)
+      (parse-m-expr parser))))
+
+(defun read-m-expression (&optional (*standard-input* *standard-input*))
+  (let ((parser (make-parser :stream *standard-input*)))
+    (advance parser)
+    (parse-m-expr parser)))
+
+(defun parse-m-expression (text &key (start 0) (end nil))
+  (let ((index nil))
+    (values
+     (with-input-from-string (src text :index index :start start :end end)
+       (read-m-expression src))
+     index)))
+
+
+(defmacro label (name lambda-expression)
+  `(defun ,name ,(cadr lambda-expression) ,@(cddr lambda-expression)))
+
+(defun combine (a d) (cons a d))
+
+(defmacro define-m-function (mexp &optional docstring)
+  (let ((sexp (parse-m-expression mexp)))
+    (if (and (consp sexp)
+             (eq  'equal (first sexp)))
+        `(defun ,(first (second sexp)) ,(rest (second sexp))
+           ,@(when docstring (list docstring))
+           ,@(rest (rest sexp)))
+        (progn
+          (error "M-exp is not a definition: ~%~A~%~S~%" mexp sexp)))))
+
+(defun driver (&optional (*standard-input* *standard-input*))
+  (loop
+     :for form = (read-m-expression)
+     :until (eq :eof form)
+     :do (print (eval
+                 (if (and (consp form) (eq 'equal (car form)))
+                     (if (consp (second form))
+                         `(defun ,(first (second form)) ,(rest (second form))
+                            ,@(rest (rest form)))
+                         `(defparameter ,(second form) ,(third form)))
+                     form))))
+  (values))
+
+(defvar *load-stream* nil
+  "A string of m-expressions, while loaded by M-EXPRESSION.")
+
+(defun m-expression (mexp)
+  (with-input-from-string (*load-stream* mexp)
+    (driver *load-stream*)))
+
+
+;; (load "/net/users/pjb/src/public/small-cl-pgms/m-expression/m-expression.lisp" :external-format charset:utf-8) (use-package :com.informatimago.common-lisp.m-expression)
diff --git a/small-cl-pgms/miscellaneous/clisp-server.lisp b/small-cl-pgms/miscellaneous/clisp-server.lisp
new file mode 100644
index 0000000..33d55a9
--- /dev/null
+++ b/small-cl-pgms/miscellaneous/clisp-server.lisp
@@ -0,0 +1,1436 @@
+#!/usr/local/bin/clisp -q -ansi  -on-error debug
+;;;;**************************************************************************
+;;;;FILE:               clisp-server.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    This script implements a CL server and client.
+;;;;
+;;;;    The server (with the --server option)  waits for connections
+;;;;    on port +PORT+ and then read one form, evaluates it, and sends
+;;;;    back the data printed and the multiple value resulting from
+;;;;    the form, or the error if raised.
+;;;;
+;;;;    The client either sends to the server the forms given on
+;;;;    the command line, or enter a REPL mode (with the --repl option),
+;;;;    from which it reads forms, and sends them to the server.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2006-04-09 <PJB>
+;;;;BUGS
+;;;;
+;;;;    - The current protocol disconnect between each form evaluated.
+;;;;    - We should use the SWANK protocol
+;;;;      (fetch swank client from McClimDesktop).
+;;;;    - The restricted cl package is not free of security leaks yet.
+;;;;    - It's planed to implement a virtual file system from which
+;;;;      the file and stream operators would work.
+;;;;    - It's planed to have a multi-server client, where the same forms
+;;;;      are sent to various implementations of CL and the results
+;;;;      sent back are compared and implementation dependent results
+;;;;      are highlighed.
+;;;;
+;;;;LEGAL
+;;;;    GPL
+;;;;
+;;;;    Copyright Pascal Bourguignon 2006 - 2006
+;;;;
+;;;;    This program is free software; you can redistribute it and/or
+;;;;    modify it under the terms of the GNU General Public License
+;;;;    as published by the Free Software Foundation; either version
+;;;;    2 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 General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU General Public
+;;;;    License along with this program; if not, write to the Free
+;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;;    Boston, MA 02111-1307 USA
+;;;;**************************************************************************
+(eval-when (:compile-topleve :load-toplevel :execute)
+  (setf custom:*load-echo* t))
+
+(defpackage "RESTRICTED-COMMON-LISP"
+  (:nicknames "RCL")
+  (:use "COMMON-LISP")
+  (:shadow "LIST-ALL-PACKAGES" "FIND-PACKAGE"))
+
+(in-package "RESTRICTED-COMMON-LISP")
+
+(defconstant *rcl-exports*
+  '(
+    &ALLOW-OTHER-KEYS &AUX &BODY  &ENVIRONMENT &KEY &OPTIONAL &REST &WHOLE
+
+    ;; *BREAK-ON-SIGNALS*
+    *COMPILE-FILE-PATHNAME*
+    *COMPILE-FILE-TRUENAME*
+    *COMPILE-PRINT*
+    *COMPILE-VERBOSE*
+    ;; *DEBUG-IO*
+    ;; *DEBUGGER-HOOK*
+    *DEFAULT-PATHNAME-DEFAULTS*
+    *ERROR-OUTPUT*
+    *FEATURES*
+    *GENSYM-COUNTER*
+    ;; *LOAD-PATHNAME*
+    *LOAD-PRINT*
+    ;; *LOAD-TRUENAME*
+    *LOAD-VERBOSE*
+    *MACROEXPAND-HOOK*
+    ;; *MODULES*
+    *PACKAGE*
+    *PRINT-ARRAY*
+    *PRINT-BASE*
+    *PRINT-CASE*
+    *PRINT-CIRCLE*
+    *PRINT-ESCAPE*
+    *PRINT-GENSYM*
+    *PRINT-LENGTH*
+    *PRINT-LEVEL*
+    *PRINT-LINES*
+    *PRINT-MISER-WIDTH*
+    *PRINT-PPRINT-DISPATCH*
+    *PRINT-PRETTY*
+    *PRINT-RADIX*
+    *PRINT-READABLY*
+    *PRINT-RIGHT-MARGIN*
+    ;; *QUERY-IO*
+    *RANDOM-STATE*
+    ;; *READ-BASE*
+    ;; *READ-DEFAULT-FLOAT-FORMAT*
+    ;; *READ-EVAL*
+    ;; *READ-SUPPRESS*
+    ;; *READTABLE*
+    *STANDARD-INPUT*
+    *STANDARD-OUTPUT*
+    ;; *TERMINAL-IO*
+    ;; *TRACE-OUTPUT*
+
+    * ** ***
+    + ++ +++
+    -
+    / // ///
+    = /= < <= > >=
+    1+ 1-
+
+
+    ABORT
+    ABS
+    ACONS
+    ACOS
+    ACOSH
+    ADD-METHOD
+    ADJOIN
+    ADJUST-ARRAY
+    ADJUSTABLE-ARRAY-P
+    ALLOCATE-INSTANCE
+    ALPHA-CHAR-P
+    ALPHANUMERICP
+    AND
+    APPEND
+    APPLY
+    APROPOS
+    APROPOS-LIST
+    AREF
+    ARITHMETIC-ERROR
+    ARITHMETIC-ERROR-OPERANDS
+    ARITHMETIC-ERROR-OPERATION
+    ARRAY
+    ARRAY-DIMENSION
+    ARRAY-DIMENSION-LIMIT
+    ARRAY-DIMENSIONS
+    ARRAY-DISPLACEMENT
+    ARRAY-ELEMENT-TYPE
+    ARRAY-HAS-FILL-POINTER-P
+    ARRAY-IN-BOUNDS-P
+    ARRAY-RANK
+    ARRAY-RANK-LIMIT
+    ARRAY-ROW-MAJOR-INDEX
+    ARRAY-TOTAL-SIZE
+    ARRAY-TOTAL-SIZE-LIMIT
+    ARRAYP
+    ASH
+    ASIN
+    ASINH
+    ASSERT
+    ASSOC
+    ASSOC-IF
+    ASSOC-IF-NOT
+    ATAN
+    ATANH
+    ATOM
+    BASE-CHAR
+    BASE-STRING
+    BIGNUM
+    BIT
+    BIT-AND
+    BIT-ANDC1
+    BIT-ANDC2
+    BIT-EQV
+    BIT-IOR
+    BIT-NAND
+    BIT-NOR
+    BIT-NOT
+    BIT-ORC1
+    BIT-ORC2
+    BIT-VECTOR
+    BIT-VECTOR-P
+    BIT-XOR
+    BLOCK
+    BOOLE
+    BOOLE-1
+    BOOLE-2
+    BOOLE-AND
+    BOOLE-ANDC1
+    BOOLE-ANDC2
+    BOOLE-C1
+    BOOLE-C2
+    BOOLE-CLR
+    BOOLE-EQV
+    BOOLE-IOR
+    BOOLE-NAND
+    BOOLE-NOR
+    BOOLE-ORC1
+    BOOLE-ORC2
+    BOOLE-SET
+    BOOLE-XOR
+    BOOLEAN
+    BOTH-CASE-P
+    BOUNDP
+    BREAK
+    BROADCAST-STREAM
+    BROADCAST-STREAM-STREAMS
+    BUILT-IN-CLASS
+    BUTLAST
+    BYTE
+    BYTE-POSITION
+    BYTE-SIZE
+    CAAAAR
+    CAAADR
+    CAAAR
+    CAADAR
+    CAADDR
+    CAADR
+    CAAR
+    CADAAR
+    CADADR
+    CADAR
+    CADDAR
+    CADDDR
+    CADDR
+    CADR
+    CALL-ARGUMENTS-LIMIT
+    CALL-METHOD
+    CALL-NEXT-METHOD
+    CAR
+    CASE
+    CATCH
+    CCASE
+    CDAAAR
+    CDAADR
+    CDAAR
+    CDADAR
+    CDADDR
+    CDADR
+    CDAR
+    CDDAAR
+    CDDADR
+    CDDAR
+    CDDDAR
+    CDDDDR
+    CDDDR
+    CDDR
+    CDR
+    CEILING
+    CELL-ERROR
+    CELL-ERROR-NAME
+    CERROR
+    CHANGE-CLASS
+    CHAR
+    CHAR-CODE
+    CHAR-CODE-LIMIT
+    CHAR-DOWNCASE
+    CHAR-EQUAL
+    CHAR-GREATERP
+    CHAR-INT
+    CHAR-LESSP
+    CHAR-NAME
+    CHAR-NOT-EQUAL
+    CHAR-NOT-GREATERP
+    CHAR-NOT-LESSP
+    CHAR-UPCASE
+    CHAR/=
+    CHAR<
+    CHAR<=
+    CHAR=
+    CHAR>
+    CHAR>=
+    CHARACTER
+    CHARACTERP
+    CHECK-TYPE
+    CIS
+    CLASS
+    CLASS-NAME
+    CLASS-OF
+    CLEAR-INPUT
+    CLEAR-OUTPUT
+    CLOSE
+    CLRHASH
+    CODE-CHAR
+    COERCE
+    COMPILATION-SPEED
+    COMPILE
+    COMPILE-FILE
+    COMPILE-FILE-PATHNAME
+    COMPILED-FUNCTION
+    COMPILED-FUNCTION-P
+    COMPILER-MACRO
+    COMPILER-MACRO-FUNCTION
+    COMPLEMENT
+    COMPLEX
+    COMPLEXP
+    COMPUTE-APPLICABLE-METHODS
+    COMPUTE-RESTARTS
+    CONCATENATE
+    CONCATENATED-STREAM
+    CONCATENATED-STREAM-STREAMS
+    COND
+    CONDITION
+    CONJUGATE
+    CONS
+    CONSP
+    CONSTANTLY
+    CONSTANTP
+    CONTINUE
+    CONTROL-ERROR
+    COPY-ALIST
+    COPY-LIST
+    COPY-PPRINT-DISPATCH
+    COPY-READTABLE
+    COPY-SEQ
+    COPY-STRUCTURE
+    COPY-SYMBOL
+    COPY-TREE
+    COS
+    COSH
+    COUNT
+    COUNT-IF
+    COUNT-IF-NOT
+    CTYPECASE
+    DEBUG
+    DECF
+    DECLAIM
+    DECLARATION
+    DECLARE
+    DECODE-FLOAT
+    DECODE-UNIVERSAL-TIME
+    DEFCLASS
+    DEFCONSTANT
+    DEFGENERIC
+    DEFINE-COMPILER-MACRO
+    DEFINE-CONDITION
+    DEFINE-METHOD-COMBINATION
+    DEFINE-MODIFY-MACRO
+    DEFINE-SETF-EXPANDER
+    DEFINE-SYMBOL-MACRO
+    DEFMACRO
+    DEFMETHOD
+    DEFPACKAGE
+    DEFPARAMETER
+    DEFSETF
+    DEFSTRUCT
+    DEFTYPE
+    DEFUN
+    DEFVAR
+    DELETE
+    DELETE-DUPLICATES
+    ;; DELETE-FILE
+    DELETE-IF
+    DELETE-IF-NOT
+    DELETE-PACKAGE
+    DENOMINATOR
+    DEPOSIT-FIELD
+    DESCRIBE
+    DESCRIBE-OBJECT
+    DESTRUCTURING-BIND
+    DIGIT-CHAR
+    DIGIT-CHAR-P
+    ;; DIRECTORY
+    DIRECTORY-NAMESTRING
+    DISASSEMBLE
+    DIVISION-BY-ZERO
+    DO
+    DO*
+    DO-ALL-SYMBOLS
+    DO-EXTERNAL-SYMBOLS
+    DO-SYMBOLS
+    DOCUMENTATION
+    DOLIST
+    DOTIMES
+    DOUBLE-FLOAT
+    DOUBLE-FLOAT-EPSILON
+    DOUBLE-FLOAT-NEGATIVE-EPSILON
+    DPB
+    ;; DRIBBLE
+    DYNAMIC-EXTENT
+    ECASE
+    ECHO-STREAM
+    ECHO-STREAM-INPUT-STREAM
+    ECHO-STREAM-OUTPUT-STREAM
+    ;; ED
+    EIGHTH
+    ELT
+    ENCODE-UNIVERSAL-TIME
+    END-OF-FILE
+    ENDP
+    ENOUGH-NAMESTRING
+    ;; ENSURE-DIRECTORIES-EXIST
+    ENSURE-GENERIC-FUNCTION
+    EQ
+    EQL
+    EQUAL
+    EQUALP
+    ERROR
+    ETYPECASE
+    ;; EVAL
+    EVAL-WHEN
+    EVENP
+    EVERY
+    EXP
+    EXPORT
+    EXPT
+    EXTENDED-CHAR
+    FBOUNDP
+    FCEILING
+    FDEFINITION
+    FFLOOR
+    FIFTH
+    FILE-AUTHOR
+    FILE-ERROR
+    FILE-ERROR-PATHNAME
+    FILE-LENGTH
+    FILE-NAMESTRING
+    FILE-POSITION
+    FILE-STREAM
+    FILE-STRING-LENGTH
+    FILE-WRITE-DATE
+    FILL
+    FILL-POINTER
+    FIND
+    ;; FIND-ALL-SYMBOLS
+    FIND-CLASS           ; IS PROBABLY A SECURITY LEAK (Gray streams?)
+    FIND-IF
+    FIND-IF-NOT
+    FIND-METHOD
+    FIND-PACKAGE                        ; shadowed
+    FIND-RESTART
+    ;; FIND-SYMBOL
+    FINISH-OUTPUT
+    FIRST
+    FIXNUM
+    FLET
+    FLOAT
+    FLOAT-DIGITS
+    FLOAT-PRECISION
+    FLOAT-RADIX
+    FLOAT-SIGN
+    FLOATING-POINT-INEXACT
+    FLOATING-POINT-INVALID-OPERATION
+    FLOATING-POINT-OVERFLOW
+    FLOATING-POINT-UNDERFLOW
+    FLOATP
+    FLOOR
+    FMAKUNBOUND
+    FORCE-OUTPUT
+    FORMAT
+    FORMATTER
+    FOURTH
+    FRESH-LINE
+    FROUND
+    FTRUNCATE
+    FTYPE
+    FUNCALL
+    FUNCTION
+    FUNCTION-KEYWORDS
+    FUNCTION-LAMBDA-EXPRESSION
+    FUNCTIONP
+    GCD
+    GENERIC-FUNCTION
+    GENSYM
+    GENTEMP
+    GET
+    GET-DECODED-TIME
+    GET-DISPATCH-MACRO-CHARACTER
+    GET-INTERNAL-REAL-TIME
+    GET-INTERNAL-RUN-TIME
+    GET-MACRO-CHARACTER
+    GET-OUTPUT-STREAM-STRING
+    GET-PROPERTIES
+    GET-SETF-EXPANSION
+    GET-UNIVERSAL-TIME
+    GETF
+    GETHASH
+    GO
+    GRAPHIC-CHAR-P
+    HANDLER-BIND
+    HANDLER-CASE
+    HASH-TABLE
+    HASH-TABLE-COUNT
+    HASH-TABLE-P
+    HASH-TABLE-REHASH-SIZE
+    HASH-TABLE-REHASH-THRESHOLD
+    HASH-TABLE-SIZE
+    HASH-TABLE-TEST
+    HOST-NAMESTRING
+    IDENTITY
+    IF
+    IGNORABLE
+    IGNORE
+    IGNORE-ERRORS
+    IMAGPART
+    IMPORT
+    ;; IN-PACKAGE
+    INCF
+    INITIALIZE-INSTANCE
+    INLINE
+    INPUT-STREAM-P
+    ;; INSPECT
+    INTEGER
+    INTEGER-DECODE-FLOAT
+    INTEGER-LENGTH
+    INTEGERP
+    INTERACTIVE-STREAM-P
+    ;; INTERN
+    INTERNAL-TIME-UNITS-PER-SECOND
+    INTERSECTION
+    INVALID-METHOD-ERROR
+    INVOKE-DEBUGGER
+    INVOKE-RESTART
+    INVOKE-RESTART-INTERACTIVELY
+    ISQRT
+    KEYWORD
+    KEYWORDP
+    LABELS
+    LAMBDA
+    LAMBDA-LIST-KEYWORDS
+    LAMBDA-PARAMETERS-LIMIT
+    LAST
+    LCM
+    LDB
+    LDB-TEST
+    LDIFF
+    LEAST-NEGATIVE-DOUBLE-FLOAT
+    LEAST-NEGATIVE-LONG-FLOAT
+    LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT
+    LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT
+    LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT
+    LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT
+    LEAST-NEGATIVE-SHORT-FLOAT
+    LEAST-NEGATIVE-SINGLE-FLOAT
+    LEAST-POSITIVE-DOUBLE-FLOAT
+    LEAST-POSITIVE-LONG-FLOAT
+    LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT
+    LEAST-POSITIVE-NORMALIZED-LONG-FLOAT
+    LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT
+    LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT
+    LEAST-POSITIVE-SHORT-FLOAT
+    LEAST-POSITIVE-SINGLE-FLOAT
+    LENGTH
+    LET
+    LET*
+    LISP-IMPLEMENTATION-TYPE
+    LISP-IMPLEMENTATION-VERSION
+    LIST
+    LIST*
+    LIST-ALL-PACKAGES                   ; shadowed
+    LIST-LENGTH
+    LISTEN
+    LISTP
+    ;; LOAD
+    LOAD-LOGICAL-PATHNAME-TRANSLATIONS
+    LOAD-TIME-VALUE
+    LOCALLY
+    LOG
+    LOGAND
+    LOGANDC1
+    LOGANDC2
+    LOGBITP
+    LOGCOUNT
+    LOGEQV
+    LOGICAL-PATHNAME
+    LOGICAL-PATHNAME-TRANSLATIONS
+    LOGIOR
+    LOGNAND
+    LOGNOR
+    LOGNOT
+    LOGORC1
+    LOGORC2
+    LOGTEST
+    LOGXOR
+    LONG-FLOAT
+    LONG-FLOAT-EPSILON
+    LONG-FLOAT-NEGATIVE-EPSILON
+    LONG-SITE-NAME
+    LOOP
+    LOOP-FINISH
+    LOWER-CASE-P
+    MACHINE-INSTANCE
+    MACHINE-TYPE
+    MACHINE-VERSION
+    MACRO-FUNCTION
+    MACROEXPAND
+    MACROEXPAND-1
+    MACROLET
+    MAKE-ARRAY
+    MAKE-BROADCAST-STREAM
+    MAKE-CONCATENATED-STREAM
+    MAKE-CONDITION
+    MAKE-DISPATCH-MACRO-CHARACTER
+    MAKE-ECHO-STREAM
+    MAKE-HASH-TABLE
+    MAKE-INSTANCE
+    MAKE-INSTANCES-OBSOLETE
+    MAKE-LIST
+    MAKE-LOAD-FORM
+    MAKE-LOAD-FORM-SAVING-SLOTS
+    MAKE-METHOD
+    ;; MAKE-PACKAGE
+    ;; MAKE-PATHNAME
+    MAKE-RANDOM-STATE
+    MAKE-SEQUENCE
+    MAKE-STRING
+    MAKE-STRING-INPUT-STREAM
+    MAKE-STRING-OUTPUT-STREAM
+    MAKE-SYMBOL
+    MAKE-SYNONYM-STREAM
+    MAKE-TWO-WAY-STREAM
+    MAKUNBOUND
+    MAP
+    MAP-INTO
+    MAPC
+    MAPCAN
+    MAPCAR
+    MAPCON
+    MAPHASH
+    MAPL
+    MAPLIST
+    MASK-FIELD
+    MAX
+    MEMBER
+    MEMBER-IF
+    MEMBER-IF-NOT
+    MERGE
+    ;; MERGE-PATHNAMES
+    METHOD
+    METHOD-COMBINATION
+    METHOD-COMBINATION-ERROR
+    METHOD-QUALIFIERS
+    MIN
+    MINUSP
+    MISMATCH
+    MOD
+    MOST-NEGATIVE-DOUBLE-FLOAT
+    MOST-NEGATIVE-FIXNUM
+    MOST-NEGATIVE-LONG-FLOAT
+    MOST-NEGATIVE-SHORT-FLOAT
+    MOST-NEGATIVE-SINGLE-FLOAT
+    MOST-POSITIVE-DOUBLE-FLOAT
+    MOST-POSITIVE-FIXNUM
+    MOST-POSITIVE-LONG-FLOAT
+    MOST-POSITIVE-SHORT-FLOAT
+    MOST-POSITIVE-SINGLE-FLOAT
+    MUFFLE-WARNING
+    MULTIPLE-VALUE-BIND
+    MULTIPLE-VALUE-CALL
+    MULTIPLE-VALUE-LIST
+    MULTIPLE-VALUE-PROG1
+    MULTIPLE-VALUE-SETQ
+    MULTIPLE-VALUES-LIMIT
+    NAME-CHAR
+    ;; NAMESTRING
+    NBUTLAST
+    NCONC
+    NEXT-METHOD-P
+    NIL
+    NINTERSECTION
+    NINTH
+    NO-APPLICABLE-METHOD
+    NO-NEXT-METHOD
+    NOT
+    NOTANY
+    NOTEVERY
+    NOTINLINE
+    NRECONC
+    NREVERSE
+    NSET-DIFFERENCE
+    NSET-EXCLUSIVE-OR
+    NSTRING-CAPITALIZE
+    NSTRING-DOWNCASE
+    NSTRING-UPCASE
+    NSUBLIS
+    NSUBST
+    NSUBST-IF
+    NSUBST-IF-NOT
+    NSUBSTITUTE
+    NSUBSTITUTE-IF
+    NSUBSTITUTE-IF-NOT
+    NTH
+    NTH-VALUE
+    NTHCDR
+    NULL
+    NUMBER
+    NUMBERP
+    NUMERATOR
+    NUNION
+    ODDP
+    ;; OPEN
+    OPEN-STREAM-P
+    OPTIMIZE
+    OR
+    OTHERWISE
+    OUTPUT-STREAM-P
+    PACKAGE
+    PACKAGE-ERROR
+    PACKAGE-ERROR-PACKAGE
+    PACKAGE-NAME
+    PACKAGE-NICKNAMES
+    PACKAGE-SHADOWING-SYMBOLS
+    PACKAGE-USE-LIST
+    PACKAGE-USED-BY-LIST
+    PACKAGEP
+    PAIRLIS
+    PARSE-ERROR
+    PARSE-INTEGER
+    PARSE-NAMESTRING
+    PATHNAME
+    PATHNAME-DEVICE
+    PATHNAME-DIRECTORY
+    PATHNAME-HOST
+    PATHNAME-MATCH-P
+    PATHNAME-NAME
+    PATHNAME-TYPE
+    PATHNAME-VERSION
+    PATHNAMEP
+    PEEK-CHAR
+    PHASE
+    PI
+    PLUSP
+    POP
+    POSITION
+    POSITION-IF
+    POSITION-IF-NOT
+    PPRINT
+    PPRINT-DISPATCH
+    PPRINT-EXIT-IF-LIST-EXHAUSTED
+    PPRINT-FILL
+    PPRINT-INDENT
+    PPRINT-LINEAR
+    PPRINT-LOGICAL-BLOCK
+    PPRINT-NEWLINE
+    PPRINT-POP
+    PPRINT-TAB
+    PPRINT-TABULAR
+    PRIN1
+    PRIN1-TO-STRING
+    PRINC
+    PRINC-TO-STRING
+    PRINT
+    PRINT-NOT-READABLE
+    PRINT-NOT-READABLE-OBJECT
+    PRINT-OBJECT
+    PRINT-UNREADABLE-OBJECT
+    ;; PROBE-FILE
+    PROCLAIM
+    PROG
+    PROG*
+    PROG1
+    PROG2
+    PROGN
+    PROGRAM-ERROR
+    PROGV
+    PROVIDE
+    PSETF
+    PSETQ
+    PUSH
+    PUSHNEW
+    QUOTE
+    RANDOM
+    RANDOM-STATE
+    RANDOM-STATE-P
+    RASSOC
+    RASSOC-IF
+    RASSOC-IF-NOT
+    RATIO
+    RATIONAL
+    RATIONALIZE
+    RATIONALP
+    READ
+    READ-BYTE
+    READ-CHAR
+    READ-CHAR-NO-HANG
+    READ-DELIMITED-LIST
+    READ-FROM-STRING
+    READ-LINE
+    READ-PRESERVING-WHITESPACE
+    READ-SEQUENCE
+    READER-ERROR
+    READTABLE
+    READTABLE-CASE
+    READTABLEP
+    REAL
+    REALP
+    REALPART
+    REDUCE
+    REINITIALIZE-INSTANCE
+    REM
+    REMF
+    REMHASH
+    REMOVE
+    REMOVE-DUPLICATES
+    REMOVE-IF
+    REMOVE-IF-NOT
+    REMOVE-METHOD
+    REMPROP
+    RENAME-FILE
+    RENAME-PACKAGE
+    REPLACE
+    REQUIRE
+    REST
+    RESTART
+    RESTART-BIND
+    RESTART-CASE
+    RESTART-NAME
+    RETURN
+    RETURN-FROM
+    REVAPPEND
+    REVERSE
+    ROOM
+    ROTATEF
+    ROUND
+    ROW-MAJOR-AREF
+    RPLACA
+    RPLACD
+    SAFETY
+    SATISFIES
+    SBIT
+    SCALE-FLOAT
+    SCHAR
+    SEARCH
+    SECOND
+    SEQUENCE
+    SERIOUS-CONDITION
+    SET
+    SET-DIFFERENCE
+    SET-DISPATCH-MACRO-CHARACTER
+    SET-EXCLUSIVE-OR
+    SET-MACRO-CHARACTER
+    SET-PPRINT-DISPATCH
+    SET-SYNTAX-FROM-CHAR
+    SETF
+    SETQ
+    SEVENTH
+    SHADOW
+    SHADOWING-IMPORT
+    SHARED-INITIALIZE
+    SHIFTF
+    SHORT-FLOAT
+    SHORT-FLOAT-EPSILON
+    SHORT-FLOAT-NEGATIVE-EPSILON
+    SHORT-SITE-NAME
+    SIGNAL
+    SIGNED-BYTE
+    SIGNUM
+    SIMPLE-ARRAY
+    SIMPLE-BASE-STRING
+    SIMPLE-BIT-VECTOR
+    SIMPLE-BIT-VECTOR-P
+    SIMPLE-CONDITION
+    SIMPLE-CONDITION-FORMAT-ARGUMENTS
+    SIMPLE-CONDITION-FORMAT-CONTROL
+    SIMPLE-ERROR
+    SIMPLE-STRING
+    SIMPLE-STRING-P
+    SIMPLE-TYPE-ERROR
+    SIMPLE-VECTOR
+    SIMPLE-VECTOR-P
+    SIMPLE-WARNING
+    SIN
+    SINGLE-FLOAT
+    SINGLE-FLOAT-EPSILON
+    SINGLE-FLOAT-NEGATIVE-EPSILON
+    SINH
+    SIXTH
+    SLEEP
+    SLOT-BOUNDP
+    SLOT-EXISTS-P
+    SLOT-MAKUNBOUND
+    SLOT-MISSING
+    SLOT-UNBOUND
+    SLOT-VALUE
+    SOFTWARE-TYPE
+    SOFTWARE-VERSION
+    SOME
+    SORT
+    SPACE
+    SPECIAL
+    SPECIAL-OPERATOR-P
+    SPEED
+    SQRT
+    STABLE-SORT
+    STANDARD
+    STANDARD-CHAR
+    STANDARD-CHAR-P
+    STANDARD-CLASS
+    STANDARD-GENERIC-FUNCTION
+    STANDARD-METHOD
+    STANDARD-OBJECT
+    STEP
+    STORAGE-CONDITION
+    STORE-VALUE
+    STREAM
+    STREAM-ELEMENT-TYPE
+    STREAM-ERROR
+    STREAM-ERROR-STREAM
+    STREAM-EXTERNAL-FORMAT
+    STREAMP
+    STRING
+    STRING-CAPITALIZE
+    STRING-DOWNCASE
+    STRING-EQUAL
+    STRING-GREATERP
+    STRING-LEFT-TRIM
+    STRING-LESSP
+    STRING-NOT-EQUAL
+    STRING-NOT-GREATERP
+    STRING-NOT-LESSP
+    STRING-RIGHT-TRIM
+    STRING-STREAM
+    STRING-TRIM
+    STRING-UPCASE
+    STRING/=
+    STRING<
+    STRING<=
+    STRING=
+    STRING>
+    STRING>=
+    STRINGP
+    STRUCTURE
+    STRUCTURE-CLASS
+    STRUCTURE-OBJECT
+    STYLE-WARNING
+    SUBLIS
+    SUBSEQ
+    SUBSETP
+    SUBST
+    SUBST-IF
+    SUBST-IF-NOT
+    SUBSTITUTE
+    SUBSTITUTE-IF
+    SUBSTITUTE-IF-NOT
+    SUBTYPEP
+    SVREF
+    SXHASH
+    SYMBOL
+    SYMBOL-FUNCTION
+    SYMBOL-MACROLET
+    SYMBOL-NAME
+    SYMBOL-PACKAGE
+    SYMBOL-PLIST
+    SYMBOL-VALUE
+    SYMBOLP
+    SYNONYM-STREAM
+    SYNONYM-STREAM-SYMBOL
+    T
+    TAGBODY
+    TAILP
+    TAN
+    TANH
+    TENTH
+    TERPRI
+    THE
+    THIRD
+    THROW
+    TIME
+    TRACE
+    TRANSLATE-LOGICAL-PATHNAME
+    TRANSLATE-PATHNAME
+    TREE-EQUAL
+    TRUENAME
+    TRUNCATE
+    TWO-WAY-STREAM
+    TWO-WAY-STREAM-INPUT-STREAM
+    TWO-WAY-STREAM-OUTPUT-STREAM
+    TYPE
+    TYPE-ERROR
+    TYPE-ERROR-DATUM
+    TYPE-ERROR-EXPECTED-TYPE
+    TYPE-OF
+    TYPECASE
+    TYPEP
+    UNBOUND-SLOT
+    UNBOUND-SLOT-INSTANCE
+    UNBOUND-VARIABLE
+    UNDEFINED-FUNCTION
+    UNEXPORT
+    UNINTERN
+    UNION
+    UNLESS
+    UNREAD-CHAR
+    UNSIGNED-BYTE
+    UNTRACE
+    UNUSE-PACKAGE
+    UNWIND-PROTECT
+    UPDATE-INSTANCE-FOR-DIFFERENT-CLASS
+    UPDATE-INSTANCE-FOR-REDEFINED-CLASS
+    UPGRADED-ARRAY-ELEMENT-TYPE
+    UPGRADED-COMPLEX-PART-TYPE
+    UPPER-CASE-P
+    USE-PACKAGE
+    USE-VALUE
+    USER-HOMEDIR-PATHNAME
+    VALUES
+    VALUES-LIST
+    VARIABLE
+    VECTOR
+    VECTOR-POP
+    VECTOR-PUSH
+    VECTOR-PUSH-EXTEND
+    VECTORP
+    WARN
+    WARNING
+    WHEN
+    WILD-PATHNAME-P
+    WITH-ACCESSORS
+    WITH-COMPILATION-UNIT
+    WITH-CONDITION-RESTARTS
+    WITH-HASH-TABLE-ITERATOR
+    WITH-INPUT-FROM-STRING
+    ;; WITH-OPEN-FILE
+    ;; WITH-OPEN-STREAM
+    WITH-OUTPUT-TO-STRING
+    ;; WITH-PACKAGE-ITERATOR
+    WITH-SIMPLE-RESTART
+    WITH-SLOTS
+    WITH-STANDARD-IO-SYNTAX
+    WRITE
+    WRITE-BYTE
+    WRITE-CHAR
+    WRITE-LINE
+    WRITE-SEQUENCE
+    WRITE-STRING
+    WRITE-TO-STRING
+    Y-OR-N-P
+    YES-OR-NO-P
+    ZEROP
+    ))
+
+(export *rcl-exports*)
+
+(defpackage "RESTRICTED-COMMON-LISP-USER"
+  (:nicknames "RCL-USER")
+  (:use  "RESTRICTED-COMMON-LISP"))
+
+(in-package "RESTRICTED-COMMON-LISP")
+
+(defvar *all-packages* (mapcar (function cl:find-package)
+                               '("RESTRICTED-COMMON-LISP"
+                                 "RESTRICTED-COMMON-LISP-USER"
+                                 "KEYWORD"
+                                 #+(and clisp regexp) "REGEXP")))
+(defun list-all-packages () (copy-list *all-packages*))
+(defun find-package (name)
+  (let ((name (cl:find-package name)))
+    (and (member name *all-packages*) name)))
+
+
+(in-package "COMMON-LISP-USER")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; PARSE-SEXP
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Cuts an input stream into strings containing one token.
+;;;
+;;; (with-input-from-string (in "a 1 \"s\" pac:sym | hi | \\abc #|com|# ;com
+;;;  (1 2 3) #2A((a b) (c d)) #x123 #'fun")
+;;;   (loop :for s = (parse-sexp in nil nil) :while s  :collect s))
+;;; -->
+;;; ("a " "1 " "\"s\"" " pac:sym " "| hi |" " \\abc " "#|com|# ;com
+;;;  (1 2 3)" " #2A((a b) (c d)) " "#x123 #'fun")
+
+(define-condition sexp-end-of-file (end-of-file simple-condition)
+  ())
+
+#+(or)
+(defconstant +character-syntax-types+
+  ;; Other characters are constituents.
+  (:whitespace      .  #( #\Space #\Newline #\Tab #\Return #\Linefeed #\Page ))
+  (:multiple-escape             . "|")
+  (:non-terminating-macro-char  . "#")
+  (:single-escape               . "\\")
+  (:terminating-macro-char      . "\"'(),;`"))
+
+(defconstant +white-spaces+
+  '(#\Space #\Newline #\Tab #\Return #\Linefeed #\Page))
+(defconstant +digits+
+  '#.(loop :for i :from 0 :to 9 :collect (digit-char i)))
+
+(defun parse-sexp (&optional (stream *standard-input*)
+                   (eof-error-p t) (eof-value nil))
+  "Read character on STREAM and collect them in a string,
+parsing up to one sexp.
+If an EOF occurs during the parsing of an object,
+a SEXP-END-OF-FILE condition is raised.
+If an EOF occurs before a sexp is read,
+then either a SEXP-END-OF-FILE condition is raised
+or the EOF-VALUE is returned according to EOF-ERROR-P.
+Spaces, and comments are read and collected in the output string.
+The syntax for strings, comment and lists is the default CL reader one.
+No reader macro is processed.  #2A(a b c) is parsed as two tokens:
+#2A and (a b c).
+"
+  ;; sexp ::= token
+  ;; token ::= string | text | semi-colon-comment | sharp-pipe-comment
+  ;; text ::= /([^ ]|\.)+/
+  ;; string ::= /"([^"]|\.)*"/
+  ;; semi-colon-comment ::= /;.*$/
+  ;; sharp-pipe-comment ::= #| ( text-comment | sharp-pipe-comment )* |#
+  (with-output-to-string (text)
+    (loop
+       :named parser
+       :with state = :init
+       :with stack = '()
+       :for ch = (peek-char nil stream nil nil)
+       :do (labels
+               ((accept (ch) (princ (read-char stream) text))
+                (rerror (eof-error-p ctrlstr &rest args)
+                  (if eof-error-p
+                      (error (make-instance 'sexp-end-of-file
+                               :format-control (concatenate 'string "~A: "
+                                                            ctrlstr)
+                               :format-arguments (cons 'parse-sexp args)
+                               :stream stream))
+                      (return-from parse-sexp eof-value)))
+                (eof-error (where)
+                  (rerror t "input stream ~S ends within ~A" stream where))
+                (end (token)
+                  (case token
+                    ((:eof)
+                     (rerror eof-error-p
+                             "input stream ~S has reached its end"
+                             stream))
+                    ((:eof-object)   (eof-error "an object"))
+                    ((:eof-string)   (eof-error "a string"))
+                    ((:eof-sharp)    (eof-error
+                                      "a read macro beginning with #\\#"))
+                    ((:eof-comment)  (eof-error "a comment #| ... |#"))
+                    ((:eof-single)   (eof-error
+                                      "a token after single escape character"))
+                    ((:eof-multiple) (eof-error
+                                      "a token after multiple escape character"))
+                    ((:close)
+                     (rerror t "READ from ~S: an object cannot start with #\\)"
+                             stream))
+                    (otherwise (loop-finish))))
+                (shift (new-state) (setf state new-state))
+                (spop () (funcall (pop stack))))
+             (macrolet ((spush (return new-state)
+                          `(progn (push (lambda () ,(if (keywordp return)
+                                                        `(shift ,return)
+                                                        return)) stack)
+                                  (shift ,new-state))))
+               (ecase state
+                 ((:init)
+                  (case ch
+                    (#.+white-spaces+ (accept ch))
+                    ((#\;)         (accept ch) (spush :init     :semi-comment))
+                    ((#\")         (accept ch) (spush (end :string) :string))
+                    ((#\()         (accept ch) (spush (end :list)   :list))
+                    ((#\))         (end :close))
+                    ((#\' #\, #\`) (accept ch))
+                    ((#\#)         (accept ch) (shift :init-sharp))
+                    ((nil)         (end :eof))
+                    ((#\\)         (spush (end :token) :token))
+                    ((#\|)         (spush (end :token) :token))
+                    (otherwise     (accept ch) (spush (end :token) :token))))
+                 ((:init-sharp)
+                  (case ch
+                    ((#\|)       (accept ch) (spush :init        :comment))
+                    ((nil)       (end :eof-sharp))
+                    (otherwise   (accept ch) (spush (end :token) :sharp-token))))
+                 ((:list-sharp)
+                  (case ch
+                    ((#\|)       (accept ch) (spush :list :comment))
+                    ((nil)       (end :eof-sharp))
+                    (otherwise   (accept ch) (spush :list :sharp-token))))
+                 ((:semi-comment)
+                  (case ch
+                    ((#\newline) (accept ch) (spop))
+                    ((nil)       (end (if (null stack) :eof :eof-object)))
+                    (otherwise   (accept ch))))
+                 ((:string)
+                  (case ch
+                    ((#\\)       (accept ch) (shift :string-escape))
+                    ((#\")       (accept ch) (spop))
+                    ((nil)       (end :eof-string))
+                    (otherwise   (accept ch))))
+                 ((:string-escape)
+                  (case ch
+                    ((nil)       (end :eof-string))
+                    (otherwise   (accept ch) (shift :string))))
+                 ((:comment)
+                  (case ch
+                    ((#\|)       (accept ch) (shift :comment-end))
+                    ((#\#)       (accept ch) (shift :comment-sharp))
+                    ((nil)       (end :eof-comment))
+                    (otherwise   (accept ch))))
+                 ((:comment-end)
+                  (case ch
+                    ((#\#)       (accept ch) (spop))
+                    ((nil)       (end :eof-comment))
+                    (otherwise   (accept ch) (shift :comment))))
+                 ((:comment-sharp)
+                  (case ch
+                    ((#\|)       (accept ch) (spush :comment  :comment))
+                    ((nil)       (end :eof-comment))
+                    (otherwise   (accept ch) (shift :comment))))
+                 ((:list)
+                  (case ch
+                    (#.+white-spaces+ (accept ch))
+                    ((#\;)         (accept ch) (spush :list :semi-comment))
+                    ((#\")         (accept ch) (spush :list :string))
+                    ((#\()         (accept ch) (spush :list :list))
+                    ((#\#)         (accept ch) (shift :list-sharp))
+                    ((#\))         (accept ch) (spop))
+                    ((#\' #\, #\`) (accept ch))
+                    ((nil)         (end :eof-object))
+                    (otherwise     (accept ch) (spush :list :token))))
+                 ((:token)
+                  (case ch
+                    (#.+white-spaces+ (accept ch) (spop))
+                    ((#\;)            (accept ch) (spush (spop) :semi-comment))
+                    ((#\\)            (accept ch) (spush :token :single-escape))
+                    ((#\|)            (accept ch) (shift :multiple-escape))
+                    ((#\")            (spop))
+                    ((#\( #\))        (spop))
+                    ((#\' #\, #\`)    (spop))
+                    ((nil)            (spop))
+                    (otherwise (accept ch))))
+                 ((:sharp-token)
+                  (case ch
+                    (#.+digits+       (accept ch))
+                    ((#\: #\@)        (accept ch) (shift :sharp-colon-at))
+                    ((nil)            (end :eof-object))
+                    (otherwise        (accept ch) (shift :sharp-rest))))
+                 ((:sharp-colon-at)
+                  (case ch
+                    ((#\: #\@)        (accept ch))
+                    ((nil)            (end :eof-object))
+                    (otherwise        (accept ch) (shift :sharp-rest))))
+                 ((:sharp-rest)
+                  (case ch
+                    (#.+white-spaces+ (accept ch) (spop))
+                    ((#\\)     (accept ch) (spush :sharp-rest :single-escape))
+                    ((#\|)     (accept ch) (spush :sharp-rest :multiple-escape))
+                    ((#\()     (accept ch) (spush :sharp-rest :list))
+                    ((#\))     (spop))
+                    ((#\")     (spop))
+                    ((nil)     (spop))
+                    (otherwise (accept ch))))
+                 ((:single-escape)
+                  (case ch
+                    ((nil) (end :eof-single))
+                    (otherwise (accept ch) (spop))))
+                 ((:multiple-escape)
+                  (case ch
+                    ((nil) (end :eof-multiple))
+                    ((#\|) (accept ch) (spop))
+                    ((#\\) (accept ch) (spush :multiple-escape :single-escape))
+                    (otherwise (accept ch))))))))))
+
+
+#||
+
+(with-input-from-string (in "  ; comment
+#| 1 1
+tralala |#
+ 2  Hello   World! #\\GREEK_SMALL_LETTER_LAMDA #2A((a b) (c d ) ) zzz")
+  (loop :for s = (parse-sexp in nil nil) :while s :collect s))
+
+(with-input-from-string (in "  (  a ( d e f ) c )  ")
+  (loop :for s = (parse-sexp in nil nil) :while s :collect s))
+(with-input-from-string (in "(a (d e f) c)")
+  (loop :for s = (parse-sexp in nil nil) :while s :collect s))
+
+
+(mapcar 'read-from-string
+        (with-input-from-string (in "  ; comment
+#| 1 1
+tralala |#
+ 2  Hello   World! #\\GREEK_SMALL_LETTER_LAMDA #2A((a #| b)#|hi|#
+ (1|# 3) (c d ) ) zzz #x123ABC\"def\"")
+          (loop :for s = (parse-sexp in nil nil) :while s  :collect s)))
+
+||#
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(defconstant +port+ 19000)
+
+(defun remote-eval (form-text)
+  (with-open-stream (socket (socket:socket-connect +port+))
+    (when (eql :output (socket:socket-status socket))
+      (let ((*print-circle* t)
+            (*print-readably* t))
+        (princ form-text socket) (finish-output socket)
+        (let ((results (read socket nil socket)))
+          (cond ((atom results)
+                 (format t "~&Got invalid result message: ~S~%"
+                         results))
+                ((eql :ok (car results))
+                 (unless (= 0 (length (second results)))
+                   (format t "~&Printed:  ~A" (second results)))
+                 (unless (null (third results))
+                   (format t "~&Returned: ~{~A~^ ;~%          ~}~%"
+                           (third results))))
+                ((eql :error (car results))
+                 (format t "~&ERROR: ~A~%" (cdr results)))
+                (t (format t "~&Got invalid result message: ~S~%"
+                           results))))))))
+
+(defun read-new-value ()
+  (format *query-io* "Enter a new value: ")
+  (multiple-value-list (eval (read *query-io*))))
+
+(defmacro with-restricted-dynamic-environment (&body body)
+  `(with-output-to-string (*standard-output*)
+     (with-input-from-string (*standard-input* "")
+       (let* ((*print-circle* t)
+              (*print-readably* nil)
+              (*error-output* *standard-output*)
+              (*trace-output* *standard-output*)
+              (*query-io* (MAKE-TWO-WAY-STREAM *standard-input*
+                                               *standard-output*))
+              (*terminal-io* *query-io*)
+              (*package* (find-package "RCL-USER"))
+              (*read-eval* nil)
+              (-))
+         (restart-case (progn ,@body)
+           (abort          ()      :report "Aborted")
+           (continue       ()      :report "Continued")
+           (muffle-warning ()      :report "Warning muffled")
+           (store-value    (value) :report "Value stored"
+                                   :interactive read-new-value)
+           (use-value      (value) :report "Value used"
+                                   :interactive read-new-value))))))
+
+(defun check-form/packages (form &key (in-packs '(:rcl-user :keyword))
+                                 (out-packs '(:rcl :regexp)))
+  (cond ((symbolp form)
+         (dolist (pack in-packs)
+           (multiple-value-bind (sym status)
+               (find-symbol (symbol-name form) pack)
+             (when status
+               (return-from check-form/packages nil))))
+         (dolist (pack out-packs)
+           (multiple-value-bind (sym status)
+               (find-symbol (symbol-name form) pack)
+             (when (eql status :external)
+               (return-from check-form/packages nil))))
+         (symbol-package form))
+        ((atom form) nil)
+        (t (or (check-form/packages (car form))
+               (check-form/packages (cdr form))))))
+
+(defun server-rep (socket logout)
+  (let* ((values)
+         (output
+          (with-restricted-dynamic-environment
+              ;; (print (list logout *standard-output*))
+              (let ((form (read socket nil socket)))
+                (if (eql form socket)
+                    (format logout "~&Got EOF~%")
+                    (let ((pack (check-form/packages form)))
+                      (if pack
+                          (error "Unknown package ~S" pack)
+                          (progn
+                            (format logout "~&Got request to evaluate: ~S~%"
+                                    form)
+                            (setf values  (let ((- form))
+                                            (multiple-value-list
+                                             (eval form))))))))))))
+    (let ((*print-circle* t)
+          (*print-readably* nil))
+      (print (list :ok output (mapcar (lambda (x) (format nil "~S" x)) values))
+             socket)
+      (terpri socket)
+      (finish-output socket))))
+
+
+(defun main ()
+  (cond
+    ((or (null ext:*args*)
+         (member "--help"  ext:*args* :test (function string=)))
+     (let ((name (pathname-name (load-time-value *load-pathname*))))
+       (format t "~%~A --server &  # to start the server~%~
+                 ~:*~A --repl      # to start a local REPL communicating~%~
+                   ~VA             # with the server~%~
+                ~3:*~A <sexp>      # to send one S-EXP to the server~2%"
+               name (length name) "")))
+    ((string= "--server" (or (first ext:*args*) ""))
+     (let ((server (socket:socket-server +port+))
+           (log-output *terminal-io*))
+       (unwind-protect
+            (loop
+               (handler-case
+                   (with-open-stream (socket (socket:socket-accept server))
+                     (MULTIPLE-VALUE-BIND (remote-host remote-port)
+                         (SOCKET:SOCKET-STREAM-PEER socket)
+                       (format log-output "~&Accepted connection from ~A ~A~%"
+                               remote-host remote-port))
+                     (handler-case
+                         (SERVER-REP socket log-output)
+                       (t (err)
+                         (let ((*print-circle* t)
+                               (*print-readably* nil))
+                           (print (cons :error (format nil "~A" err)) socket)
+                           (terpri socket) (finish-output socket)))))
+                 #+clisp
+                 (SYSTEM::INTERRUPT-CONDITION (err)
+                   (format log-output "~&Got error: ~A~%"#|"~:*~S~%"|# err)
+                   (format log-output "Exiting.~%")
+                   (ext:quit))
+                 (t (err)
+                   (format log-output "~&Got error: ~A~%"#|"~:*~S~%"|# err))))
+         (socket:socket-server-close server))))
+    ((string= "--repl" (or (first ext:*args*) ""))
+     (loop
+        (format t "~2%Welcome to the remote ~A REPL~2%" (lisp-implementation-type))
+        (format t "Exit by typing: :QUIT or :EXIT alone.~2%")
+        (handler-case
+            (loop
+               :for form-text = (progn
+                                  (format t "~&LISP> ") (finish-output)
+                                  (parse-sexp *standard-input* nil nil))
+               :until (or (null form-text)
+                          (member  (string-trim +white-spaces+ form-text)
+                                   '(":QUIT" ":EXIT" "(QUIT)" "(EXIT)")
+                                   :test (function string-equal)))
+               :do (remote-eval form-text)
+               :finally (return-from main))
+          (error (err) (format *error-output* "~%~A~%" err)))))
+    (t
+     (dolist (form-text ext:*args*)
+       (princ form-text)
+       (remote-eval form-text)))))
+
+(main)
+
+
+;; (funcall (first (find-all-symbols "OPEN")) "/tmp/a")
\ No newline at end of file
diff --git a/small-cl-pgms/playtomo-stonedge/index.html b/small-cl-pgms/playtomo-stonedge/index.html
new file mode 100644
index 0000000..aa54260
--- /dev/null
+++ b/small-cl-pgms/playtomo-stonedge/index.html
@@ -0,0 +1,963 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">
+
+<HTML>
+ <HEAD>
+  <link rel="icon"          href="/favicon.ico" type="image/x-icon">
+  <link rel="shortcut icon" href="/favicon.ico" type="image/x-icon">
+  <link rel="stylesheet"    href="default.css"  type="text/css">
+
+  <TITLE>An implementation of the Playtomo Stonedge game, with its solver</TITLE>
+
+  <META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=utf-8">
+  <META HTTP-EQUIV="Description"
+        NAME="description" CONTENT="An implementation of the Playtomo Stonedge game, with its solver.">
+  <META NAME="author"      CONTENT="Pascal J. Bourguignon">
+
+  <META NAME="keywords"    CONTENT="Common Lisp, Lisp, game, playtomo, stonedge, solver">
+ </HEAD>
+<BODY>
+<!--TOP-BEGIN-->
+<!-- This section is automatically generated by html-update, -->
+<!-- from data in 'node.el'.    Please, do not edit it here. -->
+<DIV CLASS="TOP">
+
+</DIV>
+<!--TOP-END-->
+<!--MENU-BEGIN-->
+<!-- This section is automatically generated by html-update, -->
+<!-- from data in 'node.el'.    Please, do not edit it here. -->
+<DIV CLASS="MENU"><HR><P>|
+ <A HREF="../../../../toc.html">Contents</a> |
+ <A HREF="../../../../index.html">Home</a> |
+ <A HREF="../sedit/index.html">Previous</a> |
+ <A HREF="../../index.html">Up</a> |
+ <A HREF="../rpsls/index.html">Next</a> |
+</P><HR></DIV>
+<!--MENU-END-->
+
+<H1>An implementation of the Playtomo Stonedge game, with its solver</H1>
+
+<p>This is an implementation of the Playtomo Stonedge Game, and its solver.
+See <a href="http://www.playtomo.com/">http://www.playtomo.com/</a> (not much here when I went);
+Download the playtomo games on BlackBerry.
+
+
+<UL>
+<LI><A HREF="playtomo-stonedge.lisp">playtomo-stonedge.lisp</A></LI>
+</UL>
+
+
+<p>Playtomo's implementation is nicer (graphical), but here, we
+provide a solver that will find all the solutions to a given level.
+<strong>Even nicer!</strong></p>
+
+<pre>
+                  +---+
+block             |BBB|
+                  +---+
+empty cell        |   |
+                  +---+
+solid cell        |SSS|
+                  +---+
+red button cell   |[R]|
+                  +---+
+blue button cell  |[B]|
+                  +---+
+ice cell          |,,,|
+                  +---+
+target cell       |TTT|
+                  +---+
+closed door       | / |
+                  +---+
+open door         |---|
+                  +---+
+</pre>
+
+
+<p>To move the block, use:</pre>
+<pre>
+      8           i
+    4   6   or  j   l
+      2           k
+</pre>
+
+
+<p>Example:</p>
+<pre>
+CL-USER&gt; (stonedge *level-39*)
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|[B]| / |[R]| / |CCC|[R]|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   | / |SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |,,,|SSS|   |   |   |SSS|TTT|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |BBB|SSS|   |   |   |CCC|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |SSS|CCC|SSS|CCC|SSS|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+Your move: 8
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|[B]| / |[R]| / |CCC|[R]|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   | / |SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |BBB|   |   |   |   |   |SSS|SSS|   |   |
++---+---+---+---+BBB+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |BBB|SSS|   |   |   |SSS|TTT|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|SSS|   |   |   |CCC|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |SSS|CCC|SSS|CCC|SSS|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+Your move: 8
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|[B]| / |[R]| / |CCC|[R]|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |BBB|   |   |   |   |   | / |SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |,,,|SSS|   |   |   |SSS|TTT|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|SSS|   |   |   |CCC|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |SSS|CCC|SSS|CCC|SSS|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+Your move: 8
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|[B]| / |[R]| / |CCC|[R]|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|BBB|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+BBB+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |BBB|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   | / |SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |,,,|SSS|   |   |   |SSS|TTT|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|SSS|   |   |   |CCC|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |SSS|CCC|SSS|CCC|SSS|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+Your move: 8
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|BBB|---|[R]| / |CCC|[R]|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   | / |SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |,,,|SSS|   |   |   |SSS|TTT|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|SSS|   |   |   |CCC|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |SSS|CCC|SSS|CCC|SSS|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+Your move: 6
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|[B]|BBBBBBB|---|CCC|[R]|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   | / |SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |,,,|SSS|   |   |   |SSS|TTT|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|SSS|   |   |   |CCC|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |SSS|CCC|SSS|CCC|SSS|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+Your move: 6
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|[B]|---|[R]|BBB|CCC|[R]|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   | / |SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |,,,|SSS|   |   |   |SSS|TTT|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|SSS|   |   |   |CCC|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |SSS|CCC|SSS|CCC|SSS|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+Your move: 6
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|[B]|---|[R]|---|BBBBBBB|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |---|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |,,,|SSS|   |   |   |SSS|TTT|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|SSS|   |   |   |CCC|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |SSS|CCC|SSS|CCC|SSS|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+Your move: 4
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|[B]|---|[R]|BBB|   |[R]|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |---|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |,,,|SSS|   |   |   |SSS|TTT|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|SSS|   |   |   |CCC|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |SSS|CCC|SSS|CCC|SSS|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+Your move: 4
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|[B]|BBBBBBB| / |   |[R]|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |---|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |,,,|SSS|   |   |   |SSS|TTT|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|SSS|   |   |   |CCC|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |SSS|CCC|SSS|CCC|SSS|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+Your move: 4
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|BBB| / |[R]| / |   |[R]|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |---|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |,,,|SSS|   |   |   |SSS|TTT|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|SSS|   |   |   |CCC|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |SSS|CCC|SSS|CCC|SSS|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+Your move: 4
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |BBBBBBB|[B]| / |[R]| / |   |[R]|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |---|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |,,,|SSS|   |   |   |SSS|TTT|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|SSS|   |   |   |CCC|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |SSS|CCC|SSS|CCC|SSS|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+Your move: 2
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|[B]| / |[R]| / |   |[R]|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |BBBBBBB|SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |---|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |,,,|SSS|   |   |   |SSS|TTT|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|SSS|   |   |   |CCC|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |SSS|CCC|SSS|CCC|SSS|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+Your move: 6
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|[B]| / |[R]| / |   |[R]|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|BBB|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |---|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |,,,|SSS|   |   |   |SSS|TTT|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|SSS|   |   |   |CCC|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |SSS|CCC|SSS|CCC|SSS|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+Your move: 2
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|[B]| / |[R]| / |   |[R]|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |BBB|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+BBB+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |BBB|   |   |   |   |   |---|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |,,,|SSS|   |   |   |SSS|TTT|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|SSS|   |   |   |CCC|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |SSS|CCC|SSS|CCC|SSS|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+Your move: 2
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|[B]| / |[R]| / |   |[R]|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |---|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |BBB|   |   |   |   |   |SSS|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |,,,|SSS|   |   |   |SSS|TTT|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|SSS|   |   |   |CCC|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |SSS|CCC|SSS|CCC|SSS|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+Your move: 2
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|[B]| / |[R]| / |   |[R]|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |---|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |BBB|SSS|   |   |   |SSS|TTT|SSS|   |   |
++---+---+---+---+BBB+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |BBB|SSS|   |   |   |CCC|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |SSS|CCC|SSS|CCC|SSS|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+Your move: 6
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|[B]| / |[R]| / |   |[R]|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |---|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |,,,|BBB|   |   |   |SSS|TTT|SSS|   |   |
++---+---+---+---+---+BBB+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|BBB|   |   |   |CCC|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |SSS|CCC|SSS|CCC|SSS|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+Your move: 2
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|[B]| / |[R]| / |   |[R]|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |---|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |,,,|SSS|   |   |   |SSS|TTT|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|SSS|   |   |   |CCC|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |BBB|CCC|SSS|CCC|SSS|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+Your move: 6
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|[B]| / |[R]| / |   |[R]|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |---|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |,,,|SSS|   |   |   |SSS|TTT|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|SSS|   |   |   |CCC|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |SSS|BBBBBBB|CCC|SSS|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+Your move: 6
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|[B]| / |[R]| / |   |[R]|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |---|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |,,,|SSS|   |   |   |SSS|TTT|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|SSS|   |   |   |CCC|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |SSS|   |SSS|BBB|SSS|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+Your move: 6
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|[B]| / |[R]| / |   |[R]|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |---|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |,,,|SSS|   |   |   |SSS|TTT|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|SSS|   |   |   |CCC|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |SSS|   |SSS|   |BBBBBBB|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+Your move: 8
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|[B]| / |[R]| / |   |[R]|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |---|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |,,,|SSS|   |   |   |SSS|TTT|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|SSS|   |   |   |BBBBBBB|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |SSS|   |SSS|   |SSS|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+Your move: 8
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|[B]| / |[R]| / |   |[R]|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |---|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |,,,|SSS|   |   |   |BBBBBBB|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|SSS|   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |SSS|   |SSS|   |SSS|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+Your move: 6
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|[B]| / |[R]| / |   |[R]|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |---|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |,,,|SSS|   |   |   |SSS|TTT|BBB|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|SSS|   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |SSS|   |SSS|   |SSS|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+Your move: 8
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|[B]| / |[R]| / |   |[R]|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |---|BBB|   |   |
++---+---+---+---+---+---+---+---+---+---+---+BBB+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|BBB|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |,,,|SSS|   |   |   |SSS|TTT|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|SSS|   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |SSS|   |SSS|   |SSS|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+Your move: 4
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|[B]| / |[R]| / |   |[R]|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |,,,|,,,|SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |BBB|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+BBB+---+---+---+
+|   |   |   |   |SSS|   |   |   |   |   |BBB|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |,,,|SSS|   |   |   |SSS|TTT|SSS|   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |SSS|SSS|   |   |   |   |SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |SSS|   |SSS|   |SSS|SSS|   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+|   |   |   |   |   |   |   |   |   |   |   |   |   |   |
++---+---+---+---+---+---+---+---+---+---+---+---+---+---+
+Your move: 2
+
+You win!
+
+; No value
+CL-USER&gt; (solve-problem *level-39*)
+
+(NUMBER OF STATES = 990)
+((:WIN 10 5 10 5 :CLOSED :CLOSED :CLOSED :CLOSED :CLOSED :CLOSED :OPEN)
+ (:FRONT :FRONT :FRONT :FRONT :RIGHT :RIGHT :RIGHT :LEFT :LEFT :LEFT :LEFT
+  :BACK :RIGHT :BACK :BACK :BACK :RIGHT :BACK :RIGHT :RIGHT :RIGHT :FRONT
+  :FRONT :RIGHT :FRONT :LEFT :BACK))
+((:WIN 10 5 10 5 :OPEN :CLOSED :CLOSED :CLOSED :CLOSED :CLOSED :OPEN)
+ (:FRONT :FRONT :FRONT :FRONT :RIGHT :RIGHT :RIGHT :LEFT :LEFT :LEFT :LEFT
+  :RIGHT :LEFT :BACK :RIGHT :BACK :BACK :BACK :RIGHT :BACK :RIGHT :RIGHT :RIGHT
+  :FRONT :FRONT :RIGHT :FRONT :LEFT :BACK))
+((:WIN 10 5 10 5 :CLOSED :CLOSED :OPEN :CLOSED :CLOSED :CLOSED :OPEN)
+ (:FRONT :FRONT :FRONT :FRONT :RIGHT :RIGHT :RIGHT :LEFT :LEFT :LEFT :LEFT
+  :RIGHT :RIGHT :LEFT :LEFT :BACK :RIGHT :BACK :BACK :BACK :RIGHT :BACK :RIGHT
+  :RIGHT :RIGHT :FRONT :FRONT :RIGHT :FRONT :LEFT :BACK))
+((:WIN 10 5 10 5 :OPEN :CLOSED :OPEN :CLOSED :CLOSED :CLOSED :OPEN)
+ (:FRONT :FRONT :FRONT :FRONT :RIGHT :RIGHT :RIGHT :LEFT :LEFT :LEFT :LEFT
+  :RIGHT :RIGHT :LEFT :LEFT :RIGHT :LEFT :BACK :RIGHT :BACK :BACK :BACK :RIGHT
+  :BACK :RIGHT :RIGHT :RIGHT :FRONT :FRONT :RIGHT :FRONT :LEFT :BACK))
+Real time: 0.288899 sec.
+Run time: 0.288956 sec.
+Space: 6520144 Bytes
+GC: 1, GC time: 0.009999 sec.
+NIL
+CL-USER&gt;
+</pre>
+
+
+
+
+<!--MENU-BEGIN-->
+<!-- This section is automatically generated by html-update, -->
+<!-- from data in 'node.el'.    Please, do not edit it here. -->
+<DIV CLASS="MENU"><HR><P>|
+ <A HREF="../../../../toc.html">Contents</a> |
+ <A HREF="../../../../index.html">Home</a> |
+ <A HREF="../sedit/index.html">Previous</a> |
+ <A HREF="../../index.html">Up</a> |
+ <A HREF="../rpsls/index.html">Next</a> |
+</P><HR></DIV>
+<!--MENU-END-->
+<!--BOTTOM-BEGIN-->
+<!-- This section is automatically generated by html-update, -->
+<!-- from data in 'node.el'.    Please, do not edit it here. -->
+<DIV CLASS="BOTTOM">
+<hr><code><small>
+ | <a href="http://www.informatimago.com//develop/lisp/small-cl-pgms/playtomo-stonedge/index.html">Mirror on informatimago.com</a>
+ | <a href="http://informatimago.free.fr/i//develop/lisp/small-cl-pgms/playtomo-stonedge/index.html">Mirror on free.fr</a>
+ | </small></code>
+
+<BR><SMALL>Last update : <!--MODIFICATION-DATE--> 2011-01-19 02:07:15
+     by : <!--MODIFICATION-AUTEUR--> Pascal J. Bourguignon
+    </SMALL>
+<BR><SMALL>
+      <a href="http://validator.w3.org/check?uri=referer"><img
+          src="http://www.w3.org/Icons/valid-html401"
+          alt="Valid HTML 4.01!" height="31" width="88"></a>
+   </SMALL>
+</DIV>
+<!--BOTTOM-END-->
+</BODY>
+</HTML>
diff --git a/small-cl-pgms/playtomo-stonedge/playtomo-stonedge.lisp b/small-cl-pgms/playtomo-stonedge/playtomo-stonedge.lisp
new file mode 100644
index 0000000..66cf996
--- /dev/null
+++ b/small-cl-pgms/playtomo-stonedge/playtomo-stonedge.lisp
@@ -0,0 +1,1048 @@
+;;;; -*- mode:lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE:               playtomo-stonedge.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    Implements the Playtomo Stonedge Game, and its solver.
+;;;;    See http://www.playtomo.com/ (not much here when I went);
+;;;;    Download the playtomo games on BlackBerry.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2010-07-09 <PJB> Created.
+;;;;BUGS
+;;;;LEGAL
+;;;;    GPL
+;;;;
+;;;;    Copyright Pascal J. Bourguignon 2010 - 2010
+;;;;
+;;;;    This program is free software; you can redistribute it and/or
+;;;;    modify it under the terms of the GNU General Public License
+;;;;    as published by the Free Software Foundation; either version
+;;;;    2 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 General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU General Public
+;;;;    License along with this program; if not, write to the Free
+;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;;    Boston, MA 02111-1307 USA
+;;;;**************************************************************************
+
+(asdf-load :split-sequence)
+(asdf-load :com.informatimago.common-lisp)
+(use-package :com.informatimago.common-lisp.graph)
+(use-package :com.informatimago.common-lisp.graph-dot)
+(shadow 'copy) ; from :com.informatimago.common-lisp.graph
+
+;;;-----------------------------------------------------------------------------
+;;;
+;;; STONE
+;;;
+
+
+(defclass stone ()
+  ((x :initform 0
+      :initarg :x
+      :reader stone-x
+      :documentation "Ordinate of the first cube of the stone.")
+   (y :initform 0
+      :initarg :y
+      :reader stone-y
+      :documentation "Coordinate of the first cube of the stone.")
+   (direction :initform (vector 0 0 1)
+              :initarg :direction
+              :reader stone-direction
+              :documentation "A unit vector indicating the direction of the stone.
+The coordinate of the other cube of the stone is given by adding this vector to
+the coordinates of the first cube.
+Note: The stone is normalized so that the vertical coordinate of the direction is either 0 or 1."))
+  (:documentation "A stone is made of two cubes of size equal to the cells.
+To move, it rotates 1/4 turn on one of its edges that is in contact with the cells."))
+
+
+(defconstant +right+ 0)
+(defconstant +left+  1)
+(defconstant +front+ 2)
+(defconstant +back+  3)
+
+
+;;
+;;              ^
+;;             y|front
+;;              |
+;;              |
+;; left         |                 right
+;; -------------+-------------------->
+;;             0|                   x
+;;              |
+;;              |
+;;              |back
+;;
+
+(defparameter *rotations*
+  ;;                   x               x                  x                  x
+  ;;                   y               y                  y                  y
+  ;;          right    z      left     z         front    z         back     z
+  ;;        -------   ---   --------  ---      --------  ---      -------   ---
+  ;;          0 0 1    z      0 0 -1  -z        1  0  0   x        1  0  0   x
+  ;;          0 1 0    y      0 1 0    y        0  0  1   z        0  0 -1  -z
+  ;;         -1 0 0   -x      1 0 0    x        0 -1  0  -y        0  1  0   y
+  #(
+    ;; +right+
+    #2A((0 0 1)
+        (0 1 0)
+        (-1 0 0))
+    ;; +left+
+    #2A((0 0 -1)
+        (0 1 0)
+        (1 0 0))
+    ;; +front+
+    #2A((1 0 0)
+        (0 0 1)
+        (0 -1 0))
+    ;; +back+
+    #2A((1 0 0)
+        (0 0 -1)
+        (0 1 0)))
+  "A vector of 3D rotation matrices for right, left, front and back rotations.")
+
+
+(defun rotate (matrix vector)
+  "Returns matrix * vector"
+  (coerce
+   (loop
+      :for i :from 0 :to 2
+      :collect (loop
+                  :for j :from 0 :to 2
+                  :sum (* (aref vector j) (aref matrix i j))))
+   'vector))
+
+
+(defun test-rotate ()
+  (assert
+   (equalp
+    (let ((result '()))
+      (dolist (direction (list #(1 0 0) #(-1 0 0) #(0 1 0) #(0 -1 0) #(0 0 1) #(0 0 -1))
+               result)
+        (dotimes (rotation 4)
+          (push (list direction (aref #(left--> right-> front-> back-->) rotation)
+                      (rotate (aref *rotations* rotation)  direction))
+                result))))
+    '((#(0 0 -1) BACK--> #(0 1 0)) (#(0 0 -1) FRONT-> #(0 -1 0))
+      (#(0 0 -1) RIGHT-> #(1 0 0)) (#(0 0 -1) LEFT--> #(-1 0 0))
+      (#(0 0 1) BACK--> #(0 -1 0)) (#(0 0 1) FRONT-> #(0 1 0))
+      (#(0 0 1) RIGHT-> #(-1 0 0)) (#(0 0 1) LEFT--> #(1 0 0))
+      (#(0 -1 0) BACK--> #(0 0 -1)) (#(0 -1 0) FRONT-> #(0 0 1))
+      (#(0 -1 0) RIGHT-> #(0 -1 0)) (#(0 -1 0) LEFT--> #(0 -1 0))
+      (#(0 1 0) BACK--> #(0 0 1)) (#(0 1 0) FRONT-> #(0 0 -1))
+      (#(0 1 0) RIGHT-> #(0 1 0)) (#(0 1 0) LEFT--> #(0 1 0))
+      (#(-1 0 0) BACK--> #(-1 0 0)) (#(-1 0 0) FRONT-> #(-1 0 0))
+      (#(-1 0 0) RIGHT-> #(0 0 -1)) (#(-1 0 0) LEFT--> #(0 0 1))
+      (#(1 0 0) BACK--> #(1 0 0)) (#(1 0 0) FRONT-> #(1 0 0))
+      (#(1 0 0) RIGHT-> #(0 0 1)) (#(1 0 0) LEFT--> #(0 0 -1)))))
+  :success)
+
+
+(test-rotate)
+
+
+(defun invert (vector)
+  "Returns   - vector"
+  (map 'vector (lambda (x) (- x)) vector))
+
+
+(defgeneric normalize (stone direction)
+  (:documentation "
+Normalize the stone for a rotation in the given direction.
+DIRECTION: (member :left :right :front :back)
+")
+  (:method ((self stone) (direction (eql :right)))
+    (declare (ignorable direction))
+    (with-slots (x direction) self
+      (when (plusp (aref direction 0))
+        (progn
+          (incf x)
+          (setf direction (invert direction)))))
+    self)
+  (:method ((self stone) (direction (eql :left)))
+    (declare (ignorable direction))
+    (with-slots (x direction) self
+      (when (minusp (aref direction 0))
+        (progn
+          (decf x)
+          (setf direction (invert direction)))))
+    self)
+  (:method ((self stone) (direction (eql :front)))
+    (declare (ignorable direction))
+    (with-slots (y direction) self
+      (when (plusp (aref direction 1))
+        (progn
+          (incf y)
+          (setf direction (invert direction)))))
+    self)
+  (:method ((self stone) (direction (eql :back)))
+    (declare (ignorable direction))
+    (with-slots (y direction) self
+      (when (minusp (aref direction 1))
+        (progn
+          (decf y)
+          (setf direction (invert direction)))))
+    self))
+
+
+(defgeneric move (stone direction)
+  (:documentation "Move the stone in the given direction.")
+  (:method ((self stone) (direction (eql :right)))
+    (declare (ignorable direction))
+    (with-slots (x direction) self
+      (incf x)
+      (setf direction  (rotate (aref *rotations* +right+) direction)))
+    self)
+  (:method ((self stone) (direction (eql :left)))
+    (declare (ignorable direction))
+    (with-slots (x direction) self
+      (decf x)
+      (setf direction  (rotate (aref *rotations* +left+) direction)))
+    self)
+  (:method ((self stone) (direction (eql :front)))
+    (declare (ignorable direction))
+    (with-slots (y direction) self
+      (incf y)
+      (setf direction  (rotate (aref *rotations* +front+) direction)))
+    self)
+  (:method ((self stone) (direction (eql :back)))
+    (declare (ignorable direction))
+    (with-slots (y direction) self
+      (decf y)
+      (setf direction  (rotate (aref *rotations* +back+) direction)))
+    self))
+
+(defmethod move :before ((self stone) direction) (normalize self direction))
+
+
+
+(defun verticalp (direction)
+  (not (zerop (aref direction 2))))
+
+(defun lateralp (direction)
+  (not (zerop (aref direction 0))))
+
+(defun frontp (direction)
+  (not (zerop (aref direction 1))))
+
+
+(defmethod print-object ((self stone) stream)
+  (print-unreadable-object (self stream :type t)
+    (with-slots (x y direction) self
+      (format stream "~A,~A ~S~%" x y direction)
+      (cond
+        ((verticalp direction)
+         (format stream "\"
+     +---+
+    /   /|
+   +---+ |
+   |   | |
+   |   | +
+   |   |/
+   +---+  ~A,~A
+\"" x y))
+
+        ((lateralp direction)
+         (apply (function format) stream "\"
+     +------+
+    /      /|
+   +------+ +
+   |      |/
+   +------+ ~A,~A
+\""
+                (if (minusp (aref direction 0))
+                    (list x y)
+                    (list (1+ x) y))))
+
+        ((frontp direction)
+         (apply (function format) stream "\"
+       +---+
+      /   /|
+     /   / +
+    /   / /
+   +---+ /
+   |   |/
+   +---+ ~A,~A
+\""
+                (if (plusp (aref direction 1))
+                    (list x y)
+                    (list x (1- y))))))))
+  self)
+
+
+
+;;;-----------------------------------------------------------------------------
+;;;
+;;; CELLS
+;;;
+
+(defclass cell ()
+  ((x :initform 0
+      :initarg :x
+      :reader cell-x
+      :documentation "Lateral coordinate.")
+   (y :initform 0
+      :initarg :y
+      :reader cell-y
+      :documentation "Front coordinate."))
+  (:documentation "This is an abstract cell. Cells are square, and all of the same size."))
+
+(define-condition game-won  () ())
+(define-condition game-lost () ())
+
+(defgeneric stone-moved-over-cell (stone cell)
+  (:documentation "Do cell specific behavior when the stone moves over the cell.
+May signal a game-won or game-lost condition.")
+  (:method (stone cell)
+    (declare (ignorable stone cell))
+    (values)))
+
+(defgeneric stone-left-cell (stone cell)
+  (:documentation "Do cell specific behavior when the stone moves from the cell.
+May signal a game-won or game-lost condition.")
+  (:method (stone cell)
+    (declare (ignorable stone cell))
+    (values)))
+
+(defgeneric game-status (stone cell)
+  (:documentation "Returns nil :win or :lose depending on what would happen if the stone was on the cell.")
+  (:method (stone cell)
+    (declare (ignorable stone cell))
+    nil))
+
+
+
+
+(defclass solid-cell (cell)
+  ()
+  (:documentation "The stone may remain securely on a solid cell."))
+
+
+
+(defclass target-cell (cell)
+  ()
+  (:documentation "Once the stone is in vertical position on a target cell,
+the game is won."))
+
+(defmethod stone-moved-over-cell (stone (cell target-cell))
+  (declare (ignorable stone cell))
+  (when (verticalp (stone-direction stone))
+    (signal 'game-won)))
+
+(defmethod game-status (stone (cell target-cell))
+  (declare (ignorable cell))
+  (when (verticalp (stone-direction stone))
+    :win))
+
+
+
+(defclass empty-cell (cell)
+  ()
+  (:documentation "When the stone is over an empty cell,
+the game is lost."))
+
+(defmethod stone-moved-over-cell (stone (cell empty-cell))
+  (declare (ignorable stone cell))
+  (signal 'game-lost))
+
+(defmethod game-status (stone (cell empty-cell))
+  (declare (ignorable stone cell))
+  :lose)
+
+
+(defclass button-cell (cell)
+  ((switches :initform '()
+             :initarg :switches
+             :accessor button-cell-switches
+             :documentation "A list of cells that may be switched when the stone is over the button cell."))
+  (:documentation "This is an abstract button cell.
+Button cells may switch the state of pathway-cells."))
+
+(defgeneric switch-pathway-cells (button-cell)
+  (:documentation "Switches the associated pathway-cells.")
+  (:method ((self button-cell))
+    (map nil (function switch-cell) (button-cell-switches self))
+    self))
+
+
+
+(defclass red-button-cell (button-cell)
+  ()
+  (:documentation "A red button cell switches its pathway cells
+as soon as the stone is over it."))
+
+(defmethod stone-moved-over-cell ((s stone) (cell red-button-cell))
+  (declare (ignorable s))
+  (switch-pathway-cells cell))
+
+
+
+(defclass blue-button-cell (button-cell)
+  ()
+  (:documentation "A blue button cell switches its pathway cells
+only when the stone is over it in vertical position."))
+
+(defmethod stone-moved-over-cell ((s stone) (cell blue-button-cell))
+  (when (verticalp (stone-direction s))
+    (switch-pathway-cells cell)))
+
+
+
+(defclass pathway-cell (cell)
+  ((state :initform :closed
+          :initarg :state
+          :reader pathway-cell-state
+          :type (member :closed :open)
+          :documentation "A pathway cell may be :open or :closed."))
+  (:documentation "When a pathway cell is :open, it supports a stone;
+when it's :closed the stone falls down and
+the game is lost."))
+
+(defmethod stone-moved-over-cell ((s stone) (cell pathway-cell))
+  (declare (ignorable s))
+  (when (eql :closed (pathway-cell-state cell))
+    (signal 'game-lost)))
+
+(defmethod game-status (stone (cell pathway-cell))
+  (declare (ignorable stone))
+  (when (eql :closed (pathway-cell-state cell))
+    :lose))
+
+(defmethod switch-cell ((self pathway-cell))
+  (setf (slot-value self 'state) (ecase (pathway-cell-state self)
+                                   ((:open)   :closed)
+                                   ((:closed) :open)))
+  self)
+
+
+
+(defclass crumble-cell (cell)
+  ((state :initform :open
+          :initarg :state
+          :reader crumble-cell-state
+          :type (member :closed :open)
+          :documentation "A crumble cell goes from :open to :closed the first time
+it's walked over, and stays :closed thereafter."))
+  (:documentation "When a crumble cell is :open, it supports a stone;
+when it's :closed the stone falls down and
+the game is lost."))
+
+(defmethod stone-moved-over-cell ((s stone) (cell crumble-cell))
+  (declare (ignorable s))
+  (when (eql :closed (crumble-cell-state cell))
+    (signal 'game-lost)))
+
+(defmethod stone-left-cell (stone (cell crumble-cell))
+  (declare (ignorable stone))
+  (setf (slot-value cell 'state) :closed))
+
+(defmethod game-status (stone (cell crumble-cell))
+  (declare (ignorable stone))
+  (when (eql :closed (crumble-cell-state cell))
+    :lose))
+
+
+(defclass ice-cell (cell)
+  ()
+  (:documentation "An ice cell supports an horizontal stone, but
+when the stone is over it in vertical position, it breaks, the stone falls down, and
+the game is lost."))
+
+(defmethod stone-moved-over-cell ((s stone) (cell ice-cell))
+  (declare (ignorable cell))
+  (when (verticalp (stone-direction s))
+    (signal 'game-lost)))
+
+(defmethod game-status (stone (cell ice-cell))
+  (declare (ignorable cell))
+  (when (verticalp (stone-direction stone))
+    :lose))
+
+
+
+;;;-----------------------------------------------------------------------------
+;;;
+;;; GAME
+;;;
+
+
+(defclass game ()
+  ((stone :initform (make-instance 'stone)
+          :initarg :stone
+          :reader game-stone
+          :documentation "The stone.")
+   (cells :initform #2A()
+          :initarg :cells
+          :reader game-cells
+          :documentation "The cells.")))
+
+
+(defgeneric text-icon (cell)
+  (:documentation "Returns a three-character strings denoting graphically the cell.")
+  (:method ((cell empty-cell))       (declare (ignorable cell)) "   ")
+  (:method ((cell solid-cell))       (declare (ignorable cell)) "SSS")
+  (:method ((cell red-button-cell))  (declare (ignorable cell)) "[R]")
+  (:method ((cell blue-button-cell)) (declare (ignorable cell)) "[B]")
+  (:method ((cell ice-cell))         (declare (ignorable cell)) ",,,")
+  (:method ((cell target-cell))      (declare (ignorable cell)) "TTT")
+  (:method ((cell crumble-cell))
+    (declare (ignorable cell))
+    (if (eql :open (crumble-cell-state cell))
+        "CCC"
+        "   "))
+  (:method ((cell pathway-cell))
+    (declare (ignorable cell))
+    (if (eql :open (pathway-cell-state cell))
+        "---"
+        " / ")))
+
+
+(defun stone-coverage (stone)
+  "
+Returns:   direction; left; back; right; front
+DIRECTION: (member :vertical :lateral :front)
+"
+  (let ((direction (cond
+                     ((verticalp (stone-direction stone)) :vertical)
+                     ((lateralp  (stone-direction stone)) :lateral)
+                     (t                                   :front))))
+    (if (eql direction :vertical)
+        (values direction  (stone-x stone) (stone-y stone) (stone-x stone) (stone-y stone))
+        (let* ((x0  (stone-x stone))
+               (x1  (+ x0 (aref (stone-direction stone) 0)))
+               (y0  (stone-y stone))
+               (y1  (+ y0 (aref (stone-direction stone) 1))))
+          (values direction (min x0 x1) (min y0 y1) (max x0 x1) (max y0 y1))))))
+
+
+(defun print-game (game stream)
+  "
+Prints an ASCII-art representation of the GAME onto the STREAM.
+"
+  (let* ((cells (game-cells game))
+         (line  (with-output-to-string (out)
+                  (loop
+                     :repeat (array-dimension cells 0)
+                     :initially (princ "+" out)
+                     :do (princ "---+" out)))))
+    (multiple-value-bind (direction stone-left stone-back stone-right stone-front)
+        (stone-coverage  (game-stone game))
+      (loop
+         :for j :from (1-  (array-dimension cells 1)) :downto 0
+         :initially (princ line stream) (terpri stream)
+         :do (loop
+                :for i :from 0 :below (array-dimension cells 0)
+                :initially (princ "|" stream)
+                :do (unless (ecase direction
+                              ((:vertical)
+                               (when (and (= stone-left i) (= stone-back j))
+                                 (princ "BBB" stream) (princ "|" stream) t))
+                              ((:lateral)
+                               (cond
+                                 ((and (= stone-left i) (= stone-back j))
+                                  (princ "BBBB" stream) t)
+                                 ((and (= stone-right i) (= stone-back j))
+                                  (princ "BBB" stream) (princ "|" stream) t)))
+                              ((:front)
+                               (when (and (= stone-left i) (or (= stone-back j)
+                                                               (= stone-front j)))
+                                 (princ "BBB" stream) (princ "|" stream) t)))
+                      (princ (text-icon (aref cells i j)) stream) (princ "|" stream))
+                :finally (progn
+                           (terpri stream)
+                           (if (and (eql direction :front) (= stone-front j))
+                               (let ((line (copy-seq line)))
+                                 (replace line "BBB" :start1 (+ 1 (* 4 stone-left)))
+                                 (princ line stream))
+                               (princ line stream))
+                           (terpri stream)))))))
+
+
+(defmethod print-object ((self game) stream)
+  (print-unreadable-object (self stream :type t :identity t)
+    (format stream "\"~%")
+    (print-game self stream)
+    (format stream "~%\""))
+  self)
+
+
+(defun parse-game (level)
+  "
+LEVEL:   A CONS whose car is a string drawing the cells, and whose cdr
+         is a list of cell definitions.  The string is a multiline
+         string, each line containing one character per cell.  The
+         character encodes the class of cell (case insensitively):
+
+            . or space:  empty-cell
+            S            solid-cell starting position
+            O            solid-cell
+            T            target-cell
+            I            ice-cell
+            C            crumble-cell
+            other:       the character is searched in the list of cell definitions.
+
+         The list of cell definitions contains sublists of these forms:
+            (cell-name  :pathway  :open|:closed)
+            (cell-name  :red      . list-of-cell-names)
+            (cell-name  :blue     . list-of-cell-names)
+
+         Cell-name is either a character, a single-character string or
+         symbol, or a digit (0 from 9).
+
+         :pathway indicates the class of the cell is pathway-cell, and
+         the following keyword indicates its initial state.
+
+         :red indicates the class of the cell is red-button-cell;
+         :blue indicates the class of the cell is blue-button-cell; in
+         both cases, the rest is the list of pathway cell-names
+         connected to the button.
+
+         There must be a start position, and all the non empty cells
+         must be at least two steps from the borders.
+"
+  (let* ((lines (split-sequence:split-sequence #\newline (first level)))
+         (depth (length lines))
+         (width (reduce (function max) lines :key (function length)))
+         (cells (make-array (list width depth)))
+         (links (rest level))
+         (linked-cells '())
+         (stone))
+    (flet ((cell-key (designator)
+             (typecase designator
+               ((or symbol string character) (char (string-upcase designator) 0))
+               ((integer 0 9) (char (princ-to-string designator) 0))
+               (t (error "Invalid reference in level links: ~S" designator)))))
+      (loop
+         :with start-x :with start-y
+         :for line :in lines
+         :for j :from (1- depth) :downto 0
+         :do (loop
+                :for i :from 0 :below width
+                :for ch = (if (< i (length line))
+                              (aref line i)
+                              #\.)
+                :do (setf (aref cells i j)
+                          (flet ((make-cell (class &rest args)
+                                   (unless (eql class 'empty-cell)
+                                     (assert (and (< 1 i (- width  2))
+                                                  (< 1 j (- depth 2)))
+                                             (i j)
+                                             "Non empty cells must be at more than two steps from the border."))
+                                   (apply (function make-instance) class :x i :y j args)))
+                            (case (char-upcase ch)
+                              ((#\. #\space)  (make-cell 'empty-cell))
+                              ((#\S)          (progn
+                                                (setf start-x i
+                                                      start-y j)
+                                                (make-cell 'solid-cell)))
+                              ((#\O)          (make-cell 'solid-cell))
+                              ((#\I)          (make-cell 'ice-cell))
+                              ((#\C)          (make-cell 'crumble-cell))
+                              ((#\T)          (make-cell 'target-cell))
+                              (otherwise
+                               (let ((link (assoc (char-upcase ch) links :key (function cell-key))))
+                                 (if link
+                                     (let ((cell
+                                            (ecase (second link)
+                                              ((:red)     (make-cell 'red-button-cell))
+                                              ((:blue)    (make-cell 'blue-button-cell))
+                                              ((:pathway) (make-cell 'pathway-cell :state (third link))))))
+                                       (push (cons (cell-key ch) cell) linked-cells)
+                                       cell)
+                                     (error "Invalid character in level map: ~S" ch))))))))
+         :finally (progn
+                    (unless start-x
+                      (error "The level is missing a start position. ~%~S" level))
+                    (setf stone (make-instance 'stone :x start-x :y start-y))
+                    (loop
+                       ;; Put the pathways in the switches list of the buttons.
+                       :for (key . cell) :in linked-cells
+                       :for link = (assoc key links :key (function cell-key))
+                       :do (ecase (second link)
+                             ((:red :blue) (dolist (pathway (cddr link))
+                                             (pushnew (cdr (assoc (cell-key pathway) linked-cells))
+                                                      (button-cell-switches cell))))
+                             ((:pathway))))
+                    (return (make-instance 'game :stone stone :cells cells)))))))
+
+
+(defmethod move ((game game) direction)
+  "
+Moves the stone of the game in the given direction.
+"
+  (let ((stone (game-stone game))
+        (cells (game-cells game)))
+    (multiple-value-bind (direction stone-left stone-back stone-right stone-front) (stone-coverage stone)
+      (if (eql direction :vertical)
+          (stone-left-cell stone (aref cells stone-left stone-back))
+          (progn
+            (stone-left-cell stone (aref cells stone-left stone-back))
+            (stone-left-cell stone (aref cells stone-right stone-front)))))
+    (move (game-stone game) direction)
+    (multiple-value-bind (direction stone-left stone-back stone-right stone-front) (stone-coverage stone)
+      (if (eql direction :vertical)
+          (stone-moved-over-cell stone (aref cells stone-left stone-back))
+          (progn
+            (stone-moved-over-cell stone (aref cells stone-left stone-back))
+            (stone-moved-over-cell stone (aref cells stone-right stone-front))))))
+  game)
+
+
+(defun stonedge (level)
+  "
+Play the playtomo stonedge game for the given LEVEL.
+See PARSE-GAME for the description of LEVEL.
+"
+  (let ((game (parse-game level)))
+    (handler-case
+        (loop
+           (print-game game *query-io*)
+           (format *query-io* "Your move: ")
+           (block :abort
+             (move game
+                   (case (char (string-trim #(#\space #\tab) (read-line *query-io*)) 0)
+                     ((#\j #\4) :left)
+                     ((#\l #\6) :right)
+                     ((#\i #\8) :front)
+                     ((#\k #\2) :back)
+                     (otherwise (return-from :abort))))))
+      (game-won  () (format t "~%You win!~2%"))
+      (game-lost () (format t "~%You lose!~2%")))
+    (values)))
+
+
+;;;-----------------------------------------------------------------------------
+;;;
+;;; Solver
+;;;
+
+(defgeneric cell-state (cell)
+  (:documentation "Return NIL or the state of the cell.")
+  (:method (cell)                (declare (ignorable cell)) nil)
+  (:method ((cell crumble-cell)) (declare (ignorable cell)) (crumble-cell-state cell))
+  (:method ((cell pathway-cell)) (declare (ignorable cell)) (pathway-cell-state cell)))
+
+
+(defgeneric game-state (game)
+  (:documentation "Return a list containing in a concise form the full state of the game.")
+  (:method ((game game))
+    (let ((cells (game-cells game))
+          (stone (game-stone game)))
+      (multiple-value-bind (direction stone-left stone-back stone-right stone-front)
+          (stone-coverage stone)
+        (declare (ignore direction))
+        (list* (or (game-status stone (aref cells stone-left  stone-back))
+                   (game-status stone (aref cells stone-right stone-front)))
+               stone-left stone-back stone-right stone-front
+               (loop
+                  :for i :from 0 :below (array-total-size cells)
+                  :for state = (cell-state (row-major-aref cells i))
+                  :when state :collect state))))))
+
+
+
+(defgeneric copy (object &KEY &ALLOW-OTHER-KEYS)
+
+  (:documentation "Copy the game objects.  Stateless cells are returned uncopied.")
+
+  (:method ((stone stone) &KEY &ALLOW-OTHER-KEYS)
+    (make-instance 'stone
+        :x (stone-x stone)
+        :y (stone-y stone)
+        :direction (stone-direction stone)))
+
+  (:method ((cell cell) &KEY &ALLOW-OTHER-KEYS)
+    cell)
+
+  (:method ((cell button-cell) &KEY &ALLOW-OTHER-KEYS)
+    (make-instance (class-of cell)
+        :x (cell-x cell)
+        :y (cell-y cell)
+        :switches (button-cell-switches cell)))
+
+  (:method ((cell pathway-cell) &KEY &ALLOW-OTHER-KEYS)
+    (make-instance (class-of cell)
+        :x (cell-x cell)
+        :y (cell-y cell)
+        :state (pathway-cell-state cell)))
+
+  (:method ((cell crumble-cell) &KEY &ALLOW-OTHER-KEYS)
+    (make-instance (class-of cell)
+        :x (cell-x cell)
+        :y (cell-y cell)
+        :state (crumble-cell-state cell)))
+
+  (:method ((game game) &KEY &ALLOW-OTHER-KEYS)
+    (make-instance 'game
+        :stone (copy (game-stone game))
+        :cells (loop
+                  :with cells    = (COM.INFORMATIMAGO.COMMON-LISP.ARRAY:COPY-ARRAY (game-cells game))
+                  :with pathways = '()
+                  :with buttons  = '()
+                  :for i :from 0 :below (array-total-size cells)
+                  :for original = (row-major-aref cells i)
+                  :for copy     = (copy original)
+                  :do (setf (row-major-aref cells i) copy)
+                  :do (typecase original
+                        (pathway-cell (push (cons original copy) pathways))
+                        (button-cell  (push copy                 buttons)))
+                  :finally (progn
+                             (dolist (button buttons)
+                               (setf (button-cell-switches button)
+                                     (mapcar (lambda (old) (cdr (assoc old pathways)))
+                                             (button-cell-switches button))))
+                             (return cells))))))
+
+
+
+(defstruct node
+  "A node of the graph of the stonedge game."
+  state
+  game
+  path
+  visitedp
+  startp
+  ;; neighbors is nil or a vector of neighbor nodes in (:right :left :front :back) order.
+  neighbors)
+
+
+(defvar *states* (make-hash-table :test (function equal))
+  "A hash-table mapping game states to nodes.")
+
+
+(defun make-graph-from-states (states)
+  (let* ((ne (make-hash-table))
+         (en (make-hash-table))
+         (elements
+          (let ((elements '()))
+            (maphash
+             (lambda (state node)
+               (let ((element (make-instance 'element-class :ident state)))
+                 (set-property element :path (reverse (node-path node)))
+                 (set-property element :dot-label
+                               #- (and) (with-output-to-string (out)
+                                                     (dolist (line (split-sequence:split-sequence
+                                                                    #\newline
+                                                                    (with-output-to-string (out)
+                                                                      (print-game (node-game node) out))))
+                                                       (princ line out)
+                                                       (princ "\\n" out)))
+                               #+ (and) "x")
+                 (set-property element :dot-fill-color (if (node-startp node)
+                                                           "Yellow"
+                                                           (ecase (first state)
+                                                             ((:win)  "Green")
+                                                             ((:lose) "Red")
+                                                             ((nil)   "White"))))
+                 (setf (gethash element en) node)
+                 (setf (gethash node ne) element)
+                 (push element elements)))
+             states)
+            elements))
+         (graph (make-instance 'graph-class
+                    :nodes (make-instance 'set-class :elements elements)
+                    :edge-class 'directed-edge)))
+    (print (list (length elements)  'elements))
+    (dolist (element elements)
+      (let ((node (gethash element en)))
+        (when (node-neighbors node)
+          (loop
+             :for successor :across (node-neighbors node)
+             :for direction :in '(:right :left :front :back)
+             :do (when successor
+                   (let ((edge (make-instance 'directed-edge-class
+                                   :from element
+                                   :to (gethash successor ne))))
+                     (set-property edge :dot-label direction)
+                     (add-edge graph edge)))))))
+    graph))
+
+(defun reset ()
+  "Cleans up the *STATES* hash-table."
+  (setf  *states* (make-hash-table :test (function equal))))
+
+
+(defun explore (game path)
+  "Walks the game graph, recoding each node in the *STATES* hash-table."
+  (let* ((state (game-state game))
+         (node  (gethash state *states*)))
+    (unless node
+      (setf node (setf (gethash state *states*)
+                       (make-node :state state
+                                  :game game
+                                  :path path
+                                  :visitedp nil))))
+    (unless (node-visitedp node)
+      (setf (node-visitedp node) t)
+      (unless (first state)
+        (setf (node-neighbors node)
+              (coerce
+               (loop
+                  :for move    :in '(:right :left :front :back)
+                  :for reverse :in '(:left :right :back :front)
+                  :collect (let ((child (copy game)))
+                             (move child move)
+                             (explore child (cons move path))))
+               'vector))))
+    node))
+
+
+(defun print-wins ()
+  "Find all the WIN nodes from the *STATES* hash-table, and print thei state and path."
+  (maphash (lambda (state node)
+             (when (eq :win (first state))
+               (print (list state (reverse (node-path node))))))
+           *states*))
+
+
+(defun solve-problem (problem)
+  "Solves the playtomo-stonedge game level PROBLEM,
+printing the number of states and the win states."
+  (time (progn
+          (reset)
+          (setf (node-startp (explore (parse-game problem) '())) t)
+          (print `(number of states = ,(hash-table-count *states*)))
+          (print-wins))))
+
+
+
+;;;-----------------------------------------------------------------------------
+
+(defparameter *simple*
+  '("
+...............
+...............
+......AO.......
+....OOOOOO.....
+..SOOOOOOO1OT..
+...IIOOOOO.....
+......IO.......
+...............
+...............
+"
+    (a :red     1)
+    (1 :pathway :closed)))
+
+(defparameter *level-36*
+  '("
+...............
+...............
+......AO.......
+....OOOIIO.....
+..SOOOICOO1OT..
+...IIOIOOO.....
+......IO.......
+...............
+...............
+"
+    (a :red     1)
+    (1 :pathway :closed)))
+
+(defparameter *level-37*
+  '("
+...........
+...........
+.....OC....
+....CII....
+..OO1BS23..
+..OR4TCOO..
+....COL....
+.....O5....
+...........
+...........
+"
+    (b :blue 1)
+    (r :red  4)
+    (l :red  2 3 5)
+    (1 :pathway :closed)
+    (2 :pathway :closed)
+    (3 :pathway :closed)
+    (4 :pathway :open)
+    (5 :pathway :open)))
+
+(defparameter *level-38*
+  '("
+.................
+.................
+..II.IIIICIIOIT..
+..II..III.IIIII..
+..SOII.II.IIIII..
+..IIICOOC........
+.................
+.................
+"))
+
+(defparameter *level-39*
+  '("
+..............
+..............
+..IIB1R2CLO...
+..IIO.....O...
+....O.....O...
+....O.....3O..
+....O.....OO..
+....IO...OTO..
+....SO...CO...
+.....OCOCOO...
+..............
+..............
+"
+    (b :blue 1)
+    (r :red  2)
+    (l :red  3)
+    (1 :pathway :closed)
+    (2 :pathway :closed)
+    (3 :pathway :closed)))
+
+(defparameter *level-52*
+  '("
+.........
+...RO
+...OC
+..SBOC1
+..OTIO2
+..3OCO
+..OC
+
+
+"
+    (R :red 3)
+    (B :blue 1 2)
+    (1 :pathway :closed)
+    (2 :pathway :closed)
+    (3 :pathway :closed)))
+
+;; (defparameter *game* (parse-game *problem*))
+;; (stonedge *level-39*)
+;; (solve-problem *problem*) (solve-problem *simple*)
+;; (time (progn (reset) (explore (parse-game ) '()) (find-win)))
+;;
+;; (solve-problem *level-37*)
+;; (solve-problem *level-38*)
+;; (solve-problem *level-39*)
+
+;; (solve-problem *level-52*)
+;;
+;; (let ((name "g"))
+;;   (with-open-file (dot (format nil "~A.dot" name)
+;;                        :direction :output
+;;                        :if-does-not-exist :create
+;;                        :if-exists :supersede)
+;;     (princ (generate-dot (setf *g* (make-graph-from-states *states*))) dot))
+;;   (ext:shell (format nil "dot -Tpng -o ~A.png  ~:*~A.dot" name)))
+
+;;;; THE END ;;;;
+
diff --git a/small-cl-pgms/puzzle.lisp b/small-cl-pgms/puzzle.lisp
new file mode 100644
index 0000000..73c6014
--- /dev/null
+++ b/small-cl-pgms/puzzle.lisp
@@ -0,0 +1,184 @@
+;;;; -*- mode:lisp; coding:utf-8 -*-
+;;;;****************************************************************************
+;;;;FILE:               puzzle.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    Simulate a puzzle with n²-1 moving squares.
+;;;;
+;;;;USAGE
+;;;;
+;;;;    (load "puzzle.lisp")
+;;;;    (com.informatimago.common-lisp.puzzle:main)
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2004-03-13 <PJB> Corrected bugs signaled by
+;;;;                     salma tariq <learningbug2004@yahoo.co.in>.
+;;;;    2004-03-09 <PJB> Created.
+;;;;BUGS
+;;;;LEGAL
+;;;;    Public Domain
+;;;;
+;;;;    This software is in Public Domain.
+;;;;    You're free to do with it as you please.
+;;;;****************************************************************************
+
+(DEFPACKAGE "COM.INFORMATIMAGO.COMMON-LISP.PUZZLE"
+  (:DOCUMENTATION
+   "This package simulates a puzzle with n²-1 moving squares.
+
+    This software is in Public Domain.
+    You're free to do with it as you please.")
+  (:USE "COMMON-LISP")
+  (:EXPORT  "MAIN")
+  );;COM.INFORMATIMAGO.COMMON-LISP.PUZZLE
+(in-package "COM.INFORMATIMAGO.COMMON-LISP.PUZZLE")
+
+
+(defclass square ()
+  ;; What? A class for a mere integer?  No. We just leave to the reader
+  ;; the pleasure to implement an picture-square subclass that would
+  ;; display a picture part like on the real puzzle games.
+  ((label :accessor label  :initform 0 :initarg :label :type integer)));;square
+
+
+(defclass puzzle ()
+  ((size   :accessor size   :initform 4 :initarg :size :type (integer 2))
+   (places :accessor places :initform nil
+           :type (simple-array (or null square) (* *)))
+   (empty  :accessor empty  :initform nil :type cons)));;puzzle
+
+
+(defgeneric get-coordinates  (puzzle relative-move))
+(defgeneric get-movable-list (puzzle))
+(defgeneric move-square      (puzzle x y))
+(defgeneric play             (puzzle))
+
+
+
+(defmethod initialize-instance ((self puzzle) &rest args)
+  (declare (ignore args))
+  (call-next-method)
+  (let ((places (make-array (list (size self) (size self))
+                            :element-type '(or null square)
+                            :initial-element nil)))
+    (declare (type (simple-array (or null square) (* *)) places))
+    (loop with size = (size self)
+          for i from 0 below size do
+          (loop for j from 0 below size do
+                (unless (and (= i (1- size)) (= j (1- size)))
+                  (setf (aref places i j)
+                        (make-instance 'square :label (1+ (+ (* i size) j)))))))
+    (setf (places self) places)
+    (setf (empty  self) (cons (1- (size self)) (1- (size self))))
+    self));;initialize-instance
+
+
+(defmethod print-object ((self puzzle) (out stream))
+  (let ((width (truncate (1+ (log (1- (* (size self) (size self))) 10)))))
+    (format out "~&")
+    (loop with size = (size self)
+          for i from 0 below size do
+          (loop for j from 0 below size do
+                (if (aref (places self) i j)
+                  (format out " ~VD " width (label (aref (places self) i j)))
+                  (format out " ~VA " width "")))
+          (format out "~%")))
+  (format out "~%")
+  self);;print-object
+
+
+(defmethod get-coordinates ((self puzzle) relative-move)
+  (block nil
+    (destructuring-bind (x . y) (empty self)
+      (case relative-move
+        ((:u) (when (< 0 x)                (return (values (1- x) y))))
+        ((:d) (when (< x (1- (size self))) (return (values (1+ x) y))))
+        ((:l) (when (< 0 y)                (return (values x (1- y)))))
+        ((:r) (when (< y (1- (size self))) (return (values x (1+ y)))))
+        (otherwise
+         (error "Invalid relative move, must be (member :l :r :u :d).")))
+      (error "Cannot move empty toward this direction."))));;get-coordinates
+
+
+
+(defmethod get-movable-list ((self puzzle))
+  (mapcan
+   (lambda (d) (handler-case
+              (multiple-value-bind (x y) (get-coordinates self d)
+                (list (list d (aref (places self) x y))))
+            (error () nil)))
+   '(:l :r :u :d)));;get-movable-list
+
+
+
+(defmethod move-square ((self puzzle) (x integer) (y integer))
+  (when (and (<= 0 x (1- (size self)))  (<= 0 y (1- (size self))))
+    (destructuring-bind (ex . ey) (empty self)
+      (psetf (aref (places self) x y)   (aref (places self) ex ey)
+             (aref (places self) ex ey) (aref (places self) x y))
+      (setf (empty self) (cons x y)))));;move-square
+
+
+(defmethod play ((self puzzle))
+  (loop
+   (tagbody
+    :loop
+    (format t "~&----------------------------------------~%")
+     (format t "~A" self)
+     (format t "square to move: ")
+     (let ((input (let ((*package*
+                         (find-package "COM.INFORMATIMAGO.COMMON-LISP.PUZZLE")))
+                    ;; To be able to read mere symbols (instead of keywords).
+                    (read)))
+           (movable (get-movable-list self))
+           square x y)
+       (typecase input
+         (integer
+          (let ((m (member input movable
+                           :key (lambda (x) (label (second x))) :test (function =))))
+            (if m
+              (progn
+                (setf square (second (car m)))
+                (multiple-value-setq (x y)
+                    (get-coordinates self (first (car m)))))
+              (progn
+                (format t "Cannot move square ~D.~%" input)
+                (go :loop)))))
+         (symbol
+          (handler-case
+              (progn
+                (multiple-value-setq (x y)
+                    (get-coordinates
+                     self (case input
+                            ((:l :left l left)   :l)
+                            ((:r :right r right) :r)
+                            ((:u :up u up)       :u)
+                            ((:d :down d down)   :d)
+                            ((:q :quit q quit :exit exit
+                              :abort abort :break break)
+                             (return-from play))
+                            (otherwise input))))
+                (setf square (aref (places self) x y)))
+            (error (err) (format t "~A~%" err) (go :loop))))
+         (otherwise (format t "Invalid input.~%") (go :loop)))
+       (move-square self x y)))));;play
+
+
+(defun main ()
+  (format t "~% Size of the puzzle: ")
+  (let ((input (read)))
+    (typecase input
+      (integer
+       (unless (<= 2 input 16)  (error "Cannot display such a puzzle.")))
+      (otherwise
+       (error "Please choose an integer size between 2 and 16 inclusive.")))
+    (play (make-instance 'com.informatimago.common-lisp.puzzle
+            :size input))));;main
+
+
+;;;; puzzle.lisp                      -- 2004-03-17 20:09:19 -- pascal   ;;;;
diff --git a/small-cl-pgms/quine.lisp b/small-cl-pgms/quine.lisp
new file mode 100644
index 0000000..3b2a125
--- /dev/null
+++ b/small-cl-pgms/quine.lisp
@@ -0,0 +1,121 @@
+;;;; -*- mode:lisp; coding:utf-8 -*-
+;;;;****************************************************************************
+;;;;FILE:               quine.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    Quines are programs that output themselves.
+;;;;    Three implementations in Common-Lisp.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2003-12-29 <PJB> Created.
+;;;;BUGS
+;;;;LEGAL
+;;;;    Public Domain
+;;;;
+;;;;    This software is in Public Domain.
+;;;;    You're free to do with it as you please.
+;;;;****************************************************************************
+
+
+;; -------------------------------------------------------------------
+;; QUINE-1 cheats  a little:  it works only  on clisp and on a
+;; non-compiled function, retrieving the lambda-expression stored in
+;; the  symbol-function slot of the symbol naming the function itself
+;; (similar  to retriving the source of the program from the hard disk).
+
+#+clisp
+(defun quine-1 nil
+  (let ((lexp (function-lambda-expression (symbol-function 'quine-1))))
+    (format t "~S~%"
+            `(defun ,(second (fourth lexp)) ,(second lexp)
+               ,@(cddr (fourth lexp))))))
+
+;; -------------------------------------------------------------------
+;; QUINE-2 is  nicer, but works by  generating a string  and using the
+;; FORMAT  interpreter  (with  the  ~S  trick  to  generate  a  quoted
+;; string...).
+
+(defun quine-2 nil
+  (let ((src "(DEFUN QUINE-2 NIL (LET ((SRC ~S)) (FORMAT T SRC SRC)))"))
+     (format t src src)))
+
+
+;; QUINE-2S is like QUINE-2 but instead of producing its source as a string,
+;; it returns it as a s-expression.
+
+(defun quine-2s nil
+  (let ((src "(DEFUN QUINE-2S NIL
+                (LET ((SRC ~S))
+                  (READ-FROM-STRING (FORMAT NIL SRC SRC))))"))
+    (read-from-string (format nil src src))))
+
+
+;; QUINE-2E is like QUINE-2S but instead of producing its source as its result
+;; it redefines itself.
+
+(defun quine-2e nil
+  (let ((src "(DEFUN QUINE-2E NIL
+                (LET ((SRC ~S))
+                  (EVAL (READ-FROM-STRING (FORMAT NIL SRC SRC)))))"))
+    (eval (read-from-string (format nil src src)))))
+
+
+;; -------------------------------------------------------------------
+;; QUINE-3 generates and returns a new tree equal to the sexp defining
+;; QUINE-3 itself.
+
+(defun quine-3 nil
+  (labels
+    ((find-car
+      (token tree)
+      (cond
+       ((atom tree) nil)
+       ((eq token (car tree)) tree)
+       (t (or (find-car token (car tree))
+              (find-car token (cdr tree)))))))
+    (let* ((source '(defun quine-3 nil
+                      (labels
+                        ((find-car
+                          (token tree)
+                          (cond
+                           ((atom tree) nil)
+                           ((eq token (car tree)) tree)
+                           (t (or (find-car token (car tree))
+                                  (find-car token (cdr tree)))))))
+                        (let* ((source ':quine)
+                               (quine-3 (copy-tree source)))
+                          (setf (car (find-car :quine quine-3)) source)
+                          quine-3))))
+           (quine-3 (copy-tree source)))
+      (setf (car (find-car :quine quine-3)) source)
+      quine-3)))
+
+
+;; -------------------------------------------------------------------
+;; QUINE-1 and QUINE-2, since they're outputing a string of character,
+;; must be used as follow to effectively loop the quine:
+
+(read-from-string (with-output-to-string (*standard-output*) (quine-2)))
+
+;; while the result of QUINE-2S and QUINE-3 can be evalued directly:
+
+(eval (quine-3))
+
+
+;; -------------------------------------------------------------------
+;; LAMBDA QUINE:
+
+((lambda (x) `(,x ',x)) '(lambda (x) `(,x ',x)))
+
+;; cmucl: ((LAMBDA (X) `(,X ',X)) '(LAMBDA (X) `(,X ',X)))
+;; clisp: ((LAMBDA (X) `(,X ',X)) '(LAMBDA (X) `(,X ',X)))
+;; emacs: (#1=(lambda (x) (\` ((\, x) (quote (\, x))))) (quote #1#))
+;; sbcl:  ((LAMBDA (X) (SB-IMPL::BACKQ-LIST X (SB-IMPL::BACKQ-LIST (QUOTE QUOTE) X))) (QUOTE (LAMBDA (X) (SB-IMPL::BACKQ-LIST X (SB-IMPL::BACKQ-LIST (QUOTE QUOTE) X)))))
+
+;;
+;;;; quine.lisp                       -- 2004-03-14 00:46:53 -- pascal   ;;;;
diff --git a/small-cl-pgms/rdp/com.informatimago.rdp.asd b/small-cl-pgms/rdp/com.informatimago.rdp.asd
new file mode 100644
index 0000000..7edf835
--- /dev/null
+++ b/small-cl-pgms/rdp/com.informatimago.rdp.asd
@@ -0,0 +1,21 @@
+;;;; -*- mode:lisp -*-
+
+(asdf:defsystem :com.informatimago.rdp
+    :name "Recursive Descent Parser Generator"
+    :description   "This package defines a Recursive Descent Parser generator.
+The client may define methods to generate the code of the parser in
+different languages than lisp."
+    :author "<PJB> Pascal Bourguignon <pjb@informatimago.com>"
+    :version "0.1"
+    :licence "GPL"
+    :properties ((#:author-email                   . "pjb@informatimago.com")
+                 (#:date                           . "Summer 2011")
+                 ((#:albert #:output-dir)          . "../documentation/com.informatimago.rdp/")
+                 ((#:albert #:formats)             . ("docbook"))
+                 ((#:albert #:docbook #:template)  . "book")
+                 ((#:albert #:docbook #:bgcolor)   . "white")
+                 ((#:albert #:docbook #:textcolor) . "black"))
+    :depends-on ("cl-ppcre")
+    :components ((:file "rdp")))
+
+;;;; THE END ;;;;
diff --git a/small-cl-pgms/rdp/com.informatimago.rdp.basic.asd b/small-cl-pgms/rdp/com.informatimago.rdp.basic.asd
new file mode 100644
index 0000000..9828c15
--- /dev/null
+++ b/small-cl-pgms/rdp/com.informatimago.rdp.basic.asd
@@ -0,0 +1,19 @@
+;;;; -*- mode:lisp -*-
+
+(asdf:defsystem :com.informatimago.rdp.basic
+    :name "Recursive Descent Parser Generator - BASIC generator."
+    :description   "This package defines methods to generate the parsers in BASIC."
+    :author "<PJB> Pascal Bourguignon <pjb@informatimago.com>"
+    :version "0.1"
+    :licence "GPL"
+    :properties ((#:author-email                   . "pjb@informatimago.com")
+                 (#:date                           . "Summer 2011")
+                 ((#:albert #:output-dir)          . "../documentation/com.informatimago.rdp.basic/")
+                 ((#:albert #:formats)             . ("docbook"))
+                 ((#:albert #:docbook #:template)  . "book")
+                 ((#:albert #:docbook #:bgcolor)   . "white")
+                 ((#:albert #:docbook #:textcolor) . "black"))
+    :depends-on ("com.informatimago.rdp")
+    :components ((:file "rdp-basic-gen")))
+
+;;;; THE END ;;;;
diff --git a/small-cl-pgms/rdp/com.informatimago.rdp.basic.example.asd b/small-cl-pgms/rdp/com.informatimago.rdp.basic.example.asd
new file mode 100644
index 0000000..e14ef37
--- /dev/null
+++ b/small-cl-pgms/rdp/com.informatimago.rdp.basic.example.asd
@@ -0,0 +1,20 @@
+;;;; -*- mode:lisp -*-
+
+(asdf:defsystem :com.informatimago.rdp.basic.example
+    :name "An example of parser generated in BASIC with the Recursive Descent Parser Generator."
+    :description "An example of parser generated in BASIC with the Recursive Descent Parser Generator."
+    :author "<PJB> Pascal Bourguignon <pjb@informatimago.com>"
+    :version "0.1"
+    :licence "GPL"
+    :properties ((#:author-email                   . "pjb@informatimago.com")
+                 (#:date                           . "Summer 2011")
+                 ((#:albert #:output-dir)          . "../documentation/com.informatimago.rdp.basic.example/")
+                 ((#:albert #:formats)             . ("docbook"))
+                 ((#:albert #:docbook #:template)  . "book")
+                 ((#:albert #:docbook #:bgcolor)   . "white")
+                 ((#:albert #:docbook #:textcolor) . "black"))
+    :depends-on ("com.informatimago.rdp"
+                 "com.informatimago.rdp.basic")
+    :components ((:file "example-basic")))
+
+;;;; THE END ;;;;
diff --git a/small-cl-pgms/rdp/com.informatimago.rdp.example.asd b/small-cl-pgms/rdp/com.informatimago.rdp.example.asd
new file mode 100644
index 0000000..2e8718e
--- /dev/null
+++ b/small-cl-pgms/rdp/com.informatimago.rdp.example.asd
@@ -0,0 +1,19 @@
+;;;; -*- mode:lisp -*-
+
+(asdf:defsystem :com.informatimago.rdp.example
+    :name "An example of parser generated with the Recursive Descent Parser Generator."
+    :description "An example of parser generated with the Recursive Descent Parser Generator."
+    :author "<PJB> Pascal Bourguignon <pjb@informatimago.com>"
+    :version "0.1"
+    :licence "GPL"
+    :properties ((#:author-email                   . "pjb@informatimago.com")
+                 (#:date                           . "Summer 2011")
+                 ((#:albert #:output-dir)          . "../documentation/com.informatimago.rdp.example/")
+                 ((#:albert #:formats)             . ("docbook"))
+                 ((#:albert #:docbook #:template)  . "book")
+                 ((#:albert #:docbook #:bgcolor)   . "white")
+                 ((#:albert #:docbook #:textcolor) . "black"))
+    :depends-on ("com.informatimago.rdp")
+    :components ((:file "example-lisp")))
+
+;;;; THE END ;;;;
diff --git a/small-cl-pgms/rdp/example-basic-dribble.txt b/small-cl-pgms/rdp/example-basic-dribble.txt
new file mode 100644
index 0000000..9d69c1f
--- /dev/null
+++ b/small-cl-pgms/rdp/example-basic-dribble.txt
@@ -0,0 +1,684 @@
+;; Loading file /home/pjb/.clisprc.lisp ...
+;; Reading ASDF packages from /home/pjb/asdf-central-registry.data...
+; loading system definition from /usr/local/share/lisp/packages/net/sourceforge/cclan/asdf-install/asdf-install.asd into #<PACKAGE ASDF0>
+; registering #<SYSTEM ASDF-INSTALL #x2048F146> as ASDF-INSTALL
+0 errors, 0 warnings
+[1]> (setf *print-circle* nil)
+NIL
+
+;;; First we load the parser generator.
+
+[2]> (load"rdp.lisp")
+;; Loading file rdp.lisp ...
+;; Loaded file rdp.lisp
+T
+
+;;; Second we load the pseudo basic generator.
+
+[5]>  (load"rdp-basic-gen.lisp")
+;; Loading file rdp-basic-gen.lisp ...
+WARNING: The generic function #<STANDARD-GENERIC-FUNCTION GEN-BOILERPLATE> is
+         being modified, but has already been called.
+;; Loaded file rdp-basic-gen.lisp
+T
+
+;;; Next, we load the grammar definition.
+;;; This will generate the scanner and parser for that language.
+;;; We could write: (with-open-file (*standard-output* "parser.bas"
+;;;                                  :direction :output :if-exists :supersede
+;;;                                  :if-does-not-exist :create)
+;;;                      (load "example-basic.lisp"))
+;;; to save the basic program into the file "parser.bas".
+
+
+[6]> (load"example-basic.lisp")
+;; Loading file example-basic.lisp ...
+  10 SCANSRC$="" : SCANFUN$="" : SCANPOS=0
+  20 CURTOK$=""  : CURTXT$=""  : CURPOS=0
+  30 SPACES$=
+  40 DEF SCANEOF : IF LEN(SCANSRC$)<=SCANPOS THEN RETURN 1 ELSE RETURN 0 : ENDFUN
+  50 SUB ACCEPT
+  60   IF TOKEN$ <> CURTOK$ THEN
+  70      PRINT "ERROR: AT POSITION",CURPOS,"EXPECTED ",TOKEN$," NOT ",CURTOK$
+  80      STOP
+  90   ELSE
+ 100      ACCEPTOK$=CURTOK$:ACCEPTXT$=CURTXT$:ACCEPPOS$=CURPOS$
+ 110      CALL SCANFUN$
+ 120   ENDIF
+ 130 ENDSUB
+ 140 MAXCONS=100000
+ 150 NIL=0:CONS=1:STRING=2:NUMBER=3
+ 160 TYPELABEL$[NIL]="NIL"
+ 170 TYPELABEL$[CONS]="CONS"
+ 180 TYPELABEL$[STRING]="STRING"
+ 190 TYPELABEL$[NUMBER]="NUMBER"
+ 200 DIM TYPES[MAXCONS],CAR[MAXCONS],CDR[MAXCONS],STRINGS$[MAXCONS],NUMBERS[MAXCONS]
+ 210 TYPES[NIL]=NIL:CAR[NIL]=NIL:CDR[NIL]=NIL:STRINGS$[NIL]="NIL":NUMBERS[NIL]=0
+ 220 FREE=MAXCONS
+ 230 SUB CONS
+ 240   IF FREE<=1 THEN PRINT "ERROR: OUT OF CONS SPACE" : STOP : ENDIF
+ 250   FREE=FREE-1
+ 260   TYPES[FREE]=CONS
+ 270   CAR[FREE]=NCAR
+ 280   CDR[FREE]=NCDR
+ 290   RES=FREE
+ 300 ENDSUB
+ 310 SUB MKSTR
+ 320   IF FREE<=1 THEN PRINT "ERROR: OUT OF CONS SPACE" : STOP : ENDIF
+ 330   FREE=FREE-1
+ 340   TYPES[FREE]=STRING
+ 350   STRING$[FREE]=NSTRING$
+ 360   RES=FREE
+ 370 ENDSUB
+ 380 SUB MKNUM
+ 390   IF FREE<=1 THEN PRINT "ERROR: OUT OF CONS SPACE" : STOP : ENDIF
+ 400   FREE=FREE-1
+ 410   TYPES[FREE]=NUMBER
+ 420   NUMBER[FREE]=NNUMBER
+ 430   RES=FREE
+ 440 ENDSUB
+ 450 SUB REVERSE
+ 460   REV=0:TREV=NIL
+ 470   WHILE LIST<>0
+ 480    IF TYPES[LIST]<>CONS THEN
+ 490       PRINT "ERROR: REVERSE EXPECTS A LIST, NOT A ",TYPELABEL$[TYPES[LIST]]
+ 500       STOP
+ 510     ELSE
+ 520       NEW=CDR[LIST]
+ 530       CDR[LIST]=REV:TYPES[LIST]=TREV
+ 540       REV=LIST:TREV=CONS
+ 550       LIST=NEW
+ 560     ENDIF
+ 570   ENDWHILE
+ 580   RES=REV
+ 590 ENDSUB
+ 600 SUB SCANEXAMPLE
+ 610   WHILE POS(SCANSRC$[SCANPOS],SPACES$)>0 : SCANPOS=SCANPOS+1 : ENDWHILE
+ 620   CURPOS=SCANPOS
+ 630   IF SCANEOF<>0 THEN
+ 640     SCANPOS=LEN(SCANSRC$)
+ 650     SCANTXT$="<END OF SOURCE>"
+ 660     SCANTOK$=""
+ 670   ELSE
+ 680     REM ASSUMING THERE IS SOME WAY TO MATCH REGEXPS IN BASIC...
+ 690     MATCHREGEXP  "^\(procedure\>\|begin\>\|while\>\|const\>\|call\>\|then\>\|odd\>\|end\>\|var\>\|<=\|>=\|:=\|if\>\|do\>\|(\|)\|\*\|/\|+\|-\|#\|<\|>\|=\|,\|;\|\.\)" SCANSRC$,SCANPOS INTO START,END
+ 700     IF START>0 THEN
+ 710       SCANPOS=END
+ 720       SCANTXT$=MID$(SCANSRC$,START,END)
+ 730       SCANTOK$=SCANTXT$
+ 740     ELSE
+ 750  MATCHREGEXP "^\\([A-Za-z][A-Za-z0-9]*\\)" SCANSRC$,SCANPOS INTO START,END
+ 760  IF START>0 THEN
+ 770       SCANPOS=END
+ 780       SCANTXT$=MID$(SCANSRC$,START,END)
+ 790       SCANTOK$="IDENT"
+ 800  ELSE
+ 810  MATCHREGEXP "^\\(^\([-+]\?[0-9]\+\.[0-9]\+\([Ee][-+]\?[0-9]\+\)\?\)\\)" SCANSRC$,SCANPOS INTO START,END
+ 820  IF START>0 THEN
+ 830       SCANPOS=END
+ 840       SCANTXT$=MID$(SCANSRC$,START,END)
+ 850       SCANTOK$="REAL"
+ 860  ELSE
+ 870  MATCHREGEXP "^\\([-+]\?[0-9]\+\\)" SCANSRC$,SCANPOS INTO START,END
+ 880  IF START>0 THEN
+ 890       SCANPOS=END
+ 900       SCANTXT$=MID$(SCANSRC$,START,END)
+ 910       SCANTOK$="INTEGER"
+ 920  ELSE
+ 930      PRINT "ERROR: AT POSITION",CURPOS,"EXPECTED ",TOKEN$," NOT ",CURTOK$
+ 940      STOP
+ 950  ENDIF
+ 960  ENDIF
+ 970  ENDIF
+ 980     ENDIF
+ 990   ENDIF
+1000 ENDSUB
+1010 SUB PARSEPROGRAM
+1020 IF (CURTOK$="IDENT" OR CURTOK$="call" OR CURTOK$="begin" OR CURTOK$="if" OR CURTOK$="while" OR CURTOK$="procedure" OR CURTOK$="var" OR CURTOK$="const") THEN
+1030   CALL PARSEBLOCK
+1040 ELSE
+1050   RET=NIL
+1060 ENDIF
+1070 L1A1=RES
+1080 TOKEN$="." : CALL ACCEPT
+1090 L1A2=RES
+1100 A2=L1A2:NCAR=A2:NCDR=NIL:CALL CONS:A0=RES
+1110 A1=L1A1:NCAR=A1:NCDR=A0:CALL CONS:A0=RES
+1120 RES=A1
+1130 ENDSUB
+1140 SUB PARSEFACTOR
+1150 IF (CURTOK$="IDENT") THEN
+1160 TOKEN$="IDENT" : CALL ACCEPT
+1170 ELSE
+1180 IF (CURTOK$="INTEGER" OR CURTOK$="REAL") THEN
+1190 IF (CURTOK$="INTEGER" OR CURTOK$="REAL") THEN
+1200   CALL PARSENUMBER
+1210 ELSE
+1220   PRINT "ERROR: UNEXPECTED TOKEN ",SCANTOK$
+1230   STOP
+1240 ENDIF
+1250 ELSE
+1260 IF (CURTOK$="(") THEN
+1270 TOKEN$="(" : CALL ACCEPT
+1280 L3A1=RES
+1290 IF (CURTOK$="IDENT" OR CURTOK$="INTEGER" OR CURTOK$="REAL" OR CURTOK$="(" OR CURTOK$="+" OR CURTOK$="-") THEN
+1300   CALL PARSEEXPRESSION
+1310 ELSE
+1320   PRINT "ERROR: UNEXPECTED TOKEN ",SCANTOK$
+1330   STOP
+1340 ENDIF
+1350 L3A2=RES
+1360 TOKEN$=")" : CALL ACCEPT
+1370 L3A3=RES
+1380 A3=L3A3:NCAR=A3:NCDR=NIL:CALL CONS:A0=RES
+1390 A2=L3A2:NCAR=A2:NCDR=A0:CALL CONS:A0=RES
+1400 A1=L3A1:NCAR=A1:NCDR=A0:CALL CONS:A0=RES
+1410 RES=A2
+1420 ELSE
+1430 PRINT "ERROR: DID NOT EXPECT ",CURTOK$
+1440 STOP
+1450 ENDIF
+1460 ENDIF
+1470 ENDIF
+1480 L2A1=RES
+1490 A1=L2A1:NCAR=A1:NCDR=NIL:CALL CONS:A0=RES
+1500 RES=A1
+1510 ENDSUB
+1520 SUB PARSETERM
+1530 IF (CURTOK$="IDENT" OR CURTOK$="INTEGER" OR CURTOK$="REAL" OR CURTOK$="(") THEN
+1540   CALL PARSEFACTOR
+1550 ELSE
+1560   PRINT "ERROR: UNEXPECTED TOKEN ",SCANTOK$
+1570   STOP
+1580 ENDIF
+1590 L4A1=RES
+1600 L5RES=NIL
+1610 WHILE (CURTOK$="*" OR CURTOK$="/")
+1620 IF (CURTOK$="*") THEN
+1630 TOKEN$="*" : CALL ACCEPT
+1640 ELSE
+1650 IF (CURTOK$="/") THEN
+1660 TOKEN$="/" : CALL ACCEPT
+1670 ELSE
+1680 PRINT "ERROR: DID NOT EXPECT ",CURTOK$
+1690 STOP
+1700 ENDIF
+1710 ENDIF
+1720 L6A1=RES
+1730 IF (CURTOK$="IDENT" OR CURTOK$="INTEGER" OR CURTOK$="REAL" OR CURTOK$="(") THEN
+1740   CALL PARSEFACTOR
+1750 ELSE
+1760   PRINT "ERROR: UNEXPECTED TOKEN ",SCANTOK$
+1770   STOP
+1780 ENDIF
+1790 L6A2=RES
+1800 A2=L6A2:NCAR=A2:NCDR=NIL:CALL CONS:A0=RES
+1810 A1=L6A1:NCAR=A1:NCDR=A0:CALL CONS:A0=RES
+1820 $0
+1830 NCAR=RET:NCDR=L5RES:CALL CONS:L5RES=RES
+1840 ENDWHILE
+1850 LIST=L5RES:CALL REVERSE
+1860 L4A2=RES
+1870 A2=L4A2:NCAR=A2:NCDR=NIL:CALL CONS:A0=RES
+1880 A1=L4A1:NCAR=A1:NCDR=A0:CALL CONS:A0=RES
+1890 NCAR=A1:NCDR=A2:CALL CONS
+1900 ENDSUB
+1910 SUB PARSEEXPRESSION
+1920 L8RES=NIL
+1930 IF (CURTOK$="+" OR CURTOK$="-") THEN
+1940 IF (CURTOK$="+") THEN
+1950 TOKEN$="+" : CALL ACCEPT
+1960 ELSE
+1970 IF (CURTOK$="-") THEN
+1980 TOKEN$="-" : CALL ACCEPT
+1990 ELSE
+2000 PRINT "ERROR: DID NOT EXPECT ",CURTOK$
+2010 STOP
+2020 ENDIF
+2030 ENDIF
+2040 ELSE
+2050   RES=NIL
+2060 ENDIF
+2070 L7A1=RES
+2080 IF (CURTOK$="IDENT" OR CURTOK$="INTEGER" OR CURTOK$="REAL" OR CURTOK$="(") THEN
+2090   CALL PARSETERM
+2100 ELSE
+2110   PRINT "ERROR: UNEXPECTED TOKEN ",SCANTOK$
+2120   STOP
+2130 ENDIF
+2140 L7A2=RES
+2150 L9RES=NIL
+2160 WHILE (CURTOK$="+" OR CURTOK$="-")
+2170 IF (CURTOK$="+") THEN
+2180 TOKEN$="+" : CALL ACCEPT
+2190 ELSE
+2200 IF (CURTOK$="-") THEN
+2210 TOKEN$="-" : CALL ACCEPT
+2220 ELSE
+2230 PRINT "ERROR: DID NOT EXPECT ",CURTOK$
+2240 STOP
+2250 ENDIF
+2260 ENDIF
+2270 L10A1=RES
+2280 IF (CURTOK$="IDENT" OR CURTOK$="INTEGER" OR CURTOK$="REAL" OR CURTOK$="(") THEN
+2290   CALL PARSETERM
+2300 ELSE
+2310   PRINT "ERROR: UNEXPECTED TOKEN ",SCANTOK$
+2320   STOP
+2330 ENDIF
+2340 L10A2=RES
+2350 A2=L10A2:NCAR=A2:NCDR=NIL:CALL CONS:A0=RES
+2360 A1=L10A1:NCAR=A1:NCDR=A0:CALL CONS:A0=RES
+2370 NCAR=A2:NCDR=NIL:CALL CONS
+2380 NCAR=A1:NCDR=RES:CALL CONS
+2390 NCAR=RET:NCDR=L9RES:CALL CONS:L9RES=RES
+2400 ENDWHILE
+2410 LIST=L9RES:CALL REVERSE
+2420 L7A3=RES
+2430 A3=L7A3:NCAR=A3:NCDR=NIL:CALL CONS:A0=RES
+2440 A2=L7A2:NCAR=A2:NCDR=A0:CALL CONS:A0=RES
+2450 A1=L7A1:NCAR=A1:NCDR=A0:CALL CONS:A0=RES
+2460 IF A1<>0 THEN
+2470   NCAR=A2:NCDR=NIL:CALL CONS
+2480   NCAR=A1:NCDR=RES:CALL CONS
+2490   NCAR=RES
+2500 ELSE
+2510   NCAR=A2
+2520 ENDIF
+2530 NCDR=A3:CALL CONS
+2540 TMP=RES
+2550 NSTRING$="+":CALL MKSTR:NCAR=RES:NCDR=TMP:CALL CONS
+2560 ENDSUB
+2570 SUB PARSECONDITION
+2580 IF (CURTOK$="odd") THEN
+2590 TOKEN$="odd" : CALL ACCEPT
+2600 L12A1=RES
+2610 IF (CURTOK$="IDENT" OR CURTOK$="INTEGER" OR CURTOK$="REAL" OR CURTOK$="(" OR CURTOK$="+" OR CURTOK$="-") THEN
+2620   CALL PARSEEXPRESSION
+2630 ELSE
+2640   PRINT "ERROR: UNEXPECTED TOKEN ",SCANTOK$
+2650   STOP
+2660 ENDIF
+2670 L12A2=RES
+2680 A2=L12A2:NCAR=A2:NCDR=NIL:CALL CONS:A0=RES
+2690 A1=L12A1:NCAR=A1:NCDR=A0:CALL CONS:A0=RES
+2700 NCAR=A2:NCDR=NIL:CALL CONS:TMP=RES
+2710 NSTRING$="ODD":CALL MKSTR
+2720 NCAR=RES:NCDR=TMP:CALL CONS
+2730 ELSE
+2740 IF (CURTOK$="IDENT" OR CURTOK$="INTEGER" OR CURTOK$="REAL" OR CURTOK$="(" OR CURTOK$="+" OR CURTOK$="-") THEN
+2750 IF (CURTOK$="IDENT" OR CURTOK$="INTEGER" OR CURTOK$="REAL" OR CURTOK$="(" OR CURTOK$="+" OR CURTOK$="-") THEN
+2760   CALL PARSEEXPRESSION
+2770 ELSE
+2780   PRINT "ERROR: UNEXPECTED TOKEN ",SCANTOK$
+2790   STOP
+2800 ENDIF
+2810 L13A1=RES
+2820 IF (CURTOK$="=") THEN
+2830 TOKEN$="=" : CALL ACCEPT
+2840 ELSE
+2850 IF (CURTOK$="#") THEN
+2860 TOKEN$="#" : CALL ACCEPT
+2870 ELSE
+2880 IF (CURTOK$="<") THEN
+2890 TOKEN$="<" : CALL ACCEPT
+2900 ELSE
+2910 IF (CURTOK$="<=") THEN
+2920 TOKEN$="<=" : CALL ACCEPT
+2930 ELSE
+2940 IF (CURTOK$=">") THEN
+2950 TOKEN$=">" : CALL ACCEPT
+2960 ELSE
+2970 IF (CURTOK$=">=") THEN
+2980 TOKEN$=">=" : CALL ACCEPT
+2990 ELSE
+3000 PRINT "ERROR: DID NOT EXPECT ",CURTOK$
+3010 STOP
+3020 ENDIF
+3030 ENDIF
+3040 ENDIF
+3050 ENDIF
+3060 ENDIF
+3070 ENDIF
+3080 L13A2=RES
+3090 IF (CURTOK$="IDENT" OR CURTOK$="INTEGER" OR CURTOK$="REAL" OR CURTOK$="(" OR CURTOK$="+" OR CURTOK$="-") THEN
+3100   CALL PARSEEXPRESSION
+3110 ELSE
+3120   PRINT "ERROR: UNEXPECTED TOKEN ",SCANTOK$
+3130   STOP
+3140 ENDIF
+3150 L13A3=RES
+3160 A3=L13A3:NCAR=A3:NCDR=NIL:CALL CONS:A0=RES
+3170 A2=L13A2:NCAR=A2:NCDR=A0:CALL CONS:A0=RES
+3180 A1=L13A1:NCAR=A1:NCDR=A0:CALL CONS:A0=RES
+3190 NCAR=A3:NCDR=NIL:CALL CONS
+3200 NCAR=A1:NCDR=RES:CALL CONS
+3210 NCAR=A2:NCDR=RES:CALL CONS
+3220 ELSE
+3230 PRINT "ERROR: DID NOT EXPECT ",CURTOK$
+3240 STOP
+3250 ENDIF
+3260 ENDIF
+3270 L11A1=RES
+3280 A1=L11A1:NCAR=A1:NCDR=NIL:CALL CONS:A0=RES
+3290 RES=A1
+3300 ENDSUB
+3310 SUB PARSENUMBER
+3320 IF (CURTOK$="INTEGER") THEN
+3330 TOKEN$="INTEGER" : CALL ACCEPT
+3340 ELSE
+3350 IF (CURTOK$="REAL") THEN
+3360 TOKEN$="REAL" : CALL ACCEPT
+3370 ELSE
+3380 PRINT "ERROR: DID NOT EXPECT ",CURTOK$
+3390 STOP
+3400 ENDIF
+3410 ENDIF
+3420 L14A1=RES
+3430 A1=L14A1:NCAR=A1:NCDR=NIL:CALL CONS:A0=RES
+3440 RES=A1
+3450 ENDSUB
+3460 SUB PARSESTATEMENT
+3470 L16RES=NIL
+3480 IF (CURTOK$="IDENT" OR CURTOK$="call" OR CURTOK$="begin" OR CURTOK$="if" OR CURTOK$="while") THEN
+3490 IF (CURTOK$="IDENT") THEN
+3500 TOKEN$="IDENT" : CALL ACCEPT
+3510 L17A1=RES
+3520 TOKEN$=":=" : CALL ACCEPT
+3530 L17A2=RES
+3540 IF (CURTOK$="IDENT" OR CURTOK$="INTEGER" OR CURTOK$="REAL" OR CURTOK$="(" OR CURTOK$="+" OR CURTOK$="-") THEN
+3550   CALL PARSEEXPRESSION
+3560 ELSE
+3570   PRINT "ERROR: UNEXPECTED TOKEN ",SCANTOK$
+3580   STOP
+3590 ENDIF
+3600 L17A3=RES
+3610 A3=L17A3:NCAR=A3:NCDR=NIL:CALL CONS:A0=RES
+3620 A2=L17A2:NCAR=A2:NCDR=A0:CALL CONS:A0=RES
+3630 A1=L17A1:NCAR=A1:NCDR=A0:CALL CONS:A0=RES
+3640 NCAR=A3:NCDR=NIL:CALL CONS
+3650 NCAR=A1:NCDR=RES:CALL CONS
+3660 TMP=RES:NSTRING$="LET":CALL MKSTR
+3670 NCAR=RES:NCDR=TMP:CALL CONS
+3680 ELSE
+3690 IF (CURTOK$="call") THEN
+3700 TOKEN$="call" : CALL ACCEPT
+3710 L18A1=RES
+3720 TOKEN$="IDENT" : CALL ACCEPT
+3730 L18A2=RES
+3740 A2=L18A2:NCAR=A2:NCDR=NIL:CALL CONS:A0=RES
+3750 A1=L18A1:NCAR=A1:NCDR=A0:CALL CONS:A0=RES
+3760 NCAR=A2:NCDR=NIL:CALL CONS
+3770 TMP=RES:NSTRING$="CALL":CALL MKSTR
+3780 NCAR=RES:NCDR=TMP:CALL CONS
+3790 ELSE
+3800 IF (CURTOK$="begin") THEN
+3810 TOKEN$="begin" : CALL ACCEPT
+3820 L19A1=RES
+3830 IF (CURTOK$="IDENT" OR CURTOK$="call" OR CURTOK$="begin" OR CURTOK$="if" OR CURTOK$="while") THEN
+3840   CALL PARSESTATEMENT
+3850 ELSE
+3860   RET=NIL
+3870 ENDIF
+3880 L19A2=RES
+3890 L20RES=NIL
+3900 WHILE (CURTOK$=";")
+3910 TOKEN$=";" : CALL ACCEPT
+3920 L21A1=RES
+3930 IF (CURTOK$="IDENT" OR CURTOK$="call" OR CURTOK$="begin" OR CURTOK$="if" OR CURTOK$="while") THEN
+3940   CALL PARSESTATEMENT
+3950 ELSE
+3960   RET=NIL
+3970 ENDIF
+3980 L21A2=RES
+3990 A2=L21A2:NCAR=A2:NCDR=NIL:CALL CONS:A0=RES
+4000 A1=L21A1:NCAR=A1:NCDR=A0:CALL CONS:A0=RES
+4010 RES=A2
+4020 NCAR=RET:NCDR=L20RES:CALL CONS:L20RES=RES
+4030 ENDWHILE
+4040 LIST=L20RES:CALL REVERSE
+4050 L19A3=RES
+4060 TOKEN$="end" : CALL ACCEPT
+4070 L19A4=RES
+4080 A4=L19A4:NCAR=A4:NCDR=NIL:CALL CONS:A0=RES
+4090 A3=L19A3:NCAR=A3:NCDR=A0:CALL CONS:A0=RES
+4100 A2=L19A2:NCAR=A2:NCDR=A0:CALL CONS:A0=RES
+4110 A1=L19A1:NCAR=A1:NCDR=A0:CALL CONS:A0=RES
+4120 NCAR=A2:NCDR=A3:CALL CONS
+4130 ELSE
+4140 IF (CURTOK$="if") THEN
+4150 TOKEN$="if" : CALL ACCEPT
+4160 L22A1=RES
+4170 IF (CURTOK$="odd" OR CURTOK$="IDENT" OR CURTOK$="INTEGER" OR CURTOK$="REAL" OR CURTOK$="(" OR CURTOK$="+" OR CURTOK$="-") THEN
+4180   CALL PARSECONDITION
+4190 ELSE
+4200   PRINT "ERROR: UNEXPECTED TOKEN ",SCANTOK$
+4210   STOP
+4220 ENDIF
+4230 L22A2=RES
+4240 TOKEN$="then" : CALL ACCEPT
+4250 L22A3=RES
+4260 IF (CURTOK$="IDENT" OR CURTOK$="call" OR CURTOK$="begin" OR CURTOK$="if" OR CURTOK$="while") THEN
+4270   CALL PARSESTATEMENT
+4280 ELSE
+4290   RET=NIL
+4300 ENDIF
+4310 L22A4=RES
+4320 A4=L22A4:NCAR=A4:NCDR=NIL:CALL CONS:A0=RES
+4330 A3=L22A3:NCAR=A3:NCDR=A0:CALL CONS:A0=RES
+4340 A2=L22A2:NCAR=A2:NCDR=A0:CALL CONS:A0=RES
+4350 A1=L22A1:NCAR=A1:NCDR=A0:CALL CONS:A0=RES
+4360 NCAR=A4:NCDR=NIL:CALL CONS
+4370 NCAR=A2:NCDR=RES:CALL CONS
+4380 TMP=RES:NSTRING$="IF":CALL MKSTR
+4390 NCAR=RES:NCDR=TMP:CALL CONS
+4400 ELSE
+4410 IF (CURTOK$="while") THEN
+4420 TOKEN$="while" : CALL ACCEPT
+4430 L23A1=RES
+4440 IF (CURTOK$="odd" OR CURTOK$="IDENT" OR CURTOK$="INTEGER" OR CURTOK$="REAL" OR CURTOK$="(" OR CURTOK$="+" OR CURTOK$="-") THEN
+4450   CALL PARSECONDITION
+4460 ELSE
+4470   PRINT "ERROR: UNEXPECTED TOKEN ",SCANTOK$
+4480   STOP
+4490 ENDIF
+4500 L23A2=RES
+4510 TOKEN$="do" : CALL ACCEPT
+4520 L23A3=RES
+4530 IF (CURTOK$="IDENT" OR CURTOK$="call" OR CURTOK$="begin" OR CURTOK$="if" OR CURTOK$="while") THEN
+4540   CALL PARSESTATEMENT
+4550 ELSE
+4560   RET=NIL
+4570 ENDIF
+4580 L23A4=RES
+4590 A4=L23A4:NCAR=A4:NCDR=NIL:CALL CONS:A0=RES
+4600 A3=L23A3:NCAR=A3:NCDR=A0:CALL CONS:A0=RES
+4610 A2=L23A2:NCAR=A2:NCDR=A0:CALL CONS:A0=RES
+4620 A1=L23A1:NCAR=A1:NCDR=A0:CALL CONS:A0=RES
+4630 NCAR=A4:NCDR=NIL:CALL CONS
+4640 NCAR=A2:NCDR=RES:CALL CONS
+4650 TMP=RES:NSTRING$="WHILE":CALL MKSTR
+4660 NCAR=RES:NCDR=TMP:CALL CONS
+4670 ELSE
+4680 PRINT "ERROR: DID NOT EXPECT ",CURTOK$
+4690 STOP
+4700 ENDIF
+4710 ENDIF
+4720 ENDIF
+4730 ENDIF
+4740 ENDIF
+4750 ELSE
+4760   RES=NIL
+4770 ENDIF
+4780 L15A1=RES
+4790 A1=L15A1:NCAR=A1:NCDR=NIL:CALL CONS:A0=RES
+4800 RES=A1
+4810 ENDSUB
+4820 SUB PARSEBLOCK
+4830 L25RES=NIL
+4840 IF (CURTOK$="const") THEN
+4850 TOKEN$="const" : CALL ACCEPT
+4860 L26A1=RES
+4870 TOKEN$="IDENT" : CALL ACCEPT
+4880 L26A2=RES
+4890 TOKEN$="=" : CALL ACCEPT
+4900 L26A3=RES
+4910 IF (CURTOK$="INTEGER" OR CURTOK$="REAL") THEN
+4920   CALL PARSENUMBER
+4930 ELSE
+4940   PRINT "ERROR: UNEXPECTED TOKEN ",SCANTOK$
+4950   STOP
+4960 ENDIF
+4970 L26A4=RES
+4980 L27RES=NIL
+4990 WHILE (CURTOK$=",")
+5000 TOKEN$="," : CALL ACCEPT
+5010 L28A1=RES
+5020 TOKEN$="IDENT" : CALL ACCEPT
+5030 L28A2=RES
+5040 TOKEN$="=" : CALL ACCEPT
+5050 L28A3=RES
+5060 IF (CURTOK$="INTEGER" OR CURTOK$="REAL") THEN
+5070   CALL PARSENUMBER
+5080 ELSE
+5090   PRINT "ERROR: UNEXPECTED TOKEN ",SCANTOK$
+5100   STOP
+5110 ENDIF
+5120 L28A4=RES
+5130 A4=L28A4:NCAR=A4:NCDR=NIL:CALL CONS:A0=RES
+5140 A3=L28A3:NCAR=A3:NCDR=A0:CALL CONS:A0=RES
+5150 A2=L28A2:NCAR=A2:NCDR=A0:CALL CONS:A0=RES
+5160 A1=L28A1:NCAR=A1:NCDR=A0:CALL CONS:A0=RES
+5170 NCAR=A4:NCDR=NIL:CALL CONS
+5180 NCAR=A2:NCDR=RES:CALL CONS
+5190 NCAR=RET:NCDR=L27RES:CALL CONS:L27RES=RES
+5200 ENDWHILE
+5210 LIST=L27RES:CALL REVERSE
+5220 L26A5=RES
+5230 TOKEN$=";" : CALL ACCEPT
+5240 L26A6=RES
+5250 A6=L26A6:NCAR=A6:NCDR=NIL:CALL CONS:A0=RES
+5260 A5=L26A5:NCAR=A5:NCDR=A0:CALL CONS:A0=RES
+5270 A4=L26A4:NCAR=A4:NCDR=A0:CALL CONS:A0=RES
+5280 A3=L26A3:NCAR=A3:NCDR=A0:CALL CONS:A0=RES
+5290 A2=L26A2:NCAR=A2:NCDR=A0:CALL CONS:A0=RES
+5300 A1=L26A1:NCAR=A1:NCDR=A0:CALL CONS:A0=RES
+5310 NCAR=A4:NCDR=NIL:CALL CONS
+5320 NCAR=A2:NCDR=RES:CALL CONS
+5330 NCAR=RES:NCDR=A5:CALL CONS
+5340 ELSE
+5350   RES=NIL
+5360 ENDIF
+5370 L24A1=RES
+5380 L29RES=NIL
+5390 IF (CURTOK$="var") THEN
+5400 TOKEN$="var" : CALL ACCEPT
+5410 L30A1=RES
+5420 TOKEN$="IDENT" : CALL ACCEPT
+5430 L30A2=RES
+5440 L31RES=NIL
+5450 WHILE (CURTOK$=",")
+5460 TOKEN$="," : CALL ACCEPT
+5470 L32A1=RES
+5480 TOKEN$="IDENT" : CALL ACCEPT
+5490 L32A2=RES
+5500 A2=L32A2:NCAR=A2:NCDR=NIL:CALL CONS:A0=RES
+5510 A1=L32A1:NCAR=A1:NCDR=A0:CALL CONS:A0=RES
+5520 RES=A2
+5530 NCAR=RET:NCDR=L31RES:CALL CONS:L31RES=RES
+5540 ENDWHILE
+5550 LIST=L31RES:CALL REVERSE
+5560 L30A3=RES
+5570 TOKEN$=";" : CALL ACCEPT
+5580 L30A4=RES
+5590 A4=L30A4:NCAR=A4:NCDR=NIL:CALL CONS:A0=RES
+5600 A3=L30A3:NCAR=A3:NCDR=A0:CALL CONS:A0=RES
+5610 A2=L30A2:NCAR=A2:NCDR=A0:CALL CONS:A0=RES
+5620 A1=L30A1:NCAR=A1:NCDR=A0:CALL CONS:A0=RES
+5630 NCAR=A3:NCDR=NIL:CALL CONS
+5640 NCAR=A2:NCDR=RES:CALL CONS
+5650 ELSE
+5660   RES=NIL
+5670 ENDIF
+5680 L24A2=RES
+5690 L33RES=NIL
+5700 WHILE (CURTOK$="procedure")
+5710 TOKEN$="procedure" : CALL ACCEPT
+5720 L34A1=RES
+5730 TOKEN$="IDENT" : CALL ACCEPT
+5740 L34A2=RES
+5750 TOKEN$=";" : CALL ACCEPT
+5760 L34A3=RES
+5770 IF (CURTOK$="IDENT" OR CURTOK$="call" OR CURTOK$="begin" OR CURTOK$="if" OR CURTOK$="while" OR CURTOK$="procedure" OR CURTOK$="var" OR CURTOK$="const") THEN
+5780   CALL PARSEBLOCK
+5790 ELSE
+5800   RET=NIL
+5810 ENDIF
+5820 L34A4=RES
+5830 TOKEN$=";" : CALL ACCEPT
+5840 L34A5=RES
+5850 A5=L34A5:NCAR=A5:NCDR=NIL:CALL CONS:A0=RES
+5860 A4=L34A4:NCAR=A4:NCDR=A0:CALL CONS:A0=RES
+5870 A3=L34A3:NCAR=A3:NCDR=A0:CALL CONS:A0=RES
+5880 A2=L34A2:NCAR=A2:NCDR=A0:CALL CONS:A0=RES
+5890 A1=L34A1:NCAR=A1:NCDR=A0:CALL CONS:A0=RES
+5900 NCAR=A4:NCDR=NIL:CALL CONS
+5910 NCAR=A2:NCDR=RES:CALL CONS
+5920 TMP=RES:NSTRING$="PROCEDURE":CALL MKSTR
+5930 NCAR=RES:NCDR=TMP:CALL CONS
+5940 NCAR=RET:NCDR=L33RES:CALL CONS:L33RES=RES
+5950 ENDWHILE
+5960 LIST=L33RES:CALL REVERSE
+5970 L24A3=RES
+5980 IF (CURTOK$="IDENT" OR CURTOK$="call" OR CURTOK$="begin" OR CURTOK$="if" OR CURTOK$="while") THEN
+5990   CALL PARSESTATEMENT
+6000 ELSE
+6010   RET=NIL
+6020 ENDIF
+6030 L24A4=RES
+6040 A4=L24A4:NCAR=A4:NCDR=NIL:CALL CONS:A0=RES
+6050 A3=L24A3:NCAR=A3:NCDR=A0:CALL CONS:A0=RES
+6060 A2=L24A2:NCAR=A2:NCDR=A0:CALL CONS:A0=RES
+6070 A1=L24A1:NCAR=A1:NCDR=A0:CALL CONS:A0=RES
+6080 NCAR=A4:NCDR=NIL:CALL CONS
+6090 NCAR=A3:NCDR=RES:CALL CONS
+6100 NCAR=A2:NCDR=RES:CALL CONS
+6110 NCAR=A1:NCDR=RES:CALL CONS
+6120 TMP=RES:NSTRING$="BLOCK":CALL MKSTR
+6130 NCAR=RES:NCDR=TMP:CALL CONS
+6140 ENDSUB
+6150 SUB PARSEEXAMPLE
+6160   SCANSRC$=SOURCE$ : SCANPOS=0 : SCANFUN$="SCANEXAMPLE"
+6170   CALL SCANFUN$
+6180   CALL PARSEPROGRAM
+6190   IF SCANEOF<>0 THEN
+6200     PRINT "ERROR: END OF SOURCE NOT REACHED"
+6210     STOP
+6220   ENDIF
+6230 ENDSUB
+;; Loaded file example-basic.lisp
+T
+[7]>
+
+;;; Parsing a source with this basic program would be done with:
+
+SOURCE$=  "
+    const abc = 123,
+          pi=3.141592e+0;
+    var a,b,c;
+    procedure gcd;
+    begin
+        while a # b do
+        begin
+             if a<b then b:=b-a ;
+             if a>b then a:=a-b
+        end
+    end;
+begin
+    a:=42;
+    b:=30.0;
+    call gcd
+end." : CALL PARSEXAMPLE
+
+;;; The resulting parse tree is stored in the CAR,CDR,TYPES,STRING$ and NUMBER
+;;; arrays, the root of the tree being pointed to by RES.
diff --git a/small-cl-pgms/rdp/example-basic.lisp b/small-cl-pgms/rdp/example-basic.lisp
new file mode 100644
index 0000000..6223724
--- /dev/null
+++ b/small-cl-pgms/rdp/example-basic.lisp
@@ -0,0 +1,160 @@
+;;;; -*- mode:lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE:               example-basic.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    An example grammar for the recusive descent parser generator.
+;;;;    The actions are written in a pseudo basic
+;;;;    to generate a pseudo basic parser.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2011-07-19 <PJB> Updated regexps, now we use extended regexps.
+;;;;    2006-09-10 <PJB> Created.
+;;;;BUGS
+;;;;LEGAL
+;;;;    GPL
+;;;;
+;;;;    Copyright Pascal Bourguignon 2006 - 2011
+;;;;
+;;;;    This program is free software; you can redistribute it and/or
+;;;;    modify it under the terms of the GNU General Public License
+;;;;    as published by the Free Software Foundation; either version
+;;;;    2 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 General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU General Public
+;;;;    License along with this program; if not, write to the Free
+;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;;    Boston, MA 02111-1307 USA
+;;;;**************************************************************************
+
+
+(defpackage "COM.INFORMATIMAGO.RDP.BASIC.EXAMPLE"
+  (:use "COMMON-LISP" "COM.INFORMATIMAGO.RDP")
+  (:export "PARSE-EXAMPLE"))
+(in-package "COM.INFORMATIMAGO.RDP.BASIC.EXAMPLE")
+
+
+(defgrammar example
+    :target-language :basic
+    :terminals ((ident   "[A-Za-z][A-Za-z0-9]*")
+                ;; real must come first to match the longest first.
+                (real    "[-+]?[0-9]+.[0-9]+([Ee][-+]?[0-9]+)?")
+                (integer "[-+]?[0-9]+"))
+    :start program
+    :rules ((--> factor
+                 (alt ident
+                      number
+                      (seq "(" expression ")" :action "RES=A2"))
+                 :action "RES=A1")
+            (--> number  (alt integer real) :action "RES=A1")
+            (--> term
+                 factor (rep (alt "*" "/") factor)
+                 :action "NCAR=A1:NCDR=A2:CALL CONS")
+            (--> expression
+                 (opt (alt "+" "-"))
+                 term
+                 (rep (alt "+" "-") term
+                      :action
+                      "NCAR=A2:NCDR=NIL:CALL CONS"
+                      "NCAR=A1:NCDR=RES:CALL CONS")
+                 :action
+                 "IF A1<>0 THEN"
+                 "  NCAR=A2:NCDR=NIL:CALL CONS"
+                 "  NCAR=A1:NCDR=RES:CALL CONS"
+                 "  NCAR=RES"
+                 "ELSE"
+                 "  NCAR=A2"
+                 "ENDIF"
+                 "NCDR=A3:CALL CONS"
+                 "TMP=RES"
+                 "NSTRING$=\"+\":CALL MKSTR:NCAR=RES:NCDR=TMP:CALL CONS")
+            (--> condition
+                 (alt (seq "odd" expression
+                           :action
+                           "NCAR=A2:NCDR=NIL:CALL CONS:TMP=RES"
+                           "NSTRING$=\"ODD\":CALL MKSTR"
+                           "NCAR=RES:NCDR=TMP:CALL CONS")
+                      (seq expression
+                           (alt "=" "#" "<" "<=" ">" ">=")
+                           expression
+                           :action
+                           "NCAR=A3:NCDR=NIL:CALL CONS"
+                           "NCAR=A1:NCDR=RES:CALL CONS"
+                           "NCAR=A2:NCDR=RES:CALL CONS"))
+                 :action "RES=A1")
+            (--> statement
+                 (opt (alt (seq ident ":=" expression
+                                :action
+                                "NCAR=A3:NCDR=NIL:CALL CONS"
+                                "NCAR=A1:NCDR=RES:CALL CONS"
+                                "TMP=RES:NSTRING$=\"LET\":CALL MKSTR"
+                                "NCAR=RES:NCDR=TMP:CALL CONS")
+                           (seq "call" ident
+                                :action
+                                "NCAR=A2:NCDR=NIL:CALL CONS"
+                                "TMP=RES:NSTRING$=\"CALL\":CALL MKSTR"
+                                "NCAR=RES:NCDR=TMP:CALL CONS")
+                           (seq "begin" statement
+                                (rep ";" statement :action "RES=A2")
+                                "end"
+                                :action "NCAR=A2:NCDR=A3:CALL CONS")
+                           (seq "if" condition "then" statement
+                                :action
+                                "NCAR=A4:NCDR=NIL:CALL CONS"
+                                "NCAR=A2:NCDR=RES:CALL CONS"
+                                "TMP=RES:NSTRING$=\"IF\":CALL MKSTR"
+                                "NCAR=RES:NCDR=TMP:CALL CONS")
+                           (seq "while" condition "do" statement
+                                :action
+                                "NCAR=A4:NCDR=NIL:CALL CONS"
+                                "NCAR=A2:NCDR=RES:CALL CONS"
+                                "TMP=RES:NSTRING$=\"WHILE\":CALL MKSTR"
+                                "NCAR=RES:NCDR=TMP:CALL CONS")))
+                 :action "RES=A1")
+            (--> block
+                 (opt "const" ident "=" number
+                      (rep "," ident "=" number
+                           :action
+                           "NCAR=A4:NCDR=NIL:CALL CONS"
+                           "NCAR=A2:NCDR=RES:CALL CONS")
+                      ";"
+                      :action
+                      "NCAR=A4:NCDR=NIL:CALL CONS"
+                      "NCAR=A2:NCDR=RES:CALL CONS"
+                      "NCAR=RES:NCDR=A5:CALL CONS")
+                 (opt "var" ident
+                      (rep "," ident :action "RES=A2")
+                      ";"
+                      :action
+                      "NCAR=A3:NCDR=NIL:CALL CONS"
+                      "NCAR=A2:NCDR=RES:CALL CONS")
+                 (rep "procedure" ident ";" block ";"
+                      :action
+                      "NCAR=A4:NCDR=NIL:CALL CONS"
+                      "NCAR=A2:NCDR=RES:CALL CONS"
+                      "TMP=RES:NSTRING$=\"PROCEDURE\":CALL MKSTR"
+                      "NCAR=RES:NCDR=TMP:CALL CONS")
+                 statement
+                 :action
+                 "NCAR=A4:NCDR=NIL:CALL CONS"
+                 "NCAR=A3:NCDR=RES:CALL CONS"
+                 "NCAR=A2:NCDR=RES:CALL CONS"
+                 "NCAR=A1:NCDR=RES:CALL CONS"
+                 "TMP=RES:NSTRING$=\"BLOCK\":CALL MKSTR"
+                 "NCAR=RES:NCDR=TMP:CALL CONS")
+            (--> program
+                 block "." :action "RES=A1")))
+
+
+;;;; THE END ;;;;
+
diff --git a/small-cl-pgms/rdp/example-lisp-dribble.txt b/small-cl-pgms/rdp/example-lisp-dribble.txt
new file mode 100644
index 0000000..f03b189
--- /dev/null
+++ b/small-cl-pgms/rdp/example-lisp-dribble.txt
@@ -0,0 +1,418 @@
+;; Loading file /home/pjb/.clisprc.lisp ...
+;; Reading ASDF packages from /home/pjb/asdf-central-registry.data...
+; loading system definition from /usr/local/share/lisp/packages/net/sourceforge/cclan/asdf-install/asdf-install.asd into #<PACKAGE ASDF0>
+; registering #<SYSTEM ASDF-INSTALL #x2048F146> as ASDF-INSTALL
+0 errors, 0 warnings
+[1]> (setf *print-circle* nil)
+NIL
+
+;;; First we load the parser generator.
+
+[2]> (load"rdp.lisp")
+;; Loading file rdp.lisp ...
+;; Loaded file rdp.lisp
+T
+
+
+;;; Next, we load the grammar definition.
+;;; This will generate the scanner and parser for that language.
+
+[3]> (load"example-lisp.lisp")
+;; Loading file example-lisp.lisp ...
+;; Loaded file example-lisp.lisp
+T
+
+;;; Now we can parse a small example.
+
+[4]> (parse-example
+  "
+    const abc = 123,
+          pi=3.141592e+0;
+    var a,b,c;
+    procedure gcd;
+    begin
+        while a # b do
+        begin
+             if a<b then b:=b-a ;
+             if a>b then a:=a-b
+        end
+    end;
+begin
+    a:=42;
+    b:=30.0;
+    call gcd
+end.")
+(BLOCK
+ (((IDENT "abc" 11) (INTEGER "123" 17))
+  ((IDENT "pi" 32) (REAL "3.141592e+0" 35)))
+ ((IDENT "a" 57) (IDENT "b" 59) (IDENT "c" 61))
+ ((PROCEDURE (IDENT "gcd" 79)
+   (BLOCK NIL NIL NIL
+    ((WHILE (("#" "#" 112) (+ ((IDENT "a" 110))) (+ ((IDENT "b" 114))))
+      ((IF (("<" "<" 151) (+ ((IDENT "a" 150))) (+ ((IDENT "b" 152))))
+        (SETF (IDENT "b" 159)
+         (+ ((IDENT "b" 162)) (("-" "-" 163) ((IDENT "a" 164))))))
+       (IF ((">" ">" 186) (+ ((IDENT "a" 185))) (+ ((IDENT "b" 187))))
+        (SETF (IDENT "a" 194)
+         (+ ((IDENT "a" 197)) (("-" "-" 198) ((IDENT "b" 199))))))))))))
+ ((SETF (IDENT "a" 235) (+ ((INTEGER "42" 238))))
+  (SETF (IDENT "b" 246) (+ ((REAL "30.0" 249)))) (CALL (IDENT "gcd" 264))))
+
+;;; The integers in third position in the sublists are the positions
+;;; in the source of the corresponding token.
+
+
+;;; Let's dump the source of the generated scanner and parser:
+
+[5]> (pprint (macroexpand-1
+                (with-open-file (gram "example-lisp.lisp") (read gram))))
+
+(PROGN
+ (DEFSTRUCT SCANNER SOURCE FUNCTION (POSITION 0) (CURRENT-TOKEN NIL)
+  (CURRENT-TEXT "") (CURRENT-POSITION 0))
+ (DEFUN SCANNER-END-OF-SOURCE (SCANNER)
+  (<= (LENGTH (SCANNER-SOURCE SCANNER)) (SCANNER-POSITION SCANNER)))
+ (DEFUN ACCEPT (SCANNER TOKEN)
+  (IF (WORD-EQUAL TOKEN (SCANNER-CURRENT-TOKEN SCANNER))
+   (PROG1
+    (LIST (SCANNER-CURRENT-TOKEN SCANNER) (SCANNER-CURRENT-TEXT SCANNER)
+     (SCANNER-CURRENT-POSITION SCANNER))
+    (FUNCALL (SCANNER-FUNCTION SCANNER) SCANNER))
+   (ERROR "At position ~D, expected ~S, not ~S"
+    (SCANNER-CURRENT-POSITION SCANNER) TOKEN (SCANNER-CURRENT-TOKEN SCANNER))))
+ (DEFPARAMETER *SPACES* (FORMAT NIL "^[~{~C~}]\\+" '(#\  #\Newline #\Tab)))
+ (DEFUN SCAN-EXAMPLE (SCANNER)
+  (LET
+   ((MATCH
+     (REGEXP:MATCH *SPACES* (SCANNER-SOURCE SCANNER) :START
+      (SCANNER-POSITION SCANNER))))
+   (WHEN MATCH (SETF (SCANNER-POSITION SCANNER) (REGEXP:MATCH-END MATCH)))
+   (SETF (SCANNER-CURRENT-POSITION SCANNER) (SCANNER-POSITION SCANNER))
+   (COND
+    ((SCANNER-END-OF-SOURCE SCANNER)
+     (SETF (SCANNER-POSITION SCANNER) (LENGTH (SCANNER-SOURCE SCANNER))
+      (SCANNER-CURRENT-TEXT SCANNER) "<END OF SOURCE>"
+      (SCANNER-CURRENT-TOKEN SCANNER) NIL))
+    ((SETF MATCH
+      (REGEXP:MATCH
+       '"^\\(procedure\\>\\|begin\\>\\|while\\>\\|const\\>\\|call\\>\\|then\\>\\|odd\\>\\|end\\>\\|var\\>\\|<=\\|>=\\|:=\\|if\\>\\|do\\>\\|(\\|)\\|\\*\\|/\\|+\\|-\\|#\\|<\\|>\\|=\\|,\\|;\\|\\.\\)"
+       (SCANNER-SOURCE SCANNER) :START (SCANNER-POSITION SCANNER)))
+     (SETF (SCANNER-POSITION SCANNER) (REGEXP:MATCH-END MATCH)
+      (SCANNER-CURRENT-TEXT SCANNER)
+      (REGEXP:MATCH-STRING (SCANNER-SOURCE SCANNER) MATCH)
+      (SCANNER-CURRENT-TOKEN SCANNER) (SCANNER-CURRENT-TEXT SCANNER)))
+    ((SETF MATCH
+      (REGEXP:MATCH '"^\\([A-Za-z][A-Za-z0-9]*\\)" (SCANNER-SOURCE SCANNER)
+       :START (SCANNER-POSITION SCANNER)))
+     (SETF (SCANNER-POSITION SCANNER) (REGEXP:MATCH-END MATCH)
+      (SCANNER-CURRENT-TEXT SCANNER)
+      (REGEXP:MATCH-STRING (SCANNER-SOURCE SCANNER) MATCH)
+      (SCANNER-CURRENT-TOKEN SCANNER) 'IDENT))
+    ((SETF MATCH
+      (REGEXP:MATCH
+       '"^\\(^\\([-+]\\?[0-9]\\+\\.[0-9]\\+\\([Ee][-+]\\?[0-9]\\+\\)\\?\\)\\)"
+       (SCANNER-SOURCE SCANNER) :START (SCANNER-POSITION SCANNER)))
+     (SETF (SCANNER-POSITION SCANNER) (REGEXP:MATCH-END MATCH)
+      (SCANNER-CURRENT-TEXT SCANNER)
+      (REGEXP:MATCH-STRING (SCANNER-SOURCE SCANNER) MATCH)
+      (SCANNER-CURRENT-TOKEN SCANNER) 'REAL))
+    ((SETF MATCH
+      (REGEXP:MATCH '"^\\([-+]\\?[0-9]\\+\\)" (SCANNER-SOURCE SCANNER) :START
+       (SCANNER-POSITION SCANNER)))
+     (SETF (SCANNER-POSITION SCANNER) (REGEXP:MATCH-END MATCH)
+      (SCANNER-CURRENT-TEXT SCANNER)
+      (REGEXP:MATCH-STRING (SCANNER-SOURCE SCANNER) MATCH)
+      (SCANNER-CURRENT-TOKEN SCANNER) 'INTEGER))
+    (T
+     (ERROR "Invalid character ~C at position: ~D"
+      (AREF (SCANNER-SOURCE SCANNER) (SCANNER-POSITION SCANNER))
+      (SCANNER-POSITION SCANNER))))))
+ (DEFUN PARSE-PROGRAM (SCANNER)
+  (LET
+   (($1
+     (WHEN
+      (MEMBER (SCANNER-CURRENT-TOKEN SCANNER)
+       '(IDENT "call" "begin" "if" "while" "procedure" "var" "const") :TEST
+       #'WORD-EQUAL)
+      (PARSE-BLOCK SCANNER)))
+    ($2 (ACCEPT SCANNER '".")))
+   (LET (($0 (LIST $1 $2))) $1)))
+ (DEFUN PARSE-FACTOR (SCANNER)
+  (LET
+   (($1
+     (COND
+      ((WORD-EQUAL (SCANNER-CURRENT-TOKEN SCANNER) 'IDENT)
+       (ACCEPT SCANNER 'IDENT))
+      ((MEMBER (SCANNER-CURRENT-TOKEN SCANNER) '(INTEGER REAL) :TEST
+        #'WORD-EQUAL)
+       (IF
+        (MEMBER (SCANNER-CURRENT-TOKEN SCANNER) '(INTEGER REAL) :TEST
+         #'WORD-EQUAL)
+        (PARSE-NUMBER SCANNER)
+        (ERROR "Unexpected token ~S" (SCANNER-CURRENT-TOKEN SCANNER))))
+      ((WORD-EQUAL (SCANNER-CURRENT-TOKEN SCANNER) '"(")
+       (LET
+        (($1 (ACCEPT SCANNER '"("))
+         ($2
+          (IF
+           (MEMBER (SCANNER-CURRENT-TOKEN SCANNER)
+            '(IDENT INTEGER REAL "(" "+" "-") :TEST #'WORD-EQUAL)
+           (PARSE-EXPRESSION SCANNER)
+           (ERROR "Unexpected token ~S" (SCANNER-CURRENT-TOKEN SCANNER))))
+         ($3 (ACCEPT SCANNER '")")))
+        (LET (($0 (LIST $1 $2 $3))) $2))))))
+   (LET (($0 (LIST $1))) $1)))
+ (DEFUN PARSE-TERM (SCANNER)
+  (LET
+   (($1
+     (IF
+      (MEMBER (SCANNER-CURRENT-TOKEN SCANNER) '(IDENT INTEGER REAL "(") :TEST
+       #'WORD-EQUAL)
+      (PARSE-FACTOR SCANNER)
+      (ERROR "Unexpected token ~S" (SCANNER-CURRENT-TOKEN SCANNER))))
+    ($2
+     (LOOP :WHILE
+      (MEMBER (SCANNER-CURRENT-TOKEN SCANNER) '("*" "/") :TEST #'WORD-EQUAL)
+      :COLLECT
+      (LET
+       (($1
+         (COND
+          ((WORD-EQUAL (SCANNER-CURRENT-TOKEN SCANNER) '"*")
+           (ACCEPT SCANNER '"*"))
+          ((WORD-EQUAL (SCANNER-CURRENT-TOKEN SCANNER) '"/")
+           (ACCEPT SCANNER '"/"))))
+        ($2
+         (IF
+          (MEMBER (SCANNER-CURRENT-TOKEN SCANNER) '(IDENT INTEGER REAL "(")
+           :TEST #'WORD-EQUAL)
+          (PARSE-FACTOR SCANNER)
+          (ERROR "Unexpected token ~S" (SCANNER-CURRENT-TOKEN SCANNER)))))
+       (LET (($0 (LIST $1 $2))) $0)))))
+   (LET (($0 (LIST $1 $2))) `(,$1 . ,$2))))
+ (DEFUN PARSE-EXPRESSION (SCANNER)
+  (LET
+   (($1
+     (WHEN
+      (MEMBER (SCANNER-CURRENT-TOKEN SCANNER) '("+" "-") :TEST #'WORD-EQUAL)
+      (COND
+       ((WORD-EQUAL (SCANNER-CURRENT-TOKEN SCANNER) '"+") (ACCEPT SCANNER '"+"))
+       ((WORD-EQUAL (SCANNER-CURRENT-TOKEN SCANNER) '"-")
+        (ACCEPT SCANNER '"-")))))
+    ($2
+     (IF
+      (MEMBER (SCANNER-CURRENT-TOKEN SCANNER) '(IDENT INTEGER REAL "(") :TEST
+       #'WORD-EQUAL)
+      (PARSE-TERM SCANNER)
+      (ERROR "Unexpected token ~S" (SCANNER-CURRENT-TOKEN SCANNER))))
+    ($3
+     (LOOP :WHILE
+      (MEMBER (SCANNER-CURRENT-TOKEN SCANNER) '("+" "-") :TEST #'WORD-EQUAL)
+      :COLLECT
+      (LET
+       (($1
+         (COND
+          ((WORD-EQUAL (SCANNER-CURRENT-TOKEN SCANNER) '"+")
+           (ACCEPT SCANNER '"+"))
+          ((WORD-EQUAL (SCANNER-CURRENT-TOKEN SCANNER) '"-")
+           (ACCEPT SCANNER '"-"))))
+        ($2
+         (IF
+          (MEMBER (SCANNER-CURRENT-TOKEN SCANNER) '(IDENT INTEGER REAL "(")
+           :TEST #'WORD-EQUAL)
+          (PARSE-TERM SCANNER)
+          (ERROR "Unexpected token ~S" (SCANNER-CURRENT-TOKEN SCANNER)))))
+       (LET (($0 (LIST $1 $2))) `(,$1 ,$2))))))
+   (LET (($0 (LIST $1 $2 $3))) `(+ ,(IF $1 `(,$1 ,$2) $2) . ,$3))))
+ (DEFUN PARSE-CONDITION (SCANNER)
+  (LET
+   (($1
+     (COND
+      ((WORD-EQUAL (SCANNER-CURRENT-TOKEN SCANNER) '"odd")
+       (LET
+        (($1 (ACCEPT SCANNER '"odd"))
+         ($2
+          (IF
+           (MEMBER (SCANNER-CURRENT-TOKEN SCANNER)
+            '(IDENT INTEGER REAL "(" "+" "-") :TEST #'WORD-EQUAL)
+           (PARSE-EXPRESSION SCANNER)
+           (ERROR "Unexpected token ~S" (SCANNER-CURRENT-TOKEN SCANNER)))))
+        (LET (($0 (LIST $1 $2))) `(ODDP ,$2))))
+      ((MEMBER (SCANNER-CURRENT-TOKEN SCANNER) '(IDENT INTEGER REAL "(" "+" "-")
+        :TEST #'WORD-EQUAL)
+       (LET
+        (($1
+          (IF
+           (MEMBER (SCANNER-CURRENT-TOKEN SCANNER)
+            '(IDENT INTEGER REAL "(" "+" "-") :TEST #'WORD-EQUAL)
+           (PARSE-EXPRESSION SCANNER)
+           (ERROR "Unexpected token ~S" (SCANNER-CURRENT-TOKEN SCANNER))))
+         ($2
+          (COND
+           ((WORD-EQUAL (SCANNER-CURRENT-TOKEN SCANNER) '"=")
+            (ACCEPT SCANNER '"="))
+           ((WORD-EQUAL (SCANNER-CURRENT-TOKEN SCANNER) '"#")
+            (ACCEPT SCANNER '"#"))
+           ((WORD-EQUAL (SCANNER-CURRENT-TOKEN SCANNER) '"<")
+            (ACCEPT SCANNER '"<"))
+           ((WORD-EQUAL (SCANNER-CURRENT-TOKEN SCANNER) '"<=")
+            (ACCEPT SCANNER '"<="))
+           ((WORD-EQUAL (SCANNER-CURRENT-TOKEN SCANNER) '">")
+            (ACCEPT SCANNER '">"))
+           ((WORD-EQUAL (SCANNER-CURRENT-TOKEN SCANNER) '">=")
+            (ACCEPT SCANNER '">="))))
+         ($3
+          (IF
+           (MEMBER (SCANNER-CURRENT-TOKEN SCANNER)
+            '(IDENT INTEGER REAL "(" "+" "-") :TEST #'WORD-EQUAL)
+           (PARSE-EXPRESSION SCANNER)
+           (ERROR "Unexpected token ~S" (SCANNER-CURRENT-TOKEN SCANNER)))))
+        (LET (($0 (LIST $1 $2 $3))) `(,$2 ,$1 ,$3)))))))
+   (LET (($0 (LIST $1))) $1)))
+ (DEFUN PARSE-NUMBER (SCANNER)
+  (LET
+   (($1
+     (COND
+      ((WORD-EQUAL (SCANNER-CURRENT-TOKEN SCANNER) 'INTEGER)
+       (ACCEPT SCANNER 'INTEGER))
+      ((WORD-EQUAL (SCANNER-CURRENT-TOKEN SCANNER) 'REAL)
+       (ACCEPT SCANNER 'REAL)))))
+   (LET (($0 (LIST $1))) $1)))
+ (DEFUN PARSE-STATEMENT (SCANNER)
+  (LET
+   (($1
+     (WHEN
+      (MEMBER (SCANNER-CURRENT-TOKEN SCANNER)
+       '(IDENT "call" "begin" "if" "while") :TEST #'WORD-EQUAL)
+      (COND
+       ((WORD-EQUAL (SCANNER-CURRENT-TOKEN SCANNER) 'IDENT)
+        (LET
+         (($1 (ACCEPT SCANNER 'IDENT)) ($2 (ACCEPT SCANNER '":="))
+          ($3
+           (IF
+            (MEMBER (SCANNER-CURRENT-TOKEN SCANNER)
+             '(IDENT INTEGER REAL "(" "+" "-") :TEST #'WORD-EQUAL)
+            (PARSE-EXPRESSION SCANNER)
+            (ERROR "Unexpected token ~S" (SCANNER-CURRENT-TOKEN SCANNER)))))
+         (LET (($0 (LIST $1 $2 $3))) `(SETF ,$1 ,$3))))
+       ((WORD-EQUAL (SCANNER-CURRENT-TOKEN SCANNER) '"call")
+        (LET (($1 (ACCEPT SCANNER '"call")) ($2 (ACCEPT SCANNER 'IDENT)))
+         (LET (($0 (LIST $1 $2))) `(CALL ,$2))))
+       ((WORD-EQUAL (SCANNER-CURRENT-TOKEN SCANNER) '"begin")
+        (LET
+         (($1 (ACCEPT SCANNER '"begin"))
+          ($2
+           (WHEN
+            (MEMBER (SCANNER-CURRENT-TOKEN SCANNER)
+             '(IDENT "call" "begin" "if" "while") :TEST #'WORD-EQUAL)
+            (PARSE-STATEMENT SCANNER)))
+          ($3
+           (LOOP :WHILE (WORD-EQUAL (SCANNER-CURRENT-TOKEN SCANNER) '";")
+            :COLLECT
+            (LET
+             (($1 (ACCEPT SCANNER '";"))
+              ($2
+               (WHEN
+                (MEMBER (SCANNER-CURRENT-TOKEN SCANNER)
+                 '(IDENT "call" "begin" "if" "while") :TEST #'WORD-EQUAL)
+                (PARSE-STATEMENT SCANNER))))
+             (LET (($0 (LIST $1 $2))) $2))))
+          ($4 (ACCEPT SCANNER '"end")))
+         (LET (($0 (LIST $1 $2 $3 $4))) `(,$2 . ,$3))))
+       ((WORD-EQUAL (SCANNER-CURRENT-TOKEN SCANNER) '"if")
+        (LET
+         (($1 (ACCEPT SCANNER '"if"))
+          ($2
+           (IF
+            (MEMBER (SCANNER-CURRENT-TOKEN SCANNER)
+             '("odd" IDENT INTEGER REAL "(" "+" "-") :TEST #'WORD-EQUAL)
+            (PARSE-CONDITION SCANNER)
+            (ERROR "Unexpected token ~S" (SCANNER-CURRENT-TOKEN SCANNER))))
+          ($3 (ACCEPT SCANNER '"then"))
+          ($4
+           (WHEN
+            (MEMBER (SCANNER-CURRENT-TOKEN SCANNER)
+             '(IDENT "call" "begin" "if" "while") :TEST #'WORD-EQUAL)
+            (PARSE-STATEMENT SCANNER))))
+         (LET (($0 (LIST $1 $2 $3 $4))) `(IF ,$2 ,$4))))
+       ((WORD-EQUAL (SCANNER-CURRENT-TOKEN SCANNER) '"while")
+        (LET
+         (($1 (ACCEPT SCANNER '"while"))
+          ($2
+           (IF
+            (MEMBER (SCANNER-CURRENT-TOKEN SCANNER)
+             '("odd" IDENT INTEGER REAL "(" "+" "-") :TEST #'WORD-EQUAL)
+            (PARSE-CONDITION SCANNER)
+            (ERROR "Unexpected token ~S" (SCANNER-CURRENT-TOKEN SCANNER))))
+          ($3 (ACCEPT SCANNER '"do"))
+          ($4
+           (WHEN
+            (MEMBER (SCANNER-CURRENT-TOKEN SCANNER)
+             '(IDENT "call" "begin" "if" "while") :TEST #'WORD-EQUAL)
+            (PARSE-STATEMENT SCANNER))))
+         (LET (($0 (LIST $1 $2 $3 $4))) `(WHILE ,$2 ,$4))))))))
+   (LET (($0 (LIST $1))) $1)))
+ (DEFUN PARSE-BLOCK (SCANNER)
+  (LET
+   (($1
+     (WHEN (WORD-EQUAL (SCANNER-CURRENT-TOKEN SCANNER) '"const")
+      (LET
+       (($1 (ACCEPT SCANNER '"const")) ($2 (ACCEPT SCANNER 'IDENT))
+        ($3 (ACCEPT SCANNER '"="))
+        ($4
+         (IF
+          (MEMBER (SCANNER-CURRENT-TOKEN SCANNER) '(INTEGER REAL) :TEST
+           #'WORD-EQUAL)
+          (PARSE-NUMBER SCANNER)
+          (ERROR "Unexpected token ~S" (SCANNER-CURRENT-TOKEN SCANNER))))
+        ($5
+         (LOOP :WHILE (WORD-EQUAL (SCANNER-CURRENT-TOKEN SCANNER) '",") :COLLECT
+          (LET
+           (($1 (ACCEPT SCANNER '",")) ($2 (ACCEPT SCANNER 'IDENT))
+            ($3 (ACCEPT SCANNER '"="))
+            ($4
+             (IF
+              (MEMBER (SCANNER-CURRENT-TOKEN SCANNER) '(INTEGER REAL) :TEST
+               #'WORD-EQUAL)
+              (PARSE-NUMBER SCANNER)
+              (ERROR "Unexpected token ~S" (SCANNER-CURRENT-TOKEN SCANNER)))))
+           (LET (($0 (LIST $1 $2 $3 $4))) `(,$2 ,$4)))))
+        ($6 (ACCEPT SCANNER '";")))
+       (LET (($0 (LIST $1 $2 $3 $4 $5 $6))) `((,$2 ,$4) . ,$5)))))
+    ($2
+     (WHEN (WORD-EQUAL (SCANNER-CURRENT-TOKEN SCANNER) '"var")
+      (LET
+       (($1 (ACCEPT SCANNER '"var")) ($2 (ACCEPT SCANNER 'IDENT))
+        ($3
+         (LOOP :WHILE (WORD-EQUAL (SCANNER-CURRENT-TOKEN SCANNER) '",") :COLLECT
+          (LET (($1 (ACCEPT SCANNER '",")) ($2 (ACCEPT SCANNER 'IDENT)))
+           (LET (($0 (LIST $1 $2))) $2))))
+        ($4 (ACCEPT SCANNER '";")))
+       (LET (($0 (LIST $1 $2 $3 $4))) `(,$2 . ,$3)))))
+    ($3
+     (LOOP :WHILE (WORD-EQUAL (SCANNER-CURRENT-TOKEN SCANNER) '"procedure")
+      :COLLECT
+      (LET
+       (($1 (ACCEPT SCANNER '"procedure")) ($2 (ACCEPT SCANNER 'IDENT))
+        ($3 (ACCEPT SCANNER '";"))
+        ($4
+         (WHEN
+          (MEMBER (SCANNER-CURRENT-TOKEN SCANNER)
+           '(IDENT "call" "begin" "if" "while" "procedure" "var" "const") :TEST
+           #'WORD-EQUAL)
+          (PARSE-BLOCK SCANNER)))
+        ($5 (ACCEPT SCANNER '";")))
+       (LET (($0 (LIST $1 $2 $3 $4 $5))) `(PROCEDURE ,$2 ,$4)))))
+    ($4
+     (WHEN
+      (MEMBER (SCANNER-CURRENT-TOKEN SCANNER)
+       '(IDENT "call" "begin" "if" "while") :TEST #'WORD-EQUAL)
+      (PARSE-STATEMENT SCANNER))))
+   (LET (($0 (LIST $1 $2 $3 $4))) `(BLOCK ,$1 ,$2 ,$3 ,$4))))
+ (DEFUN PARSE-EXAMPLE (SOURCE)
+  (LET ((SCANNER (MAKE-SCANNER :SOURCE SOURCE :FUNCTION #'SCAN-EXAMPLE)))
+   (SCAN-EXAMPLE SCANNER)
+   (PROG1 (PARSE-PROGRAM SCANNER)
+    (UNLESS (SCANNER-END-OF-SOURCE SCANNER)
+     (ERROR "End of source NOT reached."))))))
+
+[6]>
diff --git a/small-cl-pgms/rdp/example-lisp.lisp b/small-cl-pgms/rdp/example-lisp.lisp
new file mode 100644
index 0000000..ed6a5d2
--- /dev/null
+++ b/small-cl-pgms/rdp/example-lisp.lisp
@@ -0,0 +1,202 @@
+;;;; -*- mode:lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE:               example-lisp.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    An example grammar for the recusive descent parser generator.
+;;;;    The actions are written in Lisp, to generate a lisp parser.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2011-07-19 <PJB> Updated regexps, now we use extended regexps.
+;;;;    2011-07-19 <PJB> Added defpackage forms.  Added parsing example sources.
+;;;;    2006-09-10 <PJB> Created.
+;;;;BUGS
+;;;;LEGAL
+;;;;    GPL
+;;;;
+;;;;    Copyright Pascal Bourguignon 2006 - 2006
+;;;;
+;;;;    This program is free software; you can redistribute it and/or
+;;;;    modify it under the terms of the GNU General Public License
+;;;;    as published by the Free Software Foundation; either version
+;;;;    2 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 General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU General Public
+;;;;    License along with this program; if not, write to the Free
+;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;;    Boston, MA 02111-1307 USA
+;;;;**************************************************************************
+
+
+(defpackage "COM.INFORMATIMAGO.RDP.EXAMPLE"
+  (:use "COMMON-LISP" "COM.INFORMATIMAGO.RDP")
+  (:export "PARSE-EXAMPLE"))
+(in-package "COM.INFORMATIMAGO.RDP.EXAMPLE")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Example Language
+;;; taken from: http://en.wikipedia.org/wiki/Recursive_descent_parser
+;;;
+
+(defgrammar example
+    :terminals ((ident   "[A-Za-z][A-Za-z0-9]*")
+                ;; real must come first to match the longest first.
+                (real    "[-+]?[0-9]+\\.[0-9]+([Ee][-+]?[0-9]+)?")
+                (integer "[-+]?[0-9]+"))
+    :start program
+    :rules ((--> factor
+                 (alt ident
+                      number
+                      (seq "(" expression ")" :action $2))
+                 :action $1)
+            (--> number  (alt integer real) :action $1)
+            (--> term
+                 factor (rep (alt "*" "/") factor)
+                 :action `(,$1 . ,$2))
+            (--> expression
+                 (opt (alt "+" "-"))
+                 term
+                 (rep (alt "+" "-") term :action `(,$1 ,$2))
+                 :action `(+ ,(if $1 `(,$1 ,$2) $2)  . ,$3))
+            (--> condition
+                 (alt (seq "odd" expression
+                           :action `(oddp ,$2))
+                      (seq expression
+                           (alt "=" "#" "<" "<=" ">" ">=")
+                           expression
+                           :action `(,$2 ,$1 ,$3)))
+                 :action $1)
+            (--> statement
+                 (opt (alt (seq ident ":=" expression
+                                :action `(setf ,$1 ,$3))
+                           (seq "call" ident
+                                :action `(call ,$2))
+                           (seq "begin" statement
+                                (rep ";" statement
+                                     :action $2)
+                                "end"
+                                :action `(,$2 . ,$3))
+                           (seq "if" condition "then" statement
+                                :action `(if ,$2 ,$4))
+                           (seq "while" condition "do" statement
+                                :action `(while ,$2 ,$4))))
+                 :action $1)
+            (--> block
+                 (opt "const" ident "=" number
+                      (rep "," ident "=" number
+                           :action `(,$2 ,$4))
+                      ";"
+                      :action `((,$2 ,$4) . ,$5))
+                 (opt "var" ident
+                      (rep "," ident :action $2)
+                      ";"
+                      :action `(,$2 . ,$3))
+                 (rep "procedure" ident ";" block ";"
+                      :action `(procedure ,$2 ,$4))
+                 statement
+                 :action `(block ,$1 ,$2 ,$3 ,$4))
+            (--> program
+                 block "." :action $1)))
+
+
+
+(assert (equal (COM.INFORMATIMAGO.RDP.EXAMPLE:PARSE-EXAMPLE
+                "
+    const abc = 123,
+          pi=3.141592e+0;
+    var a,b,c;
+    procedure gcd;
+    begin
+        while a # b do
+        begin
+             if a<b then b:=b-a ;
+             if a>b then a:=a-b
+        end
+    end;
+begin
+    a:=42;
+    b:=30.0;
+    call gcd
+end.")
+               '(BLOCK (((IDENT "abc" 11) (INTEGER "123" 17)) ((IDENT "pi" 32) (REAL "3.141592e+0" 35))) ((IDENT "a" 57) (IDENT "b" 59) (IDENT "c" 61)) ((PROCEDURE (IDENT "gcd" 79) (BLOCK NIL NIL NIL ((WHILE (("#" "#" 112) (+ ((IDENT "a" 110))) (+ ((IDENT "b" 114)))) ((IF (("<" "<" 151) (+ ((IDENT "a" 150))) (+ ((IDENT "b" 152)))) (SETF (IDENT "b" 159) (+ ((IDENT "b" 162)) (("-" "-" 163) ((IDENT "a" 164)))))) (IF ((">" ">" 186) (+ ((IDENT "a" 185))) (+ ((IDENT "b" 187)))) (SETF (IDENT "a" 194) (+ ((IDENT "a" 197)) (("-" "-" 198) ((IDENT "b" 199)))))))))))) ((SETF (IDENT "a" 235) (+ ((INTEGER "42" 238)))) (SETF (IDENT "b" 246) (+ ((REAL "30.0" 249)))) (CALL (IDENT "gcd" 264))))))
+
+
+
+(defpackage "COM.INFORMATIMAGO.RDP.EXAMPLE-WITHOUT-ACTION"
+  (:use "COMMON-LISP" "COM.INFORMATIMAGO.RDP")
+  (:export "PARSE-EXAMPLE-WITHOUT-ACTION"))
+(in-package "COM.INFORMATIMAGO.RDP.EXAMPLE-WITHOUT-ACTION")
+
+(defgrammar example-without-action
+    :terminals ((ident   "[A-Za-z][A-Za-z0-9]*")
+                ;; real must come first to match the longest first.
+                (real    "[-+]?[0-9]+\\.[0-9]+([Ee][-+]?[0-9]+)?")
+                (integer "[-+]?[0-9]+"))
+    :start program
+    :rules ((--> factor
+                 (alt ident
+                      number
+                      (seq "(" expression ")")))
+            (--> number  (alt integer real))
+            (--> term
+                 factor (rep (alt "*" "/") factor))
+            (--> expression
+                 (opt (alt "+" "-"))
+                 term
+                 (rep (alt "+" "-") term))
+            (--> condition
+                 (alt (seq "odd" expression)
+                      (seq expression
+                           (alt "=" "#" "<" "<=" ">" ">=")
+                           expression)))
+            (--> statement
+                 (opt (alt (seq ident ":=" expression)
+                           (seq "call" ident)
+                           (seq "begin" statement
+                                (rep ";" statement)
+                                "end")
+                           (seq "if" condition "then" statement)
+                           (seq "while" condition "do" statement))))
+            (--> block
+                 (opt "const" ident "=" number
+                      (rep "," ident "=" number) ";")
+                 (opt "var" ident (rep "," ident) ";")
+                 (rep "procedure" ident ";" block ";")
+                 statement)
+            (--> program
+                 block ".")))
+
+
+(assert (equal (COM.INFORMATIMAGO.RDP.EXAMPLE-WITHOUT-ACTION:PARSE-EXAMPLE-WITHOUT-ACTION
+                "
+    const abc = 123,
+          pi=3.141592e+0;
+    var a,b,c;
+    procedure gcd;
+    begin
+        while a # b do
+        begin
+             if a<b then b:=b-a ;
+             if a>b then a:=a-b
+        end
+    end;
+begin
+    a:=42;
+    b:=30.0;
+    call gcd
+end.")
+               '(PROGRAM (BLOCK (("const" "const" 5) (IDENT "abc" 11) ("=" "=" 15) (NUMBER (INTEGER "123" 17)) ((("," "," 20) (IDENT "pi" 32) ("=" "=" 34) (NUMBER (REAL "3.141592e+0" 35)))) (";" ";" 46)) (("var" "var" 53) (IDENT "a" 57) ((("," "," 58) (IDENT "b" 59)) (("," "," 60) (IDENT "c" 61))) (";" ";" 62)) ((("procedure" "procedure" 69) (IDENT "gcd" 79) (";" ";" 82) (BLOCK NIL NIL NIL (STATEMENT (("begin" "begin" 89) (STATEMENT (("while" "while" 104) (CONDITION ((EXPRESSION NIL (TERM (FACTOR (IDENT "a" 110)) NIL) NIL) ("#" "#" 112) (EXPRESSION NIL (TERM (FACTOR (IDENT "b" 114)) NIL) NIL))) ("do" "do" 116) (STATEMENT (("begin" "begin" 128) (STATEMENT (("if" "if" 147) (CONDITION ((EXPRESSION NIL (TERM (FACTOR (IDENT "a" 150)) NIL) NIL) ("<" "<" 151) (EXPRESSION NIL (TERM (FACTOR (IDENT "b" 152)) NIL) NIL))) ("then" "then" 154) (STATEMENT ((IDENT "b" 159) (":=" ":=" 160) (EXPRESSION NIL (TERM (FACTOR (IDENT "b" 162)) NIL) ((("-" "-" 163) (TERM (FACTOR (IDENT "a" 164)) NIL)))))))) (((";" ";" 166) (STATEMENT (("if" "if" 182) (CONDITION ((EXPRESSION NIL (TERM (FACTOR (IDENT "a" 185)) NIL) NIL) (">" ">" 186) (EXPRESSION NIL (TERM (FACTOR (IDENT "b" 187)) NIL) NIL))) ("then" "then" 189) (STATEMENT ((IDENT "a" 194) (":=" ":=" 195) (EXPRESSION NIL (TERM (FACTOR (IDENT "a" 197)) NIL) ((("-" "-" 198) (TERM (FACTOR (IDENT "b" 199)) NIL)))))))))) ("end" "end" 210))))) NIL ("end" "end" 219)))) (";" ";" 222))) (STATEMENT (("begin" "begin" 224) (STATEMENT ((IDENT "a" 235) (":=" ":=" 236) (EXPRESSION NIL (TERM (FACTOR (NUMBER (INTEGER "42" 238))) NIL) NIL))) (((";" ";" 240) (STATEMENT ((IDENT "b" 246) (":=" ":=" 247) (EXPRESSION NIL (TERM (FACTOR (NUMBER (REAL "30.0" 249))) NIL) NIL)))) ((";" ";" 253) (STATEMENT (("call" "call" 259) (IDENT "gcd" 264))))) ("end" "end" 268)))) ("." "." 271))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; THE END ;;;;
diff --git a/small-cl-pgms/rdp/index.html b/small-cl-pgms/rdp/index.html
new file mode 100644
index 0000000..855c0ce
--- /dev/null
+++ b/small-cl-pgms/rdp/index.html
@@ -0,0 +1,70 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Strict//EN" "http://www.w3.org/TR/html4/strict.dtd">
+
+<HTML>
+  <HEAD>
+    <link rel="icon"          href="/favicon.ico" type="image/x-icon">
+    <link rel="shortcut icon" href="/favicon.ico" type="image/x-icon">
+    <link rel="stylesheet"    href="/default.css" type="text/css">
+    <TITLE>A Quick and Dirty Recursive Descent Parser Generator</TITLE>
+    <META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=iso-8859-1">
+    <META NAME="author" CONTENT="Pascal J. Bourguignon">
+    <META HTTP-EQUIV="Description" NAME="description"
+          CONTENT="Pascal Bourguignon Web Page">
+    <META NAME="keywords"
+          CONTENT="Recursive Descent Parser Generator,lisp,common lisp, basic">
+   </HEAD>
+  <BODY>
+<!--TOP-BEGIN-->
+<!-- This section is automatically generated by html-update, -->
+<!-- from data in 'node.el'.    Please, do not edit it here. -->
+<!--TOP-END-->
+<!--MENU-BEGIN-->
+<!-- This section is automatically generated by html-update, -->
+<!-- from data in 'node.el'.    Please, do not edit it here. -->
+<!--MENU-END-->
+
+
+    <H1>A Quick and Dirty Recursive Descent Parser Generator</H1>
+
+    <P>Here is a recursive descent parser generator, written in
+       <a href="http://www.cliki.net/">Common Lisp</a>.</p>
+
+    <P>It generates the scanner and parser in lisp, or in a pseudo-basic.
+       It is possible to add generation of the parser in other programming
+       languages.
+    </p>
+
+    <p>Files:
+    <ul>
+      <li>the <a href="rdp.lisp">sources of the parser generator</a></li>
+      <li>an <a href="example-lisp.lisp">example grammar with actions
+            to generate a lisp parser</a></li>
+      <li>an <a href="example-lisp-dribble.txt">example of the output of generator: a lisp recursive descent parser</a></li>
+      <br>
+      <li>the <a href="rdp-basic-gen.lisp">basic code generator</a></li>
+      <li>an <a href="example-basic.lisp">example grammar with actions
+            to generate a (pseudo) basic parser</a></li>
+      <li>an <a href="example-basic-dribble.txt">example of the output of generator: a (pseudo)basic recursive descent parser</a></li>
+      <li><a href="com.informatimago.rdp.asd">ASDF file com.informatimago.rdp.asd</a> for the rdp.lisp library.</li>
+      <li><a href="com.informatimago.rdp.example.asd">ASDF file com.informatimago.rdp.example.asd</a> for the Lisp generator example.</li>
+      <li><a href="com.informatimago.rdp.basic.asd">ASDF file com.informatimago.rdp.basic.asd</a> for the BASIC generator.</li>
+      <li><a href="com.informatimago.rdp.basic.example.asd">ASDF file com.informatimago.rdp.basic.example.asd</a> for the BASIC generator example.</li>
+      </ul></p>
+
+    <p>Note you can also get the sources from gitorious:
+<pre>
+    git clone https://git.gitorious.org/com-informatimago/com-informatimago-rdp.git com.informatimago.rdp
+</pre>
+
+
+
+<!--MENU-BEGIN-->
+<!-- This section is automatically generated by html-update, -->
+<!-- from data in 'node.el'.    Please, do not edit it here. -->
+<!--MENU-END-->
+<!--BOTTOM-BEGIN-->
+<!-- This section is automatically generated by html-update, -->
+<!-- from data in 'node.el'.    Please, do not edit it here. -->
+<!--BOTTOM-END-->
+  </BODY>
+</HTML>
diff --git a/small-cl-pgms/rdp/movie-shell.lisp b/small-cl-pgms/rdp/movie-shell.lisp
new file mode 100644
index 0000000..7bcca39
--- /dev/null
+++ b/small-cl-pgms/rdp/movie-shell.lisp
@@ -0,0 +1,132 @@
+;;;; -*- mode:lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE:               movie-shell.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    A silly little shell, taking commands like in Tron.
+;;;;    The commands are parsed with a recursive descent grammar,
+;;;;    the parser being generated by com.informatimago.rdp.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2011-07-19 <PJB> Created.
+;;;;BUGS
+;;;;LEGAL
+;;;;    GPL
+;;;;
+;;;;    Copyright Pascal J. Bourguignon 2011 - 2011
+;;;;
+;;;;    This program is free software; you can redistribute it and/or
+;;;;    modify it under the terms of the GNU General Public License
+;;;;    as published by the Free Software Foundation; either version
+;;;;    2 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 General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU General Public
+;;;;    License along with this program; if not, write to the Free
+;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;;    Boston, MA 02111-1307 USA
+;;;;**************************************************************************
+
+(ql:quickload :com.informatimago.rdp)
+(use-package  :com.informatimago.rdp)
+
+
+(defvar *password* '("0" . "NONE"))
+
+(defun sh-code-password-to-memory (ident address)
+  (setf *password* (cons address ident))
+  (format t "~&PASSWORD STORED TO MEMORY ~A~%" address))
+
+(defun sh-request-access-to (&key program database)
+  (format t "~&ACCESS TO ~:[PROGRAM~;DATABASE~] ~A IS ~:[REJECTED~;GRANTED~]~%"
+          database (or program database)  (string= (cdr *PASSWORD*) "GOLDFINGER")))
+
+(defun sh-status-report-on (&rest what)
+  (format t "~&~{~A~^ ~} STATUS IS OK~%" what))
+
+(defun sh-quit ()
+  (format t "~&GOOD BYE, M. DILLIGER.~%")
+  (throw 'gazongues nil))
+
+
+(defgrammar movie-shell
+    :terminals ((ident   "[A-Za-z][A-Za-z0-9]*")
+                (address "[0-9][0-9A-F]*"))
+    :start command
+    :rules ((--> command (alt request code quit) :action (values))
+            (--> request
+                 "REQUEST"
+                 (alt (seq "ACCESS" "TO" ident (alt "PROGRAM" "DATABASE")
+                           :action (sh-request-access-to
+                                    (intern (second $4) "KEYWORD") (second $3)))
+                      (seq "STATUS" "REPORT" "ON" "MISSING" "DATA"
+                           :action (sh-status-report-on (second $4) (second $5)))))
+            (--> code
+                 "CODE" ident "TO" "MEMORY" address
+                 :action (sh-code-password-to-memory (second $2) (second $5)))
+            (--> quit
+                 "QUIT"
+                 :action (sh-quit))))
+
+(defun movie-shell ()
+  (catch 'gazongues
+    (loop
+       :for command = (progn (format *query-io* "~%> ")
+                             (finish-output *query-io*)
+                             (clear-input *query-io*)
+                             (read-line *query-io*))
+       :do (progn
+             (handler-case (parse-movie-shell (string-upcase command))
+               (error (err)
+                 (format t "~&~A~%" err)))
+             (finish-output))))
+  (finish-output)
+  (values))
+
+
+;; CL-USER> (movie-shell)
+;;
+;; > request access to secret program
+;;
+;; ACCESS TO PROGRAM SECRET IS GRANTED
+;;
+;; > code zero to memory 42
+;;
+;; PASSWORD STORED TO MEMORY 42
+;;
+;; > request access to secret program
+;;
+;; ACCESS TO PROGRAM SECRET IS REJECTED
+;;
+;; > request access to big database
+;;
+;; ACCESS TO DATABASE BIG IS REJECTED
+;;
+;; > code goldfinger to memory 42
+;;
+;; PASSWORD STORED TO MEMORY 42
+;;
+;; > request access to big database
+;;
+;; ACCESS TO DATABASE BIG IS GRANTED
+;;
+;; > request status report on missing data
+;;
+;; MISSING DATA STATUS IS OK
+;;
+;; > quit
+;;
+;; GOOD BYE, M. DILLIGER.
+;; ; No value
+;; CL-USER>
+
+;;;; THE END ;;;;
diff --git a/small-cl-pgms/rdp/rdp-basic-gen.lisp b/small-cl-pgms/rdp/rdp-basic-gen.lisp
new file mode 100644
index 0000000..26a7be8
--- /dev/null
+++ b/small-cl-pgms/rdp/rdp-basic-gen.lisp
@@ -0,0 +1,284 @@
+;;;; -*- mode:lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE:               rdp-basic-gen.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    A (pseudo) basic generator for the recusive descent parser generator.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2011-07-19 <PJB> Updated for new rdp.
+;;;;    2006-09-10 <PJB> Created.
+;;;;BUGS
+;;;;LEGAL
+;;;;    GPL
+;;;;
+;;;;    Copyright Pascal Bourguignon 2006 - 2006
+;;;;
+;;;;    This program is free software; you can redistribute it and/or
+;;;;    modify it under the terms of the GNU General Public License
+;;;;    as published by the Free Software Foundation; either version
+;;;;    2 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 General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU General Public
+;;;;    License along with this program; if not, write to the Free
+;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;;    Boston, MA 02111-1307 USA
+;;;;**************************************************************************
+
+(in-package "COM.INFORMATIMAGO.RDP")
+
+
+(defparameter *linenum* 0)
+
+(defun emit (fctrl &rest args)
+  (format t "~&~4D " (incf *linenum* 10))
+  (apply (function format) t fctrl args))
+
+
+(defmethod generate-boilerplate ((target (eql :basic)) grammar)
+  `(progn
+    (emit "SCANSRC$=\"\" : SCANFUN$=\"\" : SCANPOS=0")
+    (emit "CURTOK$=\"\"  : CURTXT$=\"\"  : CURPOS=0")
+    (emit "SPACES$=" "+CHR$(10)+CHR$(13)+CHR$(9)")
+    (emit "DEF SCANEOF : IF LEN(SCANSRC$)<=SCANPOS THEN RETURN 1 ELSE RETURN 0 : ENDFUN")
+    (emit "SUB ACCEPT")
+    (emit "  IF TOKEN$ <> CURTOK$ THEN")
+    (emit "     PRINT \"ERROR: AT POSITION\",CURPOS,\"EXPECTED \",TOKEN$,\" NOT \",CURTOK$")
+    (emit "     STOP")
+    (emit "  ELSE")
+    (emit "     ACCEPTOK$=CURTOK$:ACCEPTXT$=CURTXT$:ACCEPPOS$=CURPOS$")
+    (emit "     CALL SCANFUN$")
+    (emit "  ENDIF")
+    (emit "ENDSUB")
+    (emit "MAXCONS=100000")
+    (emit "NIL=0:CONS=1:STRING=2:NUMBER=3")
+    (emit "TYPELABEL$[NIL]=\"NIL\"")
+    (emit "TYPELABEL$[CONS]=\"CONS\"")
+    (emit "TYPELABEL$[STRING]=\"STRING\"")
+    (emit "TYPELABEL$[NUMBER]=\"NUMBER\"")
+    (emit "DIM TYPES[MAXCONS],CAR[MAXCONS],CDR[MAXCONS],STRINGS$[MAXCONS],NUMBERS[MAXCONS]")
+    (emit "TYPES[NIL]=NIL:CAR[NIL]=NIL:CDR[NIL]=NIL:STRINGS$[NIL]=\"NIL\":NUMBERS[NIL]=0")
+    (emit "FREE=MAXCONS")
+    (emit "SUB CONS")
+    (emit "  IF FREE<=1 THEN PRINT \"ERROR: OUT OF CONS SPACE\" : STOP : ENDIF")
+    (emit "  FREE=FREE-1")
+    (emit "  TYPES[FREE]=CONS")
+    (emit "  CAR[FREE]=NCAR")
+    (emit "  CDR[FREE]=NCDR")
+    (emit "  RES=FREE")
+    (emit "ENDSUB")
+    (emit "SUB MKSTR")
+    (emit "  IF FREE<=1 THEN PRINT \"ERROR: OUT OF CONS SPACE\" : STOP : ENDIF")
+    (emit "  FREE=FREE-1")
+    (emit "  TYPES[FREE]=STRING")
+    (emit "  STRING$[FREE]=NSTRING$")
+    (emit "  RES=FREE")
+    (emit "ENDSUB")
+    (emit "SUB MKNUM")
+    (emit "  IF FREE<=1 THEN PRINT \"ERROR: OUT OF CONS SPACE\" : STOP : ENDIF")
+    (emit "  FREE=FREE-1")
+    (emit "  TYPES[FREE]=NUMBER")
+    (emit "  NUMBER[FREE]=NNUMBER")
+    (emit "  RES=FREE")
+    (emit "ENDSUB")
+    (emit "SUB REVERSE")
+    (emit "  REV=0:TREV=NIL")
+    (emit "  WHILE LIST<>0")
+    (emit "   IF TYPES[LIST]<>CONS THEN")
+    (emit "      PRINT \"ERROR: REVERSE EXPECTS A LIST, NOT A \",TYPELABEL$[TYPES[LIST]]")
+    (emit "      STOP")
+    (emit "    ELSE")
+    (emit "      NEW=CDR[LIST]")
+    (emit "      CDR[LIST]=REV:TYPES[LIST]=TREV")
+    (emit "      REV=LIST:TREV=CONS")
+    (emit "      LIST=NEW")
+    (emit "    ENDIF")
+    (emit "  ENDWHILE")
+    (emit "  RES=REV")
+    (emit "ENDSUB")))
+
+
+(defmethod gen-scanner-function-name ((target (eql :basic)) grammar-name)
+   (format nil "SCAN~A" grammar-name))
+
+
+(defmethod generate-scanner ((target (eql :basic)) grammar)
+  (let* ((an-terminals  (sort (remove-if-not
+                               (lambda (item)
+                                 (and (stringp item)
+                                      (alphanumericp (aref item (1- (length item))))))
+                               (grammar-all-terminals grammar))
+                              (function >) :key (function length)))
+         (nan-terminals (sort (remove-if
+                               (lambda (item)
+                                 (or (not (stringp item))
+                                     (alphanumericp (aref item (1- (length item))))))
+                               (grammar-all-terminals grammar))
+                              (function >) :key (function length)))
+         (nl-terminals (remove-if (function stringp) (grammar-terminals grammar)))
+         (lit-an-terminals-regexp
+          (format nil "^(~{~A~^|~})([^A-Za-z0-9]|$)"
+                  (mapcar (function regexp-quote-extended) an-terminals)))
+         (lit-nan-terminals-regexp
+          (format nil "^(~{~A~^|~})"
+                  (mapcar (function regexp-quote-extended)  nan-terminals))))
+    `(progn
+       (emit "SUB ~A" ',(gen-scanner-function-name target (grammar-name grammar)))
+       (emit "  WHILE POS(SCANSRC$[SCANPOS],SPACES$)>0 : SCANPOS=SCANPOS+1 : ENDWHILE")
+       (emit "  CURPOS=SCANPOS")
+       (emit "  IF SCANEOF<>0 THEN")
+       (emit "    SCANPOS=LEN(SCANSRC$)")
+       (emit "    SCANTXT$=\"<END OF SOURCE>\"")
+       (emit "    SCANTOK$=\"\"")
+       (emit "  ELSE")
+       (emit "    REM *** ASSUMING THERE IS SOME WAY TO MATCH REGEXPS IN BASIC...")
+       (when an-terminals
+         (emit "    MATCHREGEXP  \"~A\" SCANSRC$,SCANPOS INTO START,END" ',lit-an-terminals-regexp)
+         (emit "    IF START>0 THEN")
+         (emit "      SCANPOS=END")
+         (emit "      SCANTXT$=MID$(SCANSRC$,START,END-1)")
+         (emit "      SCANTOK$=SCANTXT$")
+         (emit "    ELSE"))
+       (when nan-terminals
+         (emit "      MATCHREGEXP  \"~A\" SCANSRC$,SCANPOS INTO START,END" ',lit-nan-terminals-regexp)
+         (emit "      IF START>0 THEN")
+         (emit "        SCANPOS=END")
+         (emit "        SCANTXT$=MID$(SCANSRC$,START,END)")
+         (emit "        SCANTOK$=SCANTXT$")
+         (emit "      ELSE"))
+       ,@(labels ((gen (terminals)
+                       (if (null terminals)
+                           `( (emit "       PRINT \"ERROR: AT POSITION\",CURPOS,\"EXPECTED \",TOKEN$,\" NOT \",CURTOK$")
+                              (emit "       STOP"))
+                           (let ((terminal (car terminals)))
+                             `(
+                               (emit "   MATCHREGEXP \"^(~A)\" SCANSRC$,SCANPOS INTO START,END" ',(second terminal))
+                               (emit "   IF START>0 THEN")
+                               (emit "        SCANPOS=END")
+                               (emit "        SCANTXT$=MID$(SCANSRC$,START,END)")
+                               (emit "        SCANTOK$=\"~A\"" ',(first terminal))
+                               (emit "   ELSE")
+                               ,@(gen (cdr terminals))
+                               (emit "   ENDIF"))))))
+                 (gen  (grammar-terminals grammar)))
+       (when nan-terminals (emit "      ENDIF"))
+       (when an-terminals  (emit "    ENDIF"))
+       (emit "  ENDIF")
+       (emit "ENDSUB"))))
+
+
+(defmethod gen-parse-function-name ((target (eql :basic)) grammar non-terminal)
+   (format nil "PARSE~A" non-terminal))
+
+(defmethod gen-in-firsts ((target (eql :basic)) firsts)
+  (format nil "(~{CURTOK$=\"~A\"~^ OR ~})"  firsts))
+
+
+(defparameter *lex* 0)
+
+(defmethod gen-parsing-statement ((target (eql :basic)) grammar item)
+  (if (atom item)
+      (if (terminalp grammar item)
+          `(emit "TOKEN$=~S : CALL ACCEPT" ',(string item))
+          (let* ((firsts (first-rhs grammar item))
+                 (emptyp (member nil firsts)))
+            `(progn
+               (emit "IF ~A THEN" ',(gen-in-firsts target (remove nil firsts)))
+               (emit "  CALL ~A" ',(gen-parse-function-name target grammar item))
+               (emit "ELSE")
+               ,(if emptyp
+                    `(emit "  RET=NIL")
+                    `(progn
+                       (emit "  PRINT \"ERROR: UNEXPECTED TOKEN \",SCANTOK$")
+                       (emit "  STOP")))
+               (emit "ENDIF"))))
+      (ecase (car item)
+        ((seq)
+         (destructuring-bind (seq items actions) item
+           (let ((index 0)
+                 (lex (incf *lex*)))
+             `(progn
+                ,@(mapcar (lambda (item)
+                            `(progn
+                               ,(gen-parsing-statement target grammar item)
+                               (emit "L~DA~D=RES" ,lex ,(incf index))))
+                          items)
+                ,@(loop
+                     :for prev = "NIL" :then "A0"
+                     :for i :from index :downto 1
+                     :collect
+                     `(emit "A~D=L~DA~D:NCAR=A~D:NCDR=~A:CALL CONS:A0=RES"
+                            ,i ,lex ,i ,i ,prev))
+                ,@(mapcar (lambda (act) `(emit "~A" ',act)) actions)))))
+        ((rep)
+         (let ((lex (incf *lex*)))
+           `(progn
+              (emit "L~DRES=NIL" ,lex)
+              (emit "WHILE ~A"
+                    ',(gen-in-firsts target (first-rhs grammar (second item))))
+              ,(gen-parsing-statement target grammar (second item))
+              (emit "NCAR=RET:NCDR=L~DRES:CALL CONS:L~DRES=RES" ,lex ,lex)
+              (emit "ENDWHILE")
+              (emit "LIST=L~DRES:CALL REVERSE" ,lex))))
+        ((opt)
+         (let ((lex (incf *lex*)))
+           `(progn
+              (emit "L~DRES=NIL" ,lex)
+              (emit "IF ~A THEN"
+                    ',(gen-in-firsts target (first-rhs grammar (second item))))
+              ,(gen-parsing-statement target grammar (second item))
+              (emit "ELSE")
+              (emit "  RES=NIL")
+              (emit "ENDIF"))))
+        ((alt)
+         (labels ((gen (items)
+                    (if (null items)
+                        `(progn
+                           (emit "PRINT \"ERROR: DID NOT EXPECT \",CURTOK$")
+                           (emit "STOP"))
+                        `(progn
+                           (emit "IF ~A THEN"
+                                 ',(gen-in-firsts target
+                                                  (first-rhs grammar (car items))))
+                           ,(gen-parsing-statement target grammar (car items))
+                           (emit "ELSE")
+                           ,(gen (cdr items))
+                           (emit "ENDIF")))))
+           (gen (cdr item)))))))
+
+
+(defmethod generate-nt-parser ((target (eql :basic)) grammar non-terminal)
+  `(progn
+     (emit "SUB ~A" ',(gen-parse-function-name target grammar non-terminal))
+     ,(gen-parsing-statement target grammar (find-rule grammar non-terminal))
+     (emit "ENDSUB")))
+
+
+(defmethod generate-parser ((target (eql :basic)) grammar)
+  (let ((scanner-function
+         (gen-scanner-function-name target (grammar-name grammar))))
+    `(progn
+       (emit "SUB ~A"
+             ' ,(gen-parse-function-name target grammar (grammar-name grammar)))
+       (emit "  SCANSRC$=SOURCE$ : SCANPOS=0 : SCANFUN$=\"~A\""
+             ',scanner-function)
+       (emit "  CALL SCANFUN$")
+       (emit "  CALL ~A" ',(gen-parse-function-name target grammar (grammar-start grammar)))
+       (emit "  IF SCANEOF<>0 THEN")
+       (emit "    PRINT \"ERROR: END OF SOURCE NOT REACHED\"")
+       (emit "    STOP")
+       (emit "  ENDIF")
+       (emit "ENDSUB"))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; THE END ;;;;
diff --git a/small-cl-pgms/rdp/rdp.lisp b/small-cl-pgms/rdp/rdp.lisp
new file mode 100644
index 0000000..76b83f2
--- /dev/null
+++ b/small-cl-pgms/rdp/rdp.lisp
@@ -0,0 +1,780 @@
+;;;; -*- mode:lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE:               rdp.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    Implements a simple recursive descent parser.
+;;;;
+;;;;    http://en.wikipedia.org/wiki/Formal_grammar
+;;;;    http://en.wikipedia.org/wiki/Recursive_descent_parser
+;;;;    http://en.wikipedia.org/wiki/Parsing_expression_grammar
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2011-01-12 <PJB> Added grammar parameter to functions
+;;;;                     generating function names so that different
+;;;;                     grammars with non-terminals named the same
+;;;;                     don't collide.
+;;;;    2006-09-09 <PJB> Created
+;;;;BUGS
+;;;;
+;;;;    The First set of a non-terminal that can reduce to the empty string
+;;;;    should include the Follow set of this non-terminal, but for this,
+;;;;    we'd have to normalize the grammar rules, and then generate parsing
+;;;;    functions that don't correspond directly to the source rules.
+;;;;
+;;;;LEGAL
+;;;;    GPL
+;;;;
+;;;;    Copyright Pascal Bourguignon 2006 - 2011
+;;;;
+;;;;    This program is free software; you can redistribute it and/or
+;;;;    modify it under the terms of the GNU General Public License
+;;;;    as published by the Free Software Foundation; either version
+;;;;    2 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 General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU General Public
+;;;;    License along with this program; if not, write to the Free
+;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;;    Boston, MA 02111-1307 USA
+;;;;**************************************************************************
+
+(eval-when (:execute :compile-toplevel :load-toplevel)
+  (setf *features* (cons :use-ppcre (set-difference *features* '(:use-ppcre :use-regexp)))))
+
+
+(defpackage "COM.INFORMATIMAGO.RDP"
+  (:use "COMMON-LISP")
+  (:export "DEFGRAMMAR" "SEQ" "REP" "OPT" "ALT" "GRAMMAR-NAMED"
+           "GENERATE-GRAMMAR"
+
+           "GRAMMAR" "MAKE-GRAMMAR" "COPY-GRAMMAR"
+           "GRAMMAR-NAME" "GRAMMAR-TERMINALS" "GRAMMAR-START" "GRAMMAR-RULES"
+           "GRAMMAR-ALL-TERMINALS" "GRAMMAR-ALL-NON-TERMINALS"
+
+           "FIND-RULE" "TERMINALP" "NON-TERMINAL-P" "FIRST-RHS" "FIRST-SET"
+
+           "SCANNER" "MAKE-SCANNER" "COPY-SCANNER"
+           "SCANNER-SOURCE" "SCANNER-FUNCTION" "SCANNER-POSITION"
+           "SCANNER-CURRENT-TOKEN" "SCANNER-CURRENT-TEXT"
+           "SCANNER-CURRENT-POSITION"
+           "SCANNER-END-OF-SOURCE" "ACCEPT" "*SPACES*"
+           ))
+(in-package "COM.INFORMATIMAGO.RDP")
+
+
+
+(defstruct grammar
+  name terminals start rules
+  all-terminals
+  all-non-terminals)
+
+
+(defvar *grammars* (make-hash-table)
+  "Records the variables defined with DEFGRAMMAR.
+Use (GRAMMAR-NAMED name) to look up a grammar.")
+
+(defun grammar-named (name)
+  "Returns the grammar named NAME, or NIL if none."
+  (gethash name *grammars*))
+
+
+
+
+(defgeneric generate-boilerplate (target-language grammar)
+  (:documentation "Generate the boilerplate code needed by the scanner and parser.
+
+This code must be a single lisp form.  In the case of the :lisp
+target-language, this form is the code of the boilerplate itself.  For
+another language, this form is lisp code used to generate that other
+language boilerplate."))
+
+
+(defgeneric generate-scanner     (target-language grammar)
+    (:documentation "Generate the scanner code.
+
+This code must be a single lisp form.  In the case of the :lisp
+target-language, this form is the code of the boilerplate itself.  For
+another language, this form is lisp code used to generate that other
+language boilerplate."))
+
+
+(defgeneric generate-nt-parser   (target-language grammar non-terminal)
+    (:documentation "Generate the parser code for the given non-terminal.
+
+This code must be a single lisp form.  In the case of the :lisp
+target-language, this form is the code of the boilerplate itself.  For
+another language, this form is lisp code used to generate that other
+language boilerplate."))
+
+
+(defgeneric generate-parser      (target-language grammar)
+    (:documentation "Generate the toplevel parser code.
+
+This code must be a single lisp form.  In the case of the :lisp
+target-language, this form is the code of the boilerplate itself.  For
+another language, this form is lisp code used to generate that other
+language boilerplate."))
+
+
+
+
+;;; First, we define a grammar, with actions.
+;;; The scanner and parser is generated at macro expansion time.
+
+(defvar *linenum* 0)
+
+
+(defmacro defgrammar (name &key terminals start rules (target-language :lisp))
+  "
+DO:     This macros generates a simple scanner and recursive decent parser
+        for the language described by this grammar.
+        For each <non-terminal> in the grammar, a function named
+        <name>/PARSE-<non-terminal> is generated, in addition to
+        functions SCAN-<name> and PARSE-<name>.
+        The grammar structure is also generated for run-time
+        in the global special variable <name>.
+
+TARGET-LANGUAGE:
+
+        Specifies the language into which the code is generated, as a
+        keyword.  The actions must still be written as lisp
+        expressions, but to generate the language specified.  There
+        must be a set of methods specialized on this target-language
+        keyword.
+
+SYNTAX:
+
+    (defgrammar <name>
+        :terminals (( <terminal>       \"regexp\") ...)
+        :start        <non-terminal>
+        :rules     ((--> <non-terminal> <items> ) ...))
+
+    <items>            ::= | <item> <items>
+    <item>             ::= <seq> | <rep> | <alt> | <opt>
+                         | <non-terminal> | <literal-terminal> | <terminal>
+    <seq>              ::= (SEQ <item> <items> <action>)
+    <rep>              ::= (REP <item> <items> <action>)
+    <opt>              ::= (OPT <item> <items> <action>)
+    <alt>              ::= (ALT <item> <items>)
+    <action>           ::= | :ACTION <forms>
+    <forms>            ::= | <form> <forms>
+    <form>             ::= form        -- any lisp form.
+    <non-terminal>     ::= symbol      -- any lisp symbol (keywords reserved).
+    <terminal>         ::= symbol      -- any lisp symbol (keywords reserved).
+    <literal-terminal> ::= string      -- any lisp string.
+
+SEMANTICS:
+
+        The terminals are either named terminals listed in the :TERMINALS
+        clause, or literal terminals written directly in the productions as
+        lisp strings.  They are matched as-is.
+
+        An extended regular expression regex(7) may be given that
+        will be matched by the scanner to infer the given terminal.
+        The literal terminals are matched first, the longest first,
+        and with ([A-Za-z0-9]|$) appended to terminals ending in a
+        letter or digit (so that they don't match when part of a
+        longer identifier).
+        Then the regular expressions are matched in the order given.
+
+        :START specifies the start non-terminal symbol.
+
+        The non-terminal symbols are infered implicitely from the grammar rules.
+
+        If there are more than one subforms, or an action,
+        the REP and OPT forms take an implicit SEQ:
+          (REP a b c :ACTION f)   -->  (REP (SEQ a b c :ACTION f))
+          (OPT a b c :ACTION f)   -->  (OPT (SEQ a b c :ACTION f))
+          (REP a :ACTION f)       -->  (REP (SEQ a :ACTION f))
+          (OPT a :ACTION f)       -->  (OPT (SEQ a :ACTION f))
+          (REP a)                 -->  (REP a)
+          (OPT a)                 -->  (OPT a)
+
+        Embedded ALT are flattened:
+          (ALT a b (ALT c d) e f) --> (ALT a b c d e f)
+
+        Actions are executed in a lexical environment where the symbols $1, $2,
+        etc are bound to the results of the subforms. $0 is bound to the
+        list of the results of the subforms.
+
+        The action for REP (normalized) is to return a possibly
+        empty list of the results of its single subform repeated.
+        (REP is 0 or more).
+
+        The action for OPT (normalized) is to return either NIL,
+        or the result of its single subform unchanged.
+
+        The action for an ALT is to return the result of the selected
+        alternative unchanged.
+
+        The default action for an internal SEQ is to return the list of the
+        results of its subforms.
+
+        The default action for an implicit SEQ for a given <non-terminal> lhs
+        is to return the list of the results of its subforms prefixed by the
+        <non-terminal> symbol.
+
+TODO:   We could also flatten sequences without action, or even sequences with
+        actions with renumbering.
+"
+  (let ((grammar (make-grammar :name name
+                               :terminals terminals
+                               :start start
+                               :rules (normalize-rules rules)))
+        (*linenum* 0)
+        (g (gensym)))
+    (compute-all-terminals     grammar)
+    (compute-all-non-terminals grammar)
+    `(progn
+       (setf (gethash ',name *grammars*)
+             (let ((,g (make-grammar
+                        :name ',name
+                        :terminals ',terminals
+                        :start ',start
+                        :rules ',(normalize-rules rules))))
+               (compute-all-terminals     ,g)
+               (compute-all-non-terminals ,g)
+               ,g))
+
+       ,(generate-boilerplate target-language grammar)
+       ,(generate-scanner target-language grammar)
+       ,@(mapcar (lambda (non-terminal)
+                   (generate-nt-parser target-language grammar non-terminal))
+                 (grammar-all-non-terminals grammar))
+       ,(generate-parser target-language grammar))))
+
+
+
+(defun generate-grammar (name &key terminals start rules (target-language :lisp) compile)
+  "
+SEE ALSO:   The docstring of DEFGRAMMAR.
+DO:         This function defines and generate the grammar object at run-time.
+RETURN:     The grammar object.
+NOTE:       The grammar is not added to the *grammars* map.
+"
+  (let ((grammar (make-grammar :name name
+                               :terminals terminals
+                               :start start
+                               :rules (normalize-rules rules)))
+        (*linenum* 0))
+    (compute-all-terminals     grammar)
+    (compute-all-non-terminals grammar)
+    (let ((code  `(progn
+                    ,(generate-boilerplate target-language grammar)
+                    ,(generate-scanner target-language grammar)
+                    ,@(mapcar (lambda (non-terminal)
+                                (generate-nt-parser target-language grammar non-terminal))
+                              (grammar-all-non-terminals grammar))
+                    ,(generate-parser target-language grammar))))
+     (if compile
+         (funcall (compile nil `(lambda () ,code)))
+         (eval code)))
+    grammar))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Normalization of  the grammar rules:
+;;;
+
+(defun split-action (rhs)
+  (declare (inline))
+  (let ((separator (position :action rhs)))
+    (if separator
+        (values (subseq rhs 0 separator) (subseq rhs (1+ separator)))
+        (values rhs                      nil))))
+
+
+(defun normalize-seq (expr)
+  (multiple-value-bind (rhs actions) (split-action (cdr expr))
+    (setf actions (or actions '($0)))
+    (let ((items (mapcar (lambda (item) (normalize item)) rhs)))
+      (if (and (null actions) (or (null items) (null (cdr items))))
+          (car items)
+          (list 'seq items actions)))))
+
+(defun normalize-with-action (expr)
+  (multiple-value-bind (rhs actions) (split-action (cdr expr))
+    (if (null actions)
+        (cond ((null rhs) nil)
+              ((null (cdr rhs)) `(,(car expr) ,(normalize (car rhs))))
+              (t `(,(car expr) ,(normalize-seq `(seq ,@rhs)))))
+         `(,(car expr) ,(normalize-seq `(seq ,@rhs :action ,@actions))))))
+
+(defun normalize-rep (expr) (normalize-with-action expr))
+(defun normalize-opt (expr) (normalize-with-action expr))
+
+(defun normalize-alt (expr)
+  (assert (not (find :action expr)))
+  (let ((items (mapcar (function normalize) (cdr expr))))
+    (if (null (cdr items))
+        (car items)
+        `(alt ,@(mapcan (lambda (item)
+                          (cond ((atom item) (list item))
+                                ((eql 'alt (car item)) (cdr items))
+                                (t (list item))))
+                        items)))))
+
+(defun normalize (expr)
+  (if (atom expr)
+      expr
+      (ecase (car expr)
+        ((seq) (normalize-seq expr))
+        ((rep) (normalize-rep expr))
+        ((alt) (normalize-alt expr))
+        ((opt) (normalize-opt expr)))))
+
+(defun normalize-rules (rules)
+  (mapcar (lambda (rule)
+            (destructuring-bind (--> non-term &rest items) rule
+               (assert (string= --> '-->))
+               `(,non-term ,(normalize
+                             (if (find :action items)
+                                 `(seq ,@items)
+                                 `(seq ,@items :action `(,',non-term ,@$0)))))))
+          rules))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun word-equal (a b)
+  (or (and (stringp a) (stringp b) (string= a b))
+      (eql a b)))
+
+(defun compute-all-terminals (grammar)
+  (labels  ((find-strings (items)
+              (cond
+                ((stringp items) (list items))
+                ((atom items)    '())
+                (t (ecase (car items)
+                     ((seq)
+                      (mapcan (function find-strings) (second items)))
+                     ((rep alt opt)
+                      (mapcan (function find-strings) (cdr items))))))))
+    (setf (grammar-all-terminals grammar)
+          (delete-duplicates
+           (append
+            (mapcar (function first) (grammar-terminals grammar))
+            (mapcan (function find-strings)
+                    (mapcar (function second) (grammar-rules grammar))))
+           :test (function word-equal)))))
+
+
+(defun compute-all-non-terminals (grammar)
+  (labels ((find-symbols (items)
+             (cond
+               ((symbolp items) (list items))
+               ((atom items)    '())
+               (t (ecase (car items)
+                    ((seq)
+                     (mapcan (function find-symbols) (second items)))
+                    ((rep alt opt)
+                     (mapcan (function find-symbols) (cdr items))))))))
+    (setf (grammar-all-non-terminals grammar)
+          (set-difference
+           (delete-duplicates
+            (append
+             (list (grammar-start grammar))
+             (mapcar (function first) (grammar-rules grammar))
+             (mapcan (function find-symbols)
+                     (mapcar (function second) (grammar-rules grammar)))))
+           (grammar-all-terminals grammar)))))
+
+
+;;; To implement the follow-set function we'd need to put the grammar
+;;; into a normal form, which we don't really need to map it simplistically
+;;; to recursive descent parser functions.
+
+;; (defun follow-set (grammar non-terminal)
+;;   "return the set of terminal symbols that may follow the non-terminal
+;; in the grammar."
+;;   (mapcar (lambda (rule)
+;;             (destructuring-bind (nt expr) rule
+;;
+;;               ))
+;;           (grammar-rules grammar)))
+
+
+(defun find-rule (grammar non-terminal)
+  (let ((rules (mapcar (function second)
+                       (remove-if-not (lambda (rule) (eql non-terminal (first rule)))
+                                      (grammar-rules grammar)))))
+    (cond
+      ((null rules) (error "~s is not a non-terminal" non-terminal))
+      ((null (cdr rules)) (car rules))
+      (t `(alt ,@(normalize-alt rules))))))
+
+
+(defun terminalp (grammar item)
+  (member item (grammar-all-terminals grammar)
+          :test (function word-equal)))
+
+(defun non-terminal-p (grammar item)
+  (member item (grammar-all-non-terminals grammar)))
+
+
+(defun first-rhs (grammar item)
+  (if (atom item)
+      (if (terminalp grammar item)
+          (list item)
+          (first-set grammar item))
+      (ecase (car item)
+        ((seq) (loop
+                  :with all-firsts = '()
+                  :for items :in (second item)
+                  :for firsts = (first-rhs grammar items)
+                  :while (member nil firsts)
+                  :do (setf all-firsts
+                            (union firsts (delete nil all-firsts)))
+                  :finally (setf all-firsts
+                                 (union firsts (delete nil all-firsts)))
+                  (return all-firsts)))
+        ((rep opt) (cons nil (first-rhs grammar (second item))))
+        ((alt) (mapcan (lambda (item) (first-rhs grammar item)) (rest item))))))
+
+
+(defun first-set (grammar non-terminal)
+  "return the set of terminal symbols by which the non-terminal may start
+in the grammar."
+  (delete-duplicates (first-rhs grammar (find-rule grammar non-terminal))
+                       :test (function word-equal)))
+
+
+
+
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Regexp Abstraction Layer.
+;;;
+;;; Used by the code generated by the Lisp generator below.
+;;;
+;;; On clisp, the user can choose to use the REGEXP package instead of
+;;; CL-PPCRE, by adjoining :use-regexp instead of :use-ppcre to
+;;; *features* (see the beginning of this file).
+
+
+
+;; (:export "SPLIT-STRING"
+;;          "STRING-MATCH" "MATCH-STRING" "MATCH-BEGINNING" "MATCH-END"
+;;          "REGEXP-MATCh-ANY" "REGEXP-COMPILE" "REGEXP-QUOTE-EXTENDED")
+
+
+(defun split-string (string regexp)
+  #-(or use-ppcre (and clisp use-regexp))
+  (error "Please implement ~S (perhaps push :use-ppcre on *features*)." 'split-string)
+  #+(and clisp use-regexp) (regexp:regexp-split regexp string)
+  #+use-ppcre (cl-ppcre:split regexp string))
+
+
+(defvar *string-match-results* '())
+
+#+(and clisp use-regexp)
+(defun nsubseq (sequence start &optional (end nil))
+  "
+RETURN:  When the SEQUENCE is a vector, the SEQUENCE itself, or a dispaced
+         array to the SEQUENCE.
+         When the SEQUENCE is a list, it may destroy the list and reuse the
+         cons cells to make the subsequence.
+"
+  (if (vectorp sequence)
+      (if (and (zerop start) (or (null end) (= end (length sequence))))
+          sequence
+          (make-array (- (if end
+                             (min end (length sequence))
+                             (length sequence))
+                         start)
+                      :element-type (array-element-type sequence)
+                      :displaced-to sequence
+                      :displaced-index-offset start))
+      (let ((result (nthcdr start sequence)))
+        (when end
+          (setf (cdr (nthcdr (- end start -1) sequence)) nil))
+        result)))
+
+(defun string-match (regexp string &key (start 0) (end nil))
+  #-(or use-ppcre (and clisp use-regexp))
+  (error "Please implement ~S (perhaps push :use-ppcre on *features*)." 'split-match)
+  #+(and clisp use-regexp)
+  (setf *string-match-results*
+         (let ((results (if (stringp regexp)
+                           (multiple-value-list
+                            (regexp:match regexp string :start start :end end :extended t :ignore-case nil :newline t :nosub nil))
+                           (regexp:regexp-exec (cdr regexp) string :start start :end end :return-type 'list))))
+          (if (equal '(nil) results)
+              nil
+              results)))
+  #+use-ppcre
+  (setf *string-match-results*
+        (let ((results (multiple-value-list
+                        (if (stringp regexp)
+                            (cl-ppcre:scan regexp       string :start start :end (or end (length string)))
+                            (cl-ppcre:scan (cdr regexp) string :start start :end (or end (length string)))))))
+          (if (equal '(nil) results)
+              nil
+              (destructuring-bind (as ae ss es) results
+                  (list as ae
+                        (concatenate 'vector (vector as) ss)
+                        (concatenate 'vector (vector ae) es)))))))
+
+(defun match-string (index string &optional (match-results *string-match-results*))
+  #-(or use-ppcre (and clisp use-regexp))
+  (error "Please implement ~S (perhaps push :use-ppcre on *features*)." 'match-string)
+  #+(and clisp use-regexp)
+  (let ((m (elt match-results index)))
+    (when m (regexp:match-string string m)))
+  #+use-ppcre
+  (let ((start (ignore-errors (aref (elt match-results 2) index)))
+        (end   (ignore-errors (aref (elt match-results 3) index))))
+    (when (and start end)
+      (subseq string start end))))
+
+(defun match-beginning (index &optional (match-results *string-match-results*))
+  #-(or use-ppcre (and clisp use-regexp))
+  (error "Please implement ~S (perhaps push :use-ppcre on *features*)." 'match-beginning)
+  #+(and clisp use-regexp)
+  (let ((m (elt match-results index)))
+    (when m (regexp:match-start m)))
+  #+use-ppcre
+  (ignore-errors (aref (elt match-results 2) index)))
+
+(defun match-end (index &optional (match-results *string-match-results*))
+  #-(or use-ppcre (and clisp use-regexp))
+  (error "Please implement ~S (perhaps push :use-ppcre on *features*)." 'match-end)
+  #+(and clisp use-regexp)
+  (let ((m (elt match-results index)))
+    (when m (regexp:match-end m)))
+  #+use-ppcre
+  (ignore-errors (aref (elt match-results 3) index)))
+
+(defun regexp-match-any (groupsp)
+  #- (or use-ppcre (and clisp use-regexp))
+  (error "Please implement ~S (perhaps push :use-ppcre on *features*)." 'regexp-match-any)
+  #+(and clisp use-regexp) (if groupsp "(.*)" ".*")
+  #+use-ppcre              (if groupsp "(.*)" ".*"))
+
+(defun regexp-compile (regexp)
+  #- (or use-ppcre (and clisp use-regexp))
+  (error "Please implement ~S (perhaps push :use-ppcre on *features*)." 'regexp-compile)
+  #+(and clisp use-regexp) (regexp:regexp-compile regexp
+                                                  :extended t
+                                                  :ignore-case nil
+                                                  :newline t
+                                                  :nosub nil)
+  #+use-ppcre (cl-ppcre:create-scanner regexp
+                                       :case-insensitive-mode nil
+                                       :multi-line-mode nil
+                                       :extended-mode nil
+                                       :destructive nil))
+
+(defun regexp-quote-extended (string)
+  ;; #+clisp regexp:regexp-quote doesn't quote extended regexps...
+  ;;        (regexp:regexp-quote "(abc .*" t) --> "(abc \\.\\*"  instead of "\\(abc \\.\\*"
+  #-use-ppcre
+  (let* ((special-characters "^.[$()|*+?{\\")
+         (increase (count-if (lambda (ch) (find ch special-characters)) string)))
+     (if (zerop increase)
+         string
+         (let ((result (make-array (+ (length string) increase)
+                                    :element-type 'character)))
+           (loop
+              :with i = -1
+              :for ch :across string
+              :do (if (find ch special-characters)
+                      (setf (aref result (incf i)) #\\
+                            (aref result (incf i)) ch)
+                      (setf (aref result (incf i)) ch)))
+           result)))
+  #+use-ppcre
+  (cl-ppcre:quote-meta-chars string))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Generator -- LISP
+;;;
+
+(defmethod generate-boilerplate ((target (eql :lisp)) (grammar grammar))
+  (declare (ignore grammar))
+  `(progn
+
+    (defstruct scanner
+      source
+      function
+      (position 0)
+      (current-token nil)
+      (current-text "")
+      (current-position 0))
+
+    (defun scanner-end-of-source (scanner)
+      (<= (length (scanner-source scanner)) (scanner-position scanner)))
+
+    (defun accept (scanner token)
+      (if (word-equal token (scanner-current-token scanner))
+          (prog1 (list (scanner-current-token scanner)
+                       (scanner-current-text scanner)
+                       (scanner-current-position scanner))
+            (funcall (scanner-function scanner) scanner))
+          (error "At position ~D, expected ~S, not ~S"
+                 (scanner-current-position scanner)
+                 token
+                 (scanner-current-token scanner))))
+
+    (defparameter *spaces*
+      (format nil "^([~{~C~}]+)" '(#\space #\newline #\tab)))))
+
+
+(defmethod gen-scanner-function-name ((target (eql :lisp)) (grammar grammar))
+  (intern (format nil "~:@(SCAN-~A~)" (grammar-name grammar))))
+
+
+
+(defmethod generate-scanner ((target (eql :lisp)) grammar)
+  ;;
+  ;; an-terminals  = literal terminals (given as string in rules), ending with an alphanumeric.
+  ;; nan-terminals = literal terminals ending with something else than an alphanumeric.
+  ;; nl-terminals  = non-literal terminals (specified in :terminals clauses).
+  ;;
+  ;; an-terminals are scanned by excluding alphanumerics directly after them.
+  ;; "while" --> "(while)([^A-Za-z0-9]|$)"  so that "while whilemin" scans as <while> <identifier>.
+  ;;
+  ;; nl-terminals are processed in the order they're given in the :terminals clauses.
+  ;;
+  (let* ((an-terminals  (sort (remove-if-not
+                               (lambda (item)
+                                 (and (stringp item)
+                                      (alphanumericp (aref item (1- (length item))))))
+                               (grammar-all-terminals grammar))
+                              (function >) :key (function length)))
+         (nan-terminals (sort (remove-if
+                               (lambda (item)
+                                 (or (not (stringp item))
+                                     (alphanumericp (aref item (1- (length item))))))
+                               (grammar-all-terminals grammar))
+                              (function >) :key (function length)))
+         (nl-terminals (remove-if (function stringp) (grammar-terminals grammar)))
+         (lit-an-terminals-regexp
+          (format nil "^(~{~A~^|~})([^A-Za-z0-9]|$)"
+                  (mapcar (function regexp-quote-extended) an-terminals)))
+         (lit-nan-terminals-regexp
+          (format nil "^(~{~A~^|~})"
+                  (mapcar (function regexp-quote-extended)  nan-terminals))))
+    `(defun ,(gen-scanner-function-name target grammar) (scanner)
+       (let ((match (string-match *spaces*
+                                  (scanner-source scanner)
+                                  :start (scanner-position scanner))))
+         (when match
+           (setf (scanner-position scanner) (match-end 1 match)))
+         (setf (scanner-current-position scanner) (scanner-position scanner))
+         (cond
+           ((scanner-end-of-source scanner)
+            (setf (scanner-position scanner)   (length (scanner-source scanner))
+                  (scanner-current-text scanner)  "<END OF SOURCE>"
+                  (scanner-current-token scanner) nil))
+           ,@(when (or an-terminals nan-terminals)
+                   `(((or ,@(when an-terminals
+                                  `((setf match (string-match ',lit-an-terminals-regexp
+                                                             (scanner-source scanner)
+                                                             :start (scanner-position scanner)))))
+                          ,@(when nan-terminals
+                                  `((setf match (string-match ',lit-nan-terminals-regexp
+                                                             (scanner-source scanner)
+                                                             :start (scanner-position scanner))))))
+                      (setf (scanner-position scanner)      (match-end 1 match)
+                            (scanner-current-text scanner)  (match-string 1 (scanner-source scanner) match)
+                            (scanner-current-token scanner) (scanner-current-text scanner)))))