diff --git a/books/bookvol9.pamphlet b/books/bookvol9.pamphlet
index 290baf5..18a32ec 100644
--- a/books/bookvol9.pamphlet
+++ b/books/bookvol9.pamphlet
@@ -6555,13 +6555,12 @@ Code for encoding function names inside package or domain
 (defun |mkRepititionAssoc| (z)
  (labels (
   (mkRepfun (z n)
-   (let (x)
     (cond
      ((null z) nil)
      ((and (pairp z) (eq (qcdr z) nil) (list (cons n (qcar z)))))
      ((and (pairp z) (pairp (qcdr z)) (equal (qcar (qcdr z)) (qcar z)))
       (mkRepfun (cdr z) (1+ n)))
-     (t (cons (cons n (car z)) (mkRepfun (cdr z) 1)))))))
+     (t (cons (cons n (car z)) (mkRepfun (cdr z) 1))))))
  (mkRepfun z 1)))
 
 \end{chunk}
@@ -8904,6 +8903,242 @@ where item has form
 
 \end{chunk}
 
+\section{Code optimization routines}
+\defun{optimizeFunctionDef}{optimizeFunctionDef}
+\calls{optimizeFunctionDef}{pairp}
+\calls{optimizeFunctionDef}{qcar}
+\calls{optimizeFunctionDef}{qcdr}
+\calls{optimizeFunctionDef}{rplac}
+\calls{optimizeFunctionDef}{sayBrightlyI}
+\calls{optimizeFunctionDef}{optimize}
+\calls{optimizeFunctionDef}{pp}
+\calls{optimizeFunctionDef}{bright}
+\refsdollar{optimizeFunctionDef}{reportOptimization}
+\begin{chunk}{defun optimizeFunctionDef}
+(defun |optimizeFunctionDef| (def)
+ (labels (
+  (fn (x g)
+    (cond
+     ((and (pairp x) (eq (qcar x) 'throw) (pairp (qcdr x))
+           (equal (qcar (qcdr x)) g))
+       (|rplac| (car x) 'return)
+       (|rplac| (cdr x)
+        (replaceThrowByReturn (qcdr (qcdr x)) g)))
+     ((atom x) nil)
+     (t
+      (replaceThrowByReturn (car x) g)
+      (replaceThrowByReturn (cdr x) g))))
+  (replaceThrowByReturn (x g)
+   (fn x g)
+   x)
+  (removeTopLevelCatch (body)
+   (if (and (pairp body) (eq (qcar body) 'catch) (pairp (qcdr body))
+            (pairp (qcdr (qcdr body))) (eq (qcdr (qcdr (qcdr body))) nil))
+    (removeTopLevelCatch
+      (replaceThrowByReturn 
+        (qcar (qcdr (qcdr body))) (qcar (qcdr body))))
+    body)))
+ (let (defp name slamOrLam args body bodyp)
+ (declare (special |$reportOptimization|))
+  (when |$reportOptimization|
+    (|sayBrightlyI| (|bright| "Original LISP code:"))
+    (|pp| def))
+  (setq defp (|optimize| (copy def)))
+  (when |$reportOptimization|
+    (|sayBrightlyI| (|bright| "Optimized LISP code:"))
+    (|pp| defp)
+    (|sayBrightlyI| (|bright| "Final LISP code:")))
+  (setq name (car defp))
+  (setq slamOrLam (caadr defp))
+  (setq args (cadadr defp))
+  (setq body (car (cddadr defp)))
+  (setq bodyp (removeTopLevelCatch body))
+  (list name (list slamOrLam args bodyp)))))
+
+\end{chunk}
+
+\defun{optimize}{optimize}
+\calls{optimize}{pairp}
+\calls{optimize}{qcar}
+\calls{optimize}{qcdr}
+\calls{optimize}{optimize}
+\calls{optimize}{say}
+\calls{optimize}{prettyprint}
+\calls{optimize}{rplac}
+\calls{optimize}{optIF2COND}
+\calls{optimize}{getl}
+\calls{optimize}{subrname}
+\begin{chunk}{defun optimize}
+(defun |optimize| (x)
+ (labels (
+  (opt (x)
+   (let (argl body a y op)
+    (cond
+     ((atom x) nil)
+     ((eq (setq y (car x)) 'quote) nil)
+     ((eq y 'closedfn) nil)
+     ((and (pairp y) (pairp (qcar y)) (eq (qcar (qcar y)) 'xlam)
+           (pairp (qcdr (qcar y))) (pairp (qcdr (qcdr (qcar y))))
+           (eq (qcdr (qcdr (qcdr (qcar y)))) nil))
+      (setq argl (qcar (qcdr (qcar y))))
+      (setq body (qcar (qcdr (qcdr (qcar y)))))
+      (setq a (qcdr y))
+      (|optimize| (cdr x))
+      (cond
+       ((eq argl '|ignore|) (rplac (car x) body))
+       (t
+         (when (null (<= (length argl) (length a)))
+           (say "length mismatch in XLAM expression")
+           (prettyprint y))
+          (rplac (car x)
+           (|optimize|
+            (|optXLAMCond|
+             (sublis (|pairList| argl a) body)))))))
+   ((atom y)
+     (|optimize| (cdr x))
+     (cond
+      ((eq y '|true|) (rplac (car x) '''T))
+      ((eq y '|false|) (rplac (car x) nil))))
+   ((eq (car y) 'if)
+     (rplac (car x) (|optIF2COND| y))
+     (setq y (car x))
+     (when (setq op (getl (|subrname| (car y)) 'optimize))
+      (|optimize| (cdr x))
+      (rplac (car x) (funcall op (|optimize| (car x))))))
+   ((setq op (getl (|subrname| (car y)) 'optimize))
+      (|optimize| (cdr x))
+      (rplac (car x) (funcall op (|optimize| (car x)))))
+   (t
+     (rplac (car x) (|optimize| (car x)))
+     (|optimize| (cdr x)))))))
+ (opt x)
+ x))
+
+\end{chunk}
+
+\defun{subrname}{subrname}
+\calls{subrname}{identp}
+\calls{subrname}{compiled-function-p}
+\calls{subrname}{mbpip}
+\calls{subrname}{bpiname}
+\begin{chunk}{defun subrname}
+(defun |subrname| (u)
+ (cond
+   ((identp u) u)
+   ((or (compiled-function-p u) (mbpip u)) (bpiname u))
+   (t nil)))
+
+\end{chunk}
+
+\subsection{Special case optimizers}
+Optimization functions are called through the OPTIMIZE property on the
+symbol property list.
+
+\defplist{call}{optCall}
+\begin{chunk}{postvars}
+(eval-when (eval load)
+ (setf (get '|call| 'optimize) '|optCall|))
+
+\end{chunk}
+
+\defplist{seq}{optSEQ}
+\begin{chunk}{postvars}
+(eval-when (eval load)
+ (setf (get 'seq 'optimize) '|optSEQ|))
+
+\end{chunk}
+
+\defplist{eq}{optEQ}
+\begin{chunk}{postvars}
+(eval-when (eval load)
+ (setf (get 'eq 'optimize) '|optEQ|))
+
+\end{chunk}
+
+\defplist{minus}{optMINUS}
+\begin{chunk}{postvars}
+(eval-when (eval load)
+ (setf (get 'minus 'optimize) '|optMINUS|))
+
+\end{chunk}
+
+\defplist{qsminus}{optQSMINUS}
+\begin{chunk}{postvars}
+(eval-when (eval load)
+ (setf (get 'qsminus 'optimize) '|optQSMINUS|))
+
+\end{chunk}
+
+\defplist{-}{opt-}
+\begin{chunk}{postvars}
+(eval-when (eval load)
+ (setf (get '- 'optimize) '|opt-|))
+
+\end{chunk}
+
+\defplist{lessp}{optLESSP}
+\begin{chunk}{postvars}
+(eval-when (eval load)
+ (setf (get 'lessp 'optimize) '|optLESSP|))
+
+\end{chunk}
+
+\defplist{spadcall}{optSPADCALL}
+\begin{chunk}{postvars}
+(eval-when (eval load)
+ (setf (get 'spadcall 'optimize) '|optSPADCALL|))
+
+\end{chunk}
+
+\defplist{\vert{}}{optSuchthat}
+\begin{chunk}{postvars}
+(eval-when (eval load)
+ (setf (get '|\|| 'optimize) '|optSuchthat|))
+
+\end{chunk}
+
+\defplist{catch}{optCatch}
+\begin{chunk}{postvars}
+(eval-when (eval load)
+ (setf (get 'catch 'optimize) '|optCatch|))
+
+\end{chunk}
+
+\defplist{cond}{optCond}
+\begin{chunk}{postvars}
+(eval-when (eval load)
+ (setf (get 'cond 'optimize) '|optCond|))
+
+\end{chunk}
+
+\defplist{mkRecord}{optMkRecord}
+\begin{chunk}{postvars}
+(eval-when (eval load)
+ (setf (get '|mkRecord| 'optimize) '|optMkRecord|))
+
+\end{chunk}
+
+\defplist{recordelt}{optRECORDELT}
+\begin{chunk}{postvars}
+(eval-when (eval load)
+ (setf (get 'recordelt 'optimize) '|optRECORDELT|))
+
+\end{chunk}
+
+\defplist{setrecordelt}{optSETRECORDELT}
+\begin{chunk}{postvars}
+(eval-when (eval load)
+ (setf (get 'setrecordelt 'optimize) '|optSETRECORDELT|))
+
+\end{chunk}
+
+\defplist{recordcopy}{optRECORDCOPY}
+\begin{chunk}{postvars}
+(eval-when (eval load)
+ (setf (get 'recordcopy 'optimize) '|optRECORDCOPY|))
+
+\end{chunk}
+
 \section{Functions to manipulate modemaps}
 
 \defun{addDomain}{addDomain}
@@ -21880,6 +22115,8 @@ The current input line.
 \getchunk{defun new2OldLisp}
 \getchunk{defun nonblankloc}
 
+\getchunk{defun optimize}
+\getchunk{defun optimizeFunctionDef}
 \getchunk{defun optional}
 \getchunk{defun orderByDependency}
 \getchunk{defun orderPredicateItems}
@@ -22115,6 +22352,7 @@ The current input line.
 \getchunk{defun storeblanks}
 \getchunk{defun stripOffArgumentConditions}
 \getchunk{defun stripOffSubdomainConditions}
+\getchunk{defun subrname}
 \getchunk{defun substituteCategoryArguments}
 \getchunk{defun substNames}
 \getchunk{defun substVars}
diff --git a/changelog b/changelog
index 0d2269f..109037b 100644
--- a/changelog
+++ b/changelog
@@ -1,3 +1,6 @@
+20110830 tpd src/axiom-website/patches.html 20110830.01.tpd.patch
+20110830 tpd src/interp/g-opt.lisp treeshake compiler
+20110830 tpd books/bookvol9 treeshake compiler
 20110828 tpd src/axiom-website/patches.html 20110828.01.tpd.patch
 20110828 tpd src/interp/Makefile remove package.lisp
 20110828 tpd src/interp/package.lisp removed
diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html
index ef7bcc0..6c3e3b4 100644
--- a/src/axiom-website/patches.html
+++ b/src/axiom-website/patches.html
@@ -3602,5 +3602,7 @@ books/bookvol9 treeshake compiler<br/>
 src/interp/package.lisp remove isPackageFunction<br/>
 <a href="patches/20110828.01.tpd.patch">20110828.01.tpd.patch</a>
 books/bookvol9 treeshake compiler, remove package.lisp<br/>
+<a href="patches/20110830.01.tpd.patch">20110830.01.tpd.patch</a>
+books/bookvol9 treeshake compiler<br/>
  </body>
 </html>
diff --git a/src/interp/g-opt.lisp.pamphlet b/src/interp/g-opt.lisp.pamphlet
index 6c5f60b..ce3dc60 100644
--- a/src/interp/g-opt.lisp.pamphlet
+++ b/src/interp/g-opt.lisp.pamphlet
@@ -15,201 +15,7 @@
 
 ;--% OPTIMIZER
 ;
-;optimizeFunctionDef(def) ==
-;  if $reportOptimization then
-;    sayBrightlyI bright '"Original LISP code:"
-;    pp def
 ;
-;  def' := optimize COPY def
-;
-;  if $reportOptimization then
-;    sayBrightlyI bright '"Optimized LISP code:"
-;    pp def'
-;    sayBrightlyI bright '"Final LISP code:"
-;  [name,[slamOrLam,args,body]] := def'
-;
-;  body':=
-;    removeTopLevelCatch body where
-;      removeTopLevelCatch body ==
-;        body is ["CATCH",g,u] =>
-;          removeTopLevelCatch replaceThrowByReturn(u,g)
-;        body
-;      replaceThrowByReturn(x,g) ==
-;        fn(x,g)
-;        x
-;      fn(x,g) ==
-;        x is ["THROW", =g,:u] =>
-;          rplac(first x,"RETURN")
-;          rplac(rest x,replaceThrowByReturn(u,g))
-;        atom x => nil
-;        replaceThrowByReturn(first x,g)
-;        replaceThrowByReturn(rest x,g)
-;  [name,[slamOrLam,args,body']]
-
-(DEFUN |optimizeFunctionDef,fn| (|x| |g|)
-  (PROG (|ISTMP#1| |u|)
-    (RETURN
-      (SEQ (IF (AND (PAIRP |x|) (EQ (QCAR |x|) 'THROW)
-                    (PROGN
-                      (SPADLET |ISTMP#1| (QCDR |x|))
-                      (AND (PAIRP |ISTMP#1|)
-                           (EQUAL (QCAR |ISTMP#1|) |g|)
-                           (PROGN (SPADLET |u| (QCDR |ISTMP#1|)) 'T))))
-               (EXIT (SEQ (|rplac| (CAR |x|) 'RETURN)
-                          (EXIT (|rplac| (CDR |x|)
-                                    (|optimizeFunctionDef,replaceThrowByReturn|
-                                          |u| |g|))))))
-           (IF (ATOM |x|) (EXIT NIL))
-           (|optimizeFunctionDef,replaceThrowByReturn| (CAR |x|) |g|)
-           (EXIT (|optimizeFunctionDef,replaceThrowByReturn| (CDR |x|)
-                     |g|))))))
-
-
-(DEFUN |optimizeFunctionDef,replaceThrowByReturn| (|x| |g|)
-  (SEQ (|optimizeFunctionDef,fn| |x| |g|) (EXIT |x|)))
-
-(DEFUN |optimizeFunctionDef,removeTopLevelCatch| (|body|)
-  (PROG (|ISTMP#1| |g| |ISTMP#2| |u|)
-    (RETURN
-      (SEQ (IF (AND (PAIRP |body|) (EQ (QCAR |body|) 'CATCH)
-                    (PROGN
-                      (SPADLET |ISTMP#1| (QCDR |body|))
-                      (AND (PAIRP |ISTMP#1|)
-                           (PROGN
-                             (SPADLET |g| (QCAR |ISTMP#1|))
-                             (SPADLET |ISTMP#2| (QCDR |ISTMP#1|))
-                             (AND (PAIRP |ISTMP#2|)
-                                  (EQ (QCDR |ISTMP#2|) NIL)
-                                  (PROGN
-                                    (SPADLET |u| (QCAR |ISTMP#2|))
-                                    'T))))))
-               (EXIT (|optimizeFunctionDef,removeTopLevelCatch|
-                         (|optimizeFunctionDef,replaceThrowByReturn|
-                             |u| |g|))))
-           (EXIT |body|)))))
-
-(DEFUN |optimizeFunctionDef| (|def|)
-  (PROG (|def'| |name| |slamOrLam| |args| |body| |body'|)
-    (DECLARE (SPECIAL |$reportOptimization|))
-    (RETURN
-      (PROGN
-        (COND
-          (|$reportOptimization|
-              (|sayBrightlyI|
-                  (|bright| "Original LISP code:"))
-              (|pp| |def|)))
-        (SPADLET |def'| (|optimize| (COPY |def|)))
-        (COND
-          (|$reportOptimization|
-              (|sayBrightlyI|
-                  (|bright| "Optimized LISP code:"))
-              (|pp| |def'|)
-              (|sayBrightlyI|
-                  (|bright| "Final LISP code:"))))
-        (SPADLET |name| (CAR |def'|))
-        (SPADLET |slamOrLam| (CAADR |def'|))
-        (SPADLET |args| (CADADR |def'|))
-        (SPADLET |body| (CAR (CDDADR |def'|)))
-        (SPADLET |body'|
-                 (|optimizeFunctionDef,removeTopLevelCatch| |body|))
-        (CONS |name|
-              (CONS (CONS |slamOrLam| (CONS |args| (CONS |body'| NIL)))
-                    NIL))))))
-
-;optimize x ==
-;  (opt x; x) where
-;    opt x ==
-;      atom x => nil
-;      (y:= first x)='QUOTE => nil
-;      y='CLOSEDFN => nil
-;      y is [["XLAM",argl,body],:a] =>
-;        optimize rest x
-;        argl = "ignore" => RPLAC(first x,body)
-;        if not (LENGTH argl<=LENGTH a) then
-;          SAY '"length mismatch in XLAM expression"
-;          PRETTYPRINT y
-;        RPLAC(first x,optimize optXLAMCond SUBLIS(pairList(argl,a),body))
-;      atom y =>
-;        optimize rest x
-;        y="true" => RPLAC(first x,'(QUOTE (QUOTE T)))
-;        y="false" => RPLAC(first x,nil)
-;      if first y="IF" then (RPLAC(first x,optIF2COND y); y:= first x)
-;      op:= GET(subrname first y,"OPTIMIZE") =>
-;        (optimize rest x; RPLAC(first x,FUNCALL(op,optimize first x)))
-;      RPLAC(first x,optimize first x)
-;      optimize rest x
-
-(DEFUN |optimize,opt| (|x|)
-  (PROG (|ISTMP#1| |ISTMP#2| |argl| |ISTMP#3| |body| |a| |y| |op|)
-    (RETURN
-      (SEQ (IF (ATOM |x|) (EXIT NIL))
-           (IF (BOOT-EQUAL (SPADLET |y| (CAR |x|)) 'QUOTE) (EXIT NIL))
-           (IF (BOOT-EQUAL |y| 'CLOSEDFN) (EXIT NIL))
-           (IF (AND (PAIRP |y|)
-                    (PROGN
-                      (SPADLET |ISTMP#1| (QCAR |y|))
-                      (AND (PAIRP |ISTMP#1|)
-                           (EQ (QCAR |ISTMP#1|) 'XLAM)
-                           (PROGN
-                             (SPADLET |ISTMP#2| (QCDR |ISTMP#1|))
-                             (AND (PAIRP |ISTMP#2|)
-                                  (PROGN
-                                    (SPADLET |argl| (QCAR |ISTMP#2|))
-                                    (SPADLET |ISTMP#3|
-                                     (QCDR |ISTMP#2|))
-                                    (AND (PAIRP |ISTMP#3|)
-                                     (EQ (QCDR |ISTMP#3|) NIL)
-                                     (PROGN
-                                       (SPADLET |body|
-                                        (QCAR |ISTMP#3|))
-                                       'T)))))))
-                    (PROGN (SPADLET |a| (QCDR |y|)) 'T))
-               (EXIT (SEQ (|optimize| (CDR |x|))
-                          (IF (BOOT-EQUAL |argl| '|ignore|)
-                              (EXIT (RPLAC (CAR |x|) |body|)))
-                          (IF (NULL (<= (LENGTH |argl|) (LENGTH |a|)))
-                              (SEQ (SAY
-                                                                         "length mismatch in XLAM expression")
-                                   (EXIT (PRETTYPRINT |y|)))
-                              NIL)
-                          (EXIT (RPLAC (CAR |x|)
-                                       (|optimize|
-                                        (|optXLAMCond|
-                                         (SUBLIS
-                                          (|pairList| |argl| |a|)
-                                          |body|))))))))
-           (IF (ATOM |y|)
-               (EXIT (SEQ (|optimize| (CDR |x|))
-                          (IF (BOOT-EQUAL |y| '|true|)
-                              (EXIT (RPLAC (CAR |x|) '''T)))
-                          (EXIT (IF (BOOT-EQUAL |y| '|false|)
-                                    (EXIT (RPLAC (CAR |x|) NIL)))))))
-           (IF (BOOT-EQUAL (CAR |y|) 'IF)
-               (SEQ (RPLAC (CAR |x|) (|optIF2COND| |y|))
-                    (EXIT (SPADLET |y| (CAR |x|))))
-               NIL)
-           (IF (SPADLET |op| (GETL (|subrname| (CAR |y|)) 'OPTIMIZE))
-               (EXIT (SEQ (|optimize| (CDR |x|))
-                          (EXIT (RPLAC (CAR |x|)
-                                       (FUNCALL |op|
-                                        (|optimize| (CAR |x|))))))))
-           (RPLAC (CAR |x|) (|optimize| (CAR |x|)))
-           (EXIT (|optimize| (CDR |x|)))))))
-
-(DEFUN |optimize| (|x|) (PROGN (|optimize,opt| |x|) |x|)) 
-
-;
-;subrname u ==
-;  IDENTP u => u
-;  COMPILED_-FUNCTION_-P u or MBPIP u => BPINAME u
-;  nil
-
-(DEFUN |subrname| (|u|)
-  (COND
-    ((IDENTP |u|) |u|)
-    ((OR (COMPILED-FUNCTION-P |u|) (MBPIP |u|)) (BPINAME |u|))
-    ('T NIL)))
-
 ;optCatch (x is ["CATCH",g,a]) ==
 ;  $InteractiveMode => x
 ;  atom a => a
@@ -1543,17 +1349,17 @@
 ;    )
 ;
 
-(EVALANDFILEACTQ
-    (REPEAT (IN |x|
-                '((|call| |optCall|) (SEQ |optSEQ|) (EQ |optEQ|)
-                  (MINUS |optMINUS|) (QSMINUS |optQSMINUS|) (- |opt-|)
-                  (LESSP |optLESSP|) (SPADCALL |optSPADCALL|)
-                  (|\|| |optSuchthat|) (CATCH |optCatch|)
-                  (COND |optCond|) (|mkRecord| |optMkRecord|)
-                  (RECORDELT |optRECORDELT|)
-                  (SETRECORDELT |optSETRECORDELT|)
-                  (RECORDCOPY |optRECORDCOPY|)))
-            (MAKEPROP (CAR |x|) 'OPTIMIZE (CADR |x|))))
+;(EVALANDFILEACTQ
+;    (REPEAT (IN |x|
+;                '((|call| |optCall|) (SEQ |optSEQ|) (EQ |optEQ|)
+;                  (MINUS |optMINUS|) (QSMINUS |optQSMINUS|) (- |opt-|)
+;                  (LESSP |optLESSP|) (SPADCALL |optSPADCALL|)
+;                  (|\|| |optSuchthat|) (CATCH |optCatch|)
+;                  (COND |optCond|) (|mkRecord| |optMkRecord|)
+;                  (RECORDELT |optRECORDELT|)
+;                  (SETRECORDELT |optSETRECORDELT|)
+;                  (RECORDCOPY |optRECORDCOPY|)))
+;            (MAKEPROP (CAR |x|) 'OPTIMIZE (CADR |x|))))
 
 \end{chunk}
 \eject