Remove more pamphlets

1 files changed, 0 insertions, 2015 deletions

diff --git a/src/interp/vmlisp.lisp.pamphlet b/src/interp/vmlisp.lisp.pamphlet
deleted file mode 100644
index 086c82f7..00000000
--- a/src/interp/vmlisp.lisp.pamphlet
+++ /dev/null
@@ -1,2015 +0,0 @@
-%% Oh Emacs, this is a -*- Lisp -*- file despite apperance.
-\documentclass{article}
-\usepackage{axiom}
-
-\title{\File{src/interp/vmlisp.lisp} Pamphlet}
-\author{Lars Ericson, Barry Trager, Martial Schor, Timothy Daly}
-
-\begin{document}
-\maketitle
-
-\begin{abstract}
-\end{abstract}
-
-\tableofcontents
-\eject
-
-
-\section{License}
-
-<<license>>=
-;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
-;; All rights reserved.
-;;
-;; Redistribution and use in source and binary forms, with or without
-;; modification, are permitted provided that the following conditions are
-;; met:
-;;
-;;     - Redistributions of source code must retain the above copyright
-;;       notice, this list of conditions and the following disclaimer.
-;;
-;;     - Redistributions in binary form must reproduce the above copyright
-;;       notice, this list of conditions and the following disclaimer in
-;;       the documentation and/or other materials provided with the
-;;       distribution.
-;;
-;;     - Neither the name of The Numerical ALgorithms Group Ltd. nor the
-;;       names of its contributors may be used to endorse or promote products
-;;       derived from this software without specific prior written permission.
-;;
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
-;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
-;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
-;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
-;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
-;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
-;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
-;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
-;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
-;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-@
-
-
-\section{The [[VMLISP]] package}
-
-This is the package that originally contained the \Tool{VMLisp} macros
-but in fact contains macros to support several other lisps. It
-is essentially the place where most of the macros to support
-idioms from prior ports (like [[rdefiostream]] and [[fileactq]])
-
-The content of [[VMLISP]] was moved to [[BOOT]].
-
-\section{The StringImage Fix}
-
-In GCL 2.5 there is a bug in the write-to-string function.
-It should respect *print-escape* but it does not. That is,
-\begin{verbatim}
-
-In GCL 2.4.1:
-(setq *print-escape* nil)
-(write-to-string '|a|) ==> "a"
-
-In GCL 2.5:
-(setq *print-escape* nil)
-(write-to-string '|a|) ==> "|a|"
-
-\end{verbatim}
-The form2LispString function uses stringimage and fails.
-The princ-to-string function assumes *print-escape* is nil
-and works properly.
-
-<<stringimage fix>>=
-;(define-function 'prin2cvec #'write-to-string)
-(define-function 'prin2cvec #'princ-to-string)
-;(define-function 'stringimage #'write-to-string)
-(define-function 'stringimage #'princ-to-string)
-
-@
-
-
-<<*>>=
-
-(IMPORT-MODULE "boot-pkg")
-
-;      VM LISP EMULATION PACKAGE
-;      Lars Ericson, Barry Trager, Martial Schor, tim daly, LVMCL, et al
-;      IBM Thomas J. Watson Research Center
-;      Summer, 1986
-;  see /spad/daly.changes
-
-; This emulation package version is written for Symbolics Common Lisp.
-; Emulation commentary refers to LISP/VM, IBM Program Number 5798-DQZ,
-; as described in the LISP/VM User's Guide, document SH20-6477-1.
-; Main comment section headings refer to sections in the User's Guide.
-
-; If you are using this, you are probably in Common Lisp, yes?
-
-(in-package "BOOT")
-
-;; DEFVARS
-
-(defvar *comp370-apply* nil "function (name def) for comp370 to apply")
-
-(defvar curinstream (make-synonym-stream '*standard-input*))
-
-(defvar curoutstream (make-synonym-stream '*standard-output*))
-
-(defvar *embedded-functions* nil)
-
-(defvar errorinstream (make-synonym-stream '*terminal-io*))
-
-(defvar erroroutstream (make-synonym-stream '*terminal-io*))
-
-(defvar *fileactq-apply* nil "function to apply in fileactq")
-
-(defvar *lam-name* nil "name to be used by lam macro if non-nil")
-
-(defvar macerrorcount 0  "Put some documentation in here someday")
-
-(defvar *read-place-holder* (make-symbol "%.EOF")
-   "default value returned by read and read-line at end-of-file")
-
-;; DEFMACROS
-
-
-(defmacro absval (x)
- `(abs ,x))
-
-#-:CCL
-(defmacro add1 (x)
- `(1+ ,x))
-
-(defmacro assemble (&rest ignore) 
- (declare (ignore ignore))
-  nil)
-
-(defmacro applx (&rest args)
- `(apply ,@args))
-
-#-(or LispM Lucid :CCL)
-(defmacro assq (a b)
- `(assoc ,a ,b :test #'eq))
-
-#+:CCL
-(defmacro assq (a b) `(atsoc ,a ,b))
-
-#-:CCL
-(defmacro bintp (n)
- `(typep ,n 'bignum))
-#+:CCL
-(defun bintp (n) (and (integerp n) (not (fixp n))))
-
-(defmacro |char| (x)
-  (if (and (consp x) (eq (car x) 'quote)) (character (cadr x))
-    `(character ,x)))
-
-(defmacro closedfn (form)
- `(function ,form))
-
-(defmacro |copyList| (x) 
- `(copy-list ,x))
-
-(defmacro create-sbc (x) x)  ;a no-op for common lisp
-
-(defmacro cvecp (x)
- `(stringp ,x))
-
-(defmacro dcq (&rest args)
- (cons 'setqp args))
-
-#-:CCL
-(defmacro difference (&rest args)
- `(- ,@args))
-
-(defmacro dsetq (&whole form pattern exp)
- (dodsetq form pattern exp))
-
-(defmacro ecq (&rest args)
- (cons 'eqq args))
-
-;;def needed to prevent recursion in def of eqcar
-(eval-when 
- #+:common-lisp (:compile-toplevel :load-toplevel :execute)
- #-:common-lisp (compile load eval)
- (defun equable (x) 
-   (or (null x) 
-       (and (consp x) (eq (car x) 'quote) 
-	    (symbolp (cadr x))))))
-
-#-:CCL
-(defmacro eqcar (x y)
- (let ((test
-        (cond
-         ((equable y) 'eq)
-	 ((integerp y) 'i=)
-	 ('eql))))
-  (if (atom x)
-   `(and (consp ,x) (,test (qcar ,x) ,y))
-    (let ((xx (gensym)))
-     `(let ((,xx ,x))
-       (and (consp ,xx) (,test (qcar ,xx) ,y)))))))
-
-(defmacro eqq (pattern exp)
- `(,(ecqexp pattern nil) ,exp))
-
-(defmacro |equal| (x y)
- `(equalp ,x ,y))
-
-(defmacro evalandfileactq (name &optional (form name))
- `(eval-when 
-   #+:common-lisp (:load-toplevel :execute)
-   #-:common-lisp (eval load)
-   ,form))  
-
-(defmacro exit (&rest value)
- `(return-from seq ,@value))
-
-(defmacro fetchchar (x i)
- `(char ,x ,i))
-
-#-:CCL  ;; fixp in ccl tests for fixnum
-(defmacro fixp (x)
- `(integerp ,x))
-
-#-:CCL
-(defmacro greaterp (&rest args)
- `(> ,@args))
-
-(defmacro i= (x y) ;; integer equality
-  (if (typep y 'fixnum)
-      (let ((gx (gensym)))
-	`(let ((,gx ,x))
-	   (and (typep ,gx 'fixnum) (eql (the fixnum ,gx) ,y))))
-    (let ((gx (gensym)) (gy (gensym)))
-      `(let ((,gx ,x) (,gy ,y))
-	 (cond ((and (typep ,gx 'fixnum) (typep ,gy 'fixnum))
-		(eql (the fixnum ,gx) (the fixnum ,gy)))
-	       ((eql (the integer ,gx) (the integer,gy))))))))
-
-(defmacro |idChar?| (x)
- `(or (alphanumericp ,x) (member ,x '(#\? #\% #\' #\!) :test #'char=)))
- 
-(defmacro identp (x) 
- (if (atom x)
-  `(and ,x (symbolp ,x))
-   (let ((xx (gensym)))
-    `(let ((,xx ,x))
-      (and ,xx (symbolp ,xx))))))
-
-(defmacro ifcar (x)
-  (if (atom x)
-      `(and (consp ,x) (qcar ,x))
-    (let ((xx (gensym)))
-      `(let ((,xx ,x))
-	 (and (consp ,xx) (qcar ,xx))))))
-
-(defmacro ifcdr (x)
-  (if (atom x)
-      `(and (consp ,x) (qcdr ,x))
-    (let ((xx (gensym)))
-      `(let ((,xx ,x))
-	 (and (consp ,xx) (qcdr ,xx))))))
-
-(defmacro intp (x)
- `(integerp ,x))
-
-(defmacro lam (&rest body)
- (list 'quote (*lam (copy-tree body))))
-
-(defmacro lastnode (l)
- `(last ,l))
-
-(defmacro lastpair (l)
- `(last ,l))
-
-#-:CCL
-(defmacro lessp (&rest args)
- `(< ,@args))
-
-(defmacro lintp (n)
- `(typep ,n 'bignum))
-
-(defmacro makestring (a) a)
-
-(defmacro mapelt (f vec)
- `(map 'vector ,f ,vec))
-
-(defmacro maxindex (x)
- `(the fixnum (1- (the fixnum (length ,x)))))
-
-#-(or LispM Lucid :CCL)
-(defmacro memq (a b)
- `(member ,a ,b :test #'eq))
-
-#-:CCL
-(defmacro minus (x)
- `(- ,x))
-
-(defmacro mrp (x)
- `(special-form-p ,x))
-
-(defmacro namederrset (id iexp &rest item)
- (declare (ignore item))
-  `(catch ,id ,iexp))
-
-(defmacro ne (a b) `(not (equal ,a ,b)))
-
-;;; This may need adjustment in CCL where NEQ means (NOT (EQUAL ..)))
-#-:CCL
-(defmacro neq (a b) `(not (eq ,a ,b)))
-
-#-:CCL
-(defmacro nreverse0 (x)
-  (if (atom x)
-      `(if (atom ,x) ,x (nreverse ,x))
-    (let ((xx (gensym)))
-      `(let ((,xx ,x))
-	 (if (atom ,xx) ,xx (nreverse ,xx))))))
-
-(defmacro nump (n)
- `(numberp ,n))
-
-(defmacro |opOf| (x) ;(if (atom x) x (qcar x))
-  (if (atom x)
-      `(if (consp ,x) (qcar ,x) ,x)
-    (let ((xx (gensym)))
-      `(let ((,xx ,x))
-	 (if (consp ,xx) (qcar ,xx) ,xx)))))
-
-(defmacro oraddtempdefs (filearg)
- `(eval-when 
-   #+:common-lisp (:compile-toplevel)
-   #-:common-lisp (compile)
-   (load ,filearg)))
-
-(defmacro pairp (x)
- `(consp ,x)) 
-
-#-:CCL
-(defmacro plus (&rest args)
- `(+ ,@ args))
-
-; (defmacro qassq (a b)
-;  `(assoc ,a ,b :test #'eq))
-(defmacro qassq (a b) `(assq ,a ,b))
-
-#-:CCL
-(defmacro qcar (x)
- `(car (the cons ,x)))
-#-:CCL
-(defmacro qcdr (x)
- `(cdr (the cons ,x)))
-
-#-:CCL
-(defmacro qcaar (x)
- `(car (the cons (car (the cons ,x)))))
-#-:CCL
-(defmacro qcadr (x)
- `(car (the cons (cdr (the cons ,x)))))
-#-:CCL
-(defmacro qcdar (x)
- `(cdr (the cons (car (the cons ,x)))))
-#-:CCL
-(defmacro qcddr (x)
- `(cdr (the cons (cdr (the cons ,x)))))
-
-(defmacro qcaaar (x)
- `(car (the cons (car (the cons (car (the cons ,x)))))))
-(defmacro qcaadr (x)
- `(car (the cons (car (the cons (cdr (the cons ,x)))))))
-(defmacro qcadar (x)
- `(car (the cons (cdr (the cons (car (the cons ,x)))))))
-(defmacro qcaddr (x)
- `(car (the cons (cdr (the cons (cdr (the cons ,x)))))))
-(defmacro qcdaar (x)
- `(cdr (the cons (car (the cons (car (the cons ,x)))))))
-(defmacro qcdadr (x)
- `(cdr (the cons (car (the cons (cdr (the cons ,x)))))))
-(defmacro qcddar (x)
- `(cdr (the cons (cdr (the cons (car (the cons ,x)))))))
-(defmacro qcdddr (x)
- `(cdr (the cons (cdr (the cons (cdr (the cons ,x)))))))
-
-(defmacro qcaaaar (x)
- `(car (the cons (car (the cons (car (the cons (car (the cons ,x)))))))))
-(defmacro qcaaadr (x)
- `(car (the cons (car (the cons (car (the cons (cdr (the cons ,x)))))))))
-(defmacro qcaadar (x)
- `(car (the cons (car (the cons (cdr (the cons (car (the cons ,x)))))))))
-(defmacro qcaaddr (x)
- `(car (the cons (car (the cons (cdr (the cons (cdr (the cons ,x)))))))))
-(defmacro qcadaar (x)
- `(car (the cons (cdr (the cons (car (the cons (car (the cons ,x)))))))))
-(defmacro qcadadr (x)
- `(car (the cons (cdr (the cons (car (the cons (cdr (the cons ,x)))))))))
-(defmacro qcaddar (x)
- `(car (the cons (cdr (the cons (cdr (the cons (car (the cons ,x)))))))))
-(defmacro qcadddr (x)
- `(car (the cons (cdr (the cons (cdr (the cons (cdr (the cons ,x)))))))))
-(defmacro qcdaaar (x)
- `(cdr (the cons (car (the cons (car (the cons (car (the cons ,x)))))))))
-(defmacro qcdaadr (x)
- `(cdr (the cons (car (the cons (car (the cons (cdr (the cons ,x)))))))))
-(defmacro qcdadar (x)
- `(cdr (the cons (car (the cons (cdr (the cons (car (the cons ,x)))))))))
-(defmacro qcdaddr (x)
- `(cdr (the cons (car (the cons (cdr (the cons (cdr (the cons ,x)))))))))
-(defmacro qcddaar (x)
- `(cdr (the cons (cdr (the cons (car (the cons (car (the cons ,x)))))))))
-(defmacro qcddadr (x)
- `(cdr (the cons (cdr (the cons (car (the cons (cdr (the cons ,x)))))))))
-(defmacro qcdddar (x)
- `(cdr (the cons (cdr (the cons (cdr (the cons (car (the cons ,x)))))))))
-(defmacro qcddddr (x)
- `(cdr (the cons (cdr (the cons (cdr (the cons (cdr (the cons ,x)))))))))
-
-(defmacro qcsize (x)
- `(the fixnum (length (the simple-string ,x))))
-
-(defmacro qeqq (pattern exp)
- `(,(ecqexp pattern 1) ,exp))
-
-(defmacro qlength (a)
- `(length ,a))
-
-; (defmacro qmemq (a b)
-; `(member ,a ,b :test #'eq))
-(defmacro qmemq (a b) `(memq ,a ,b))
-
-(defmacro qrefelt (vec ind)
- `(svref ,vec ,ind))
-
-(defmacro qrplaca (a b)
- `(rplaca (the cons ,a) ,b))
-
-(defmacro qrplacd (a b)
- `(rplacd (the cons ,a) ,b))
-
-(defmacro qrplq (&whole form pattern exp)
- (if (or (consp pattern) (simple-vector-p pattern))
-  `(,(rcqexp pattern) ,exp)
-   (macro-invalidargs 'qrplq form "form must be updateable.")))
-
-(defmacro qsadd1 (x)
- `(the fixnum (1+ (the fixnum ,x))))
-
-(defmacro qsdec1 (x)
- `(the fixnum (1- (the fixnum ,x))))
-
-(defmacro qsdifference (x y)
- `(the fixnum (- (the fixnum ,x) (the fixnum ,y))))
-
-(defmacro qsetq (&whole form pattern exp)
- (declare (ignore form))
-  `(,(dcqexp pattern '=) ,exp))
-
-(defmacro qsetrefv (vec ind val)
- `(setf (svref ,vec (the fixnum ,ind)) ,val))
-
-(defmacro qsetvelt (vec ind val)
- `(setf (svref ,vec (the fixnum ,ind)) ,val))
-
-(defmacro qsetvelt-1 (vec ind val)
- `(setf (svref ,vec (the fixnum (1- (the fixnum ,ind)))) ,val))
-
-(defmacro qsgreaterp (a b)
- `(> (the fixnum ,a) (the fixnum ,b)))
-
-(defmacro qsinc1 (x)
- `(the fixnum (1+ (the fixnum ,x))))
-
-(defmacro qsleftshift (a b)
- `(the fixnum (ash (the fixnum ,a) (the fixnum ,b))))
-
-(defmacro qslessp (a b)
- `(< (the fixnum ,a) (the fixnum ,b)))
-
-(defmacro qsmax (x y)
- `(the fixnum (max (the fixnum ,x) (the fixnum ,y))))
-
-(defmacro qsmin (x y)
- `(the fixnum (min (the fixnum ,x) (the fixnum ,y))))
-
-(defmacro qsminus (x)
- `(the fixnum (minus (the fixnum ,x))))
-
-(defmacro qsminusp (x)
- `(minusp (the fixnum ,x)))
-
-(defmacro qsoddp (x)
- `(oddp (the fixnum ,x)))
-
-(defmacro qsabsval (x)
-  `(the fixnum (abs (the fixnum ,x))))
-
-(defmacro qsplus (x y)
- `(the fixnum (+ (the fixnum ,x) (the fixnum ,y))))
-
-(defmacro qssub1 (x)
- `(the fixnum (1- (the fixnum ,x))))
-
-(defmacro qstimes (x y)
- `(the fixnum (* (the fixnum ,x) (the fixnum ,y))))
-
-(defmacro qstringlength (x)
- `(the fixnum (length (the simple-string ,x))))
-
-(defmacro qszerop (x)
- `(zerop (the fixnum ,x)))
-
-(defmacro qvelt (vec ind)
- `(svref ,vec (the fixnum ,ind)))
-
-(defmacro qvelt-1 (vec ind)
- `(svref ,vec (the fixnum (1- (the fixnum ,ind)))))
-
-(defmacro qvmaxindex (x)
- `(the fixnum (1- (the fixnum (length (the simple-vector ,x))))))
-
-(defmacro qvsize (x)
- `(the fixnum (length (the simple-vector ,x))))
-
-; #-:CCL
-; (defmacro refvecp (v)
-;  `(typep ,v '(vector t)))
-; #+:CCL
-; (defun refvecp (v) (and (vectorp v) (not (stringp v))))
-(defmacro refvecp (v) `(simple-vector-p ,v))
-
-(defmacro resetq (a b)
- `(prog1 ,a (setq ,a ,b)))
-
-(defmacro rnump (n)
- `(floatp ,n))
-
-(defmacro rplq (&whole form exp pattern)
- (if (or (consp pattern) (simple-vector-p pattern))
-  `(,(rcqexp pattern) ,exp)
-   (macro-invalidargs 'rplq form "form must be updateable.")))
-
-(defmacro rvecp (v)
- `(typep ,v '(vector float)))
-
-(defmacro setandfileq (id item)
- `(eval-when
-   #+:common-lisp (:load-toplevel :execute)
-   #-:common-lisp (eval load) 
-   (setq ,id ,item)
-   (lam\,fileactq ',id (list 'setq ',id (list 'quote ,id)))))
-
-#-:CCL
-(defmacro setelt (vec ind val)
- `(setf (elt ,vec ,ind) ,val))
-
-(defmacro setqp (&whole form pattern exp)
- (declare (ignore form))
-  `(,(dcqexp pattern '=) ,exp))
-
-(defmacro seq (&rest form)
-  (let* ((body (reverse form))
-         (val `(return-from seq ,(pop body))))
-    (nsubstitute '(progn) nil body) ;don't treat NIL as a label
-    `(block seq (tagbody ,@(nreverse body) ,val))))
-
-(defmacro sfp (x)
- `(special-form-p ,x))
-
-#-:CCL
-(defmacro sintp (n)
- `(typep ,n 'fixnum))
-#+:CCL
-(defmacro sintp (n)
-  `(fixp ,n))
-
-#-:CCL
-(defmacro smintp (n)
- `(typep ,n 'fixnum))
-#+:CCL
-(defmacro smintp (n)
-  `(fixp ,n))
-
-(defmacro stringlength (x)
- `(length (the string ,x)))
-
-(defmacro subrp (x)
- `(compiled-function-p ,x))
-
-#-:CCL
-(defmacro sub1 (x)
- `(1- ,x))
-
-(defmacro throw-protect (exp1 exp2)
- `(unwind-protect ,exp1 ,exp2))
-
-#-:CCL
-(defmacro times (&rest args)
- `(* ,@args))
-
-(defmacro vec-setelt (vec ind val)
- `(setf (svref ,vec ,ind) ,val))
-
-; #-:CCL
-; (defmacro vecp (v)
-;  `(typep ,v '(vector t)))
-; #+:CCL
-; (defun vecp (v) (and (vectorp v) (not (stringp v))))
-(defmacro vecp (v) `(simple-vector-p ,v))
-
-#-:CCL
-(defmacro zero? (x)
-  `(and (typep ,x 'fixnum) (zerop (the fixnum ,x))))
-#+:CCL
-(defmacro zero? (x) `(zerop ,x))
-
-;; defuns
-
-(eval-when 
- #+:common-lisp (:compile-toplevel :load-toplevel :execute)
- #-:common-lisp (compile load eval)
- (defun define-function (f v)
-   (setf (symbol-function f) v)))
-
-(define-function 'tempus-fugit #'get-internal-run-time)
-
-(defun $TOTAL-ELAPSED-TIME ()
-   (list (get-internal-run-time) (get-internal-real-time)))
-
-#-(OR IBCL KCL :CMULISP :CCL)
-(defun $TOTAL-GC-TIME () (list 0 0))
-
-#+:CCL
-(defun $TOTAL-GC-TIME () (list (gctime) (gctime)))
-
-#+IBCL
-(defun $TOTAL-GC-TIME (&aux (gcruntime (system:gbc-time-report)))
-  (list gcruntime gcruntime))
-
-#+KCL
-(defun $TOTAL-GC-TIME (&aux (gcruntime (system:gbc-time)))
-  (if (minusp gcruntime)
-      (setq gcruntime (system:gbc-time 0)))
-  (list gcruntime gcruntime))
-
-;;; note: this requires the 11/9/89 gc patch in code/lisp/daly/misc.lisp
-#+:cmulisp
-(defun $TOTAL-GC-TIME ()
- (declare (special ext::*gc-runtime* ext::*gc-walltime*))
- (list ext::*gc-runtime* ext::*gc-walltime*))
-
-; 7.0 Macros
-
-; 7.2 Creating Macro Expressions
-
-; 5.2 Functions
-
-; 5.2.2 Lambda Expressions
-
-(defun *LAM (body)
-  (cond  ((NOT (ISQUOTEDP (first BODY))) (cons 'LAMBDA BODY))
-         ((LET* ((BV (DEQUOTE (first BODY)))
-                 (CONTROL (QUOTESOF (first BODY)))
-                 (BODY (cdr BODY))
-                 (ARGS (GENSYM))
-                 (INNER-FUNC (or *lam-name* (gentemp))))
-            (COMP370 (LIST INNER-FUNC `(LAMBDA ,BV . ,BODY)))
-            `(MLAMBDA ,ARGS
-                      (CONS (QUOTE ,INNER-FUNC)
-                            (WRAP (cdr ,ARGS) ',CONTROL)))))))
-
-(defun WRAP (LIST-OF-ITEMS WRAPPER)
- (prog nil
-  (COND ((OR (NOT (PAIRP LIST-OF-ITEMS)) (not WRAPPER))
-         (RETURN LIST-OF-ITEMS))
-        ((NOT (consp WRAPPER))
-         (SETQ WRAPPER (LOTSOF WRAPPER))))
-  (RETURN
-    (CONS (if (first WRAPPER)
-              `(,(first WRAPPER) ,(first LIST-OF-ITEMS))
-              (first LIST-OF-ITEMS))
-          (WRAP (cdr LIST-OF-ITEMS) (cdr WRAPPER))))))
-
-(defun ISQUOTEDP (bv)
-  (COND ((NOT (consp BV)) NIL)
-        ((EQ (first BV) 'QUOTE))
-        ((AND (consp (first BV)) (EQ (QCAAR BV) 'QUOTE)))
-        ((ISQUOTEDP (cdr BV)))))
-
-(defun QUOTESOF (BV)
-  (COND ((NOT (consp BV)) NIL)
-      ((EQ (first BV) 'QUOTE) 'QUOTE)
-      ((CONS (COND ((NOT (consp (first BV))) nil)
-                   ((EQ (QCAAR BV) 'QUOTE) 'QUOTE)
-                   (T NIL))
-             (QUOTESOF (cdr BV))))))
-
-(defun DEQUOTE (BV)
-  (COND ((NOT (consp BV)) BV)
-        ((EQ 'QUOTE (first BV)) (second BV))
-        ((CONS (if (EQ 'QUOTE (IFCAR (CAR BV))) (CADAR BV) (first BV))
-               (DEQUOTE (cdr BV))))))
-
-(defun lotsof (&rest items)
-  (setq items (copy-list items))
-  (nconc items items))
-
-; 7.4 Using Macros
-
-; Beats me how to simulate macro expansion "in the environment of sd"...:
-
-(defun MDEF (arg item &optional sd)
- (declare (ignore sd))
-  (macroexpand `(,arg ,item)))
-
-(define-function 'MDEFX #'MDEF)
-
-; 8.0 Operator Definition and Transformation
-
-; 8.1 Definition and Transformation Operations
-
-(defun COMP370 (fnlist)
-  (cond ((atom (car fnlist)) (list (COMPILE1 fnlist)))
-        (t (MAPCAR #'(lambda (x) (COMPILE1 x)) fnlist))))
-
-#+:CCL (proclaim '(special *vars* *decl*)) ;; declare not handled right
-
-(defun COMPILE1 (fn)
-  (let* (nargs
-         (fname (car fn))
-         (lamda (cadr fn))
-         (ltype (car lamda))
-         *vars* *decl* args
-         (body (cddr lamda)))
-    (declare (special *vars* *decl*))
-    (if (eq ltype 'LAM)
-        (let ((*lam-name* (intern (concat fname "\,LAM"))))
-          (setq lamda (eval lamda) ltype (car lamda) body (cddr lamda))))
-    (let ((dectest (car body)))
-      (if (and (eqcar dectest 'declare) (eqcar (cadr dectest) 'special))
-	  (setq *decl* (cdr (cadr dectest)) body (cdr body))))
-    (setq args (remove-fluids (cadr lamda)))
-    (cond ((and (eq ltype 'lambda) (simple-arglist args)) (setq nargs args))
-          (t (setq nargs (gensym))
-     #+LispM (setq body `((dsetq ,args (copy-list ,nargs)) ,@body))
-     #-LispM (setq body `((dsetq ,args  ,nargs) ,@body))
-             (cond ((eq ltype 'lambda) (setq nargs `(&rest ,nargs &aux ,@*vars*)))
-                   ((eq ltype 'mlambda)
-                    (setq nargs `(&whole ,nargs &rest ,(gensym) &aux ,@*vars*)))
-                   (t (error "bad function type")))))
-    (cond (*decl* (setq body (cons `(declare (special ,@ *decl*)) body))))
-    (setq body
-          (cond ((eq ltype 'lambda) `(defun ,fname ,nargs . ,body))
-                ((eq ltype 'mlambda) `(defmacro ,fname ,nargs . ,body))))
-    (if *COMP370-APPLY* (funcall *COMP370-APPLY* fname body))
-
-    body))
-
-(defun simple-arglist (arglist)
-  (or (null arglist)
-      (and (consp arglist) (null (cdr (last arglist)))
-           (every #'symbolp arglist))))
-
-(defun remove-fluids (arglist &aux f v) ;updates specials *decl* and *vars*
-  (declare (special *decl* *vars*))
-   (cond ((null arglist) arglist)
-         ((symbolp arglist) (push arglist *vars*) arglist)
-                ;if atom but not symbol, ignore value
-         ((atom arglist) (push (setq arglist (gentemp)) *vars*) arglist)
-         ((and (setq f (car arglist))
-               (eq f 'fluid)
-               (listp (cdr arglist))
-               (setq v (cadr arglist))
-               (identp v)
-               (null (cddr arglist)))
-          (push v *decl*)
-          (push v *vars*)
-          v)
-         (t (cons (remove-fluids (car arglist))
-                  (remove-fluids (cdr arglist))))))
-
-(define-function 'KOMPILE #'COMP370)
-
-; 9.4 Vectors and Bpis
-
-(defun IVECP (x) (and (vectorp x) (subtypep (array-element-type x) 'integer)))
-
-(defun mbpip (item) (and (symbolp item) ;cannot know a compiled macro in CLISP
-                         (compiled-function-p (macro-function item))))
-
-(defun FBPIP (item) (or (compiled-function-p item)
-			(and (symbolp item) (fboundp item)
-			     (not (macro-function item))
-			     (compiled-function-p (symbol-function item)))))
-
-; 9.5 Identifiers
-
-#-:CCL
-(defun gensymp (x) (and (symbolp x) (null (symbol-package x))))
-
-(defun digitp (x)
-  (or (and (symbolp x) (digitp (symbol-name x)))
-      (and (characterp x) (digit-char-p x))
-      (and (stringp x) (= (length x) 1) (digit-char-p (char x 0)))))
-
-(defun dig2fix (x)
-  (if (symbolp x)
-    (digit-char-p (char (symbol-name x) 0))
-    (digit-char-p x)))
-
-#-:CCL
-(defun LN (x) (LOG x))
-#-:CCL
-(defun LOG2 (x) (LOG x 2.0))
-(defun |log| (x) (LOG x 10.0))
-
-; 9.13 Streams
-
-#+Lucid
-(defun IS-CONSOLE (stream)
-    (and (streamp stream)
-         (or (not (consp (pathname-directory stream)))
-             (equal (qcar (pathname-directory stream)) "dev")
-	     (null (pathname-name stream) ))))
-
-#+KCL
-(defun IS-CONSOLE (stream)
-  (and (streamp stream) (output-stream-p stream)
-       (eq (system:fp-output-stream stream)
-           (system:fp-output-stream *terminal-io*))))
-
-#-(OR Lucid KCL :CCL)
-(defun IS-CONSOLE (stream) (EQ stream *terminal-io*))
-
-; 10.0 Control Structures
-
-; 10.8.4 Auxiliary Operators
-
-(defun nilfn (&rest ignore)
- (declare (ignore ignore)) 
- ())
-
-; 11.0 Operations on Identifiers
-
-; 11.1 Creation
-
-(defun upcase (l)
-  (cond ((stringp l) (string-upcase l))
-        ((identp l) (intern (string-upcase (symbol-name l))))
-        ((characterp l) (char-upcase l))
-        ((atom l) l)
-        (t (mapcar #'upcase l))))
-
-(define-function 'U-CASE #'upcase)
-(define-function 'LC2UC #'upcase)
-
-(defun downcase (l)
-  (cond ((stringp l) (string-downcase l))
-        ((identp l) (intern (string-downcase (symbol-name l))))
-        ((characterp l) (char-downcase L))
-        ((atom l) l)
-        (t (mapcar #'downcase l))))
-
-(define-function 'L-CASE #'downcase)
-
-; 11.2 Accessing
-
-;; note it is important that PNAME returns nil not an error for non-symbols
-(defun pname (x)
-  (cond ((symbolp x) (symbol-name x))
-	((characterp x) (string x))
-	(t nil)))
-
-;; property lists in vmlisp are alists
-(defun PROPLIST (x)
-  (if (symbolp x)
-#-:CCL
-   (plist2alist (symbol-plist x))
-#+:CCL
-   (plist2alist (plist x))
-    nil))
-
-(defun plist2alist (x)
-  (if (null x) 
-      nil
-      (cons (cons (first x) (second x)) (plist2alist (cddr x)))))
-
-(eval-when
- #+:common-lisp (:compile-toplevel :load-toplevel :execute)
- #-:common-lisp (compile load eval)
- (progn
-   (defun put (sym ind val) (setf (get sym ind) val))
-   
-   (define-function 'MAKEPROP #'put)))
-
-; 12.0 Operations on Numbers
-
-; 12.1 Conversion
-
-(define-function 'FIX #'truncate)
-(define-function 'INT2RNUM #'float)
-
-; 12.2 Predicates
-
-;(define-function 'lessp #'<)
-
-;(define-function 'greaterp #'>)
-
-
-;(define-function 'fixp #'integerp)
-
-; 12.3 Computation
-
-;(define-function 'add1 #'1+)
-;(define-function 'sub1 #'1-)
-;(define-function 'plus #'+)
-;(define-function 'times #'*)
-;(define-function 'difference #'-)
-;(define-function 'minus #'-)
-;(define-function 'absval #'abs)
-
-(defun QUOTIENT (x y)
-  (cond ((or (floatp x) (floatp y)) (/ x y))
-        (t (truncate x y))))
-
-(define-function 'vm/ #'quotient)
-
-#-:CCL
-(defun REMAINDER (x y)
-  (if (and (integerp x) (integerp y))
-      (rem x y)
-      (- x (* y (QUOTIENT x y)))))
-
-#-:CCL
-(defun DIVIDE (x y)
-  (if (and (integerp x) (integerp y))
-      (multiple-value-list (truncate x y))
-      (list (QUOTIENT x y) (REMAINDER x y))))
-
-(defun QSQUOTIENT (a b) (the fixnum (truncate (the fixnum a) (the fixnum b))))
-
-(defun QSREMAINDER (a b) (the fixnum (rem (the fixnum a) (the fixnum b))))
-
-
-;(defun IFCAR (x) (if (consp x) (car (the cons x))))
-
-;(defun IFCDR (x) (if (consp x) (cdr (the cons x))))
-
-; 13.3 Updating
-
-
-(defun RPLPAIR (pair1 pair2)
-  (RPLACA pair1 (CAR pair2))
-  (RPLACD pair1 (CDR pair2)) pair1)
-
-(defun RPLNODE (pair1 ca2 cd2)
- (RPLACA pair1 ca2) 
- (RPLACD pair1 cd2) pair1)
-
-; 14.0 Operations on Lists
-
-; 14.1 Creation
-
-(defun VEC2LIST (vec) (coerce vec 'list))
-
-; note default test for union, intersection and set-difference is eql
-;; following are defined so as to preserve ordering in union.lisp
-;;(defun SETDIFFERENCE (l1 l2) (set-difference l1 l2 :test #'equalp))
-;;(defun SETDIFFERENCEQ (l1 l2) (set-difference l1 l2 :test #'eq))
-;;(defun |union| (l1 l2) (union l1 l2 :test #'equalp))
-;;(defun UNIONQ (l1 l2) (union l1 l2 :test #'eq))
-;;(defun |intersection| (l1 l2) (intersection l1 l2 :test #'equalp))
-;;(defun INTERSECTIONQ (l1 l2) (intersection l1 l2 :test #'eq))
-(defun |member| (item sequence)
-   (cond ((symbolp item) (member item sequence :test #'eq))
-	 ((stringp item) (member item sequence :test #'equal))
-	 ((and (atom item) (not (arrayp item))) (member item sequence))
-	 (T (member item sequence :test #'equalp))))
-
-(defun |remove| (list item &optional (count 1))
-  (if (integerp count)
-      (remove item list :count count :test #'equalp)
-      (remove item list :test #'equalp)))
-
-(defun REMOVEQ (list item &optional (count 1))
-  (if (integerp count)
-      (remove item list :count count :test #'eq)
-      (remove item list :test #'eq)))
-
-; 14.2 Accessing
-
-;(define-function 'lastnode #'last)
-;(define-function 'lastpair #'last)
-(defun |last| (x) (car (lastpair x)))
-
-; 14.3 Searching
-
-#+:CCL (DEFMACRO |assoc| (X Y) `(ASSOC** ,X ,Y))
-#-:CCL
-(DEFUN |assoc| (X Y)
-  "Return the pair associated with key X in association list Y."
-  ; ignores non-nil list terminators
-  ; ignores non-pair a-list entries
-  (cond ((symbolp X)
-	 (PROG NIL
-	       A  (COND ((ATOM Y) (RETURN NIL))
-			((NOT (consp (CAR Y))) )
-			((EQ (CAAR Y) X) (RETURN (CAR Y))) )
-	       (SETQ Y (CDR Y))
-	       (GO A)))
-	((or (numberp x) (characterp x))
-	 (PROG NIL
-	       A  (COND ((ATOM Y) (RETURN NIL))
-			((NOT (consp (CAR Y))) )
-			((EQL (CAAR Y) X) (RETURN (CAR Y))) )
-	       (SETQ Y (CDR Y))
-	       (GO A)))
-	(t
-	 (PROG NIL
-	       A  (COND ((ATOM Y) (RETURN NIL))
-			((NOT (consp (CAR Y))) )
-			((EQUAL (CAAR Y) X) (RETURN (CAR Y))) )
-	       (SETQ Y (CDR Y))
-	       (GO A)))))
-; 14.5 Updating
-
-(defun NREMOVE (list item &optional (count 1))
-  (if (integerp count)
-      (delete item list :count count :test #'equal)
-      (delete item list :test #'equal)))
-
-(defun NREMOVEQ (list item &optional (count 1))
-  (if (integerp count)
-      (delete item list :count count )
-      (delete item list )))
-
-(defun EFFACE (item list) (delete item list :count 1 :test #'equal))
-
-(defun NCONC2 (x y) (NCONC x y)) ;NCONC with exactly two arguments
-
-; 14.6 Miscellaneous
-
-(defun QSORT (l)
- (declare (special sortgreaterp))
-  (NREVERSE (sort (copy-seq l) SORTGREATERP)))
-
-(defun SORTBY (keyfn l)
- (declare (special sortgreaterp))
-  (nreverse (sort (copy-seq l) SORTGREATERP :key keyfn)))
-
-; 16.0 Operations on Vectors
-
-; 16.1 Creation
-
-(defun MAKE-VEC (n) (make-array n))
-
-(define-function 'GETREFV #'make-array)
-
-@
-Waldek Hebisch points out that, in the expression:
-\begin{verbatim}
-  reduce(+,[1.0/i for i in 1..20000])
-\end{verbatim}
-a significant amount of the time is spent in this function.
-A special case was added to significantly reduce the execution time.
-This was a problem in GCL as of 2.6.8pre and may be fixed in future
-releases. If it is fixed then the original definition, which was
-\begin{verbatim}
-(defun LIST2VEC (list) (coerce list 'vector))
-\end{verbatim}
-can be restored.
-<<*>>=
-(defun LIST2VEC (list)
- (if (consp list)
-  (let* ((len (length list))
-         (vec (make-array len)))
-    (dotimes (i len)
-     (setf (aref vec i) (pop list)))
-    vec)
-  (coerce list 'vector)))
-
-(define-function 'LIST2REFVEC #'LIST2VEC)
-
-; 16.2 Accessing
-
-
-;(define-function 'FETCHCHAR #'char)
-
-;; Oddly, LENGTH is more efficient than LIST-LENGTH in CCL, since the former
-;; is compiled and the latter is byte-coded!
-(defun size (l) 
-  (cond ((vectorp l) (length l))
-#+:CCL  ((stringp l) (length l)) ;; Until ACN fixes his lisp -> C translator.
-#-:CCL  ((consp l)   (list-length l))
-#+:CCL  ((consp l)   (length l))
-	(t           0)))
-
-(define-function 'MOVEVEC #'replace)
-
-; 17.0 Operations on Character and Bit Vectors
-
-(defun charp (a) (or (characterp a)
-                     (and (identp a) (= (length (symbol-name a)) 1))))
-
-(defun NUM2CHAR (n) (code-char n))
-
-(defun CHAR2NUM (c) (char-code (character c)))
-
-(defun CGREATERP (s1 s2) (string> (string s1) (string s2)))
-
-(define-function 'STRGREATERP #'CGREATERP)
-
-; 17.1 Creation
-
-
-#-AKCL
-(defun concat (a b &rest l)
-   (let ((type (cond ((bit-vector-p a) 'bit-vector) (t 'string))))
-      (cond ((eq type 'string)
-	     (setq a (string a) b (string b))
-             (if l (setq l (mapcar #'string l)))))
-      (if l (apply #'concatenate type a b l)
-	(concatenate type a b))) )
-#+AKCL
-(defun concat (a b &rest l)
-  (if (bit-vector-p a)
-      (if l (apply #'concatenate 'bit-vector a b l)
-	(concatenate 'bit-vector a b))
-    (if l (apply #'system:string-concatenate a b l)
-      (system:string-concatenate a b))))
-
-(define-function 'strconc #'concat)
-
-(defun make-cvec (sint) (make-array sint :fill-pointer 0 :element-type 'character))
-
-;(define-function 'CVECP #'stringp)
-
-(define-function 'getstr #'make-cvec)
-
-(defun make-full-cvec (sint &optional (char #\space))
-  (make-string sint :initial-element (character char)))
-
-(define-function 'getfullstr #'make-full-cvec)
-
-; 17.2 Accessing
-
-(defun QENUM (cvec ind) (char-code (char cvec ind)))
-
-(defun QESET (cvec ind charnum)
-  (setf (char cvec ind) (code-char charnum)))
-
-(defun string2id-n (cvec sint)
-  (if (< sint 1)
-      nil
-      (let ((start (position-if-not #'(lambda (x) (char= x #\Space)) cvec)))
-        (if start
-            (let ((end (or (position #\Space cvec :start start) (length cvec))))
-              (if (= sint 1)
-                  (intern (subseq cvec start end))
-                  (string2id-n (subseq cvec end) (1- sint))))
-            0))))
-
-(defun substring (cvec start length)
-  (setq cvec (string cvec))
-  (if length (subseq cvec start (+ start length)) (subseq cvec start)))
-
-; 17.3 Searching
-
-;;- (defun strpos (what in start dontcare)
-;;-    (setq what (string what) in (string in))
-;;-    (if dontcare (progn (setq dontcare (character dontcare))
-;;- 		       (search what in :start2 start
-;;- 			       :test #'(lambda (x y) (or (eql x dontcare)
-;;- 							 (eql x y)))))
-;;-                 (search what in :start2 start)))
-
-(defun strpos (what in start dontcare)
-   (setq what (string what) in (string in))
-   (if dontcare (progn (setq dontcare (character dontcare))
-		       (search what in :start2 start
-			       :test #'(lambda (x y) (or (eql x dontcare)
-							 (eql x y)))))
-                (if (= start 0)
-                   (search what in)
-                   (search what in :start2 start))
-   ))
-
-; In the following, table should be a string:
-
-(defun strposl (table cvec sint item)
-  (setq cvec (string cvec))
-  (if (not item)
-      (position table cvec :test #'(lambda (x y) (position y x)) :start sint)
-      (position table cvec :test-not #'(lambda (x y) (position y x)) :start sint)))
-
-; 17.4 Updating operators
-
-(defun suffix (id cvec)
-  "Suffixes the first char of the symbol or char ID to the string CVEC,
-    changing CVEC."
-  (unless (characterp id) (setq id (elt (string id) 0)))
-  (cond ((array-has-fill-pointer-p cvec)
-	 (vector-push-extend id cvec)
-	 cvec)
-	((adjustable-array-p cvec)
-	 (let ((l (length cvec)))
-	   (adjust-array cvec (1+ l))
-	   (setf (elt cvec l) id)
-	   cvec))
-	(t (concat cvec id))))
-
-(defun setsize (vector size) (adjust-array vector size))
-
-(define-function 'changelength #'setsize)
-
-(defun trimstring (x) x)
-
-;;-- (defun rplacstr (cvec1 start1 length1 cvec2
-;;--                        &optional (start2 0) (length2 nil)
-;;--                        &aux end1 end2)
-;;--   (setq cvec2 (string cvec2))
-;;--   (if (null start1) (setq start1 0))
-;;--   (if (null start2) (setq start2 0))
-;;--   (if (null length1) (setq length1 (- (length cvec1) start1)))
-;;--   (if (null length2) (setq length2 (- (length cvec2) start2)))
-;;--   (if (numberp length1) (setq end1 (+ start1 length1)))
-;;--   (if (numberp length2) (setq end2 (+ start2 length2)))
-;;--   (if (/= length1 length2)
-;;--       (concatenate 'string (subseq cvec1 0 start1)
-;;--                            (subseq cvec2 start2 end2)
-;;--                            (subseq cvec1 end1))
-;;--       (replace cvec1 cvec2 :start1 start1 :end1 end1
-;;--              :start2 start2 :end2 end2)))
-
-; The following version has been provided to avoid reliance on the
-; Common Lisp concatenate and replace functions. These built-in Lisp
-; functions would probably end up doing the character-by-character
-; copying shown here, but would also need to cope with generic sorts
-; of sequences and unwarranted keyword generality
-
-(defun rplacstr (cvec1 start1 length1 cvec2
-                       &optional start2 length2
-                       &aux end1 end2)
-  (setq cvec2 (string cvec2))
-  (if (null start1) (setq start1 0))
-  (if (null start2) (setq start2 0))
-  (if (null length1) (setq length1 (- (length cvec1) start1)))
-  (if (null length2) (setq length2 (- (length cvec2) start2)))
-  (setq end1 (+ start1 length1))
-  (setq end2 (+ start2 length2))
-  (if (= length1 length2)
-      (do ()
-          ((= start1 end1) cvec1)
-          (setf (aref cvec1 start1) (aref cvec2 start2))
-          (setq start1 (1+ start1))
-          (setq start2 (1+ start2)))
-      (let* ((l1 (length cvec1))
-	     (r (make-string (- (+ l1 length2) length1)))
-             (i 0))
-         (do ((j 0 (1+ j)))
-             ((= j start1))
-             (setf (aref r i) (aref cvec1 j))
-             (setq i (1+ i)))
-         (do ((j start2 (1+ j)))
-             ((= j end2))
-             (setf (aref r i) (aref cvec2 j))
-             (setq i (1+ i)))
-         (do ((j end1 (1+ j)))
-             ((= j l1))
-             (setf (aref r i) (aref cvec1 j))
-             (setq i (1+ i)))
-         r)
-  ))
-
-; 19.0 Operations on Arbitrary Objects
-
-; 19.1 Creating
-
-(defun MSUBST (new old tree) (subst new old tree :test #'equal))
-; note subst isn't guaranteed to copy
-(defun |nsubst| (new old tree) (nsubst new old tree :test #'equal))
-(define-function 'MSUBSTQ #'subst) ;default test is eql
-(define-function 'SUBSTQ #'SUBST) ;default test is eql subst is not guaranteed to copy
-
-(defun copy (x) (copy-tree x)) ; not right since should descend vectors
-
-(defun eqsubstlist (new old list) (sublis (mapcar #'cons old new) list))
-
-; Gen code for SETQP expr
-
-(eval-when 
- #+:common-lisp (:compile-toplevel :load-toplevel :execute)
- #-:common-lisp (compile load eval)
- (defun DCQEXP (FORM EQTAG)
-  (PROG (SV pvl avl CODE)
-        (declare (special pvl avl))
-        (setq SV (GENSYM))
-        (setq CODE (DCQGENEXP SV FORM EQTAG NIL))
-        (RETURN
-          `(LAMBDA (,sv)
-             (PROG ,pvl
-                   ,@code
-                   (RETURN 'true)
-                BAD (RETURN NIL) ) ))))
-)
-; Generate Expr code for DCQ
-(eval-when 
- #+:common-lisp (:compile-toplevel :load-toplevel :execute)
- #-:common-lisp (compile load eval)
- (defun DCQGENEXP (SV FORM EQTAG QFLAG)
-  (PROG (D A I L C W)
-        (declare (special pvl avl))
-    (COND ((EQ FORM SV) (RETURN NIL))
-          ((IDENTP FORM) (RETURN `((setq ,form ,sv)) ))
-          ((simple-vector-p FORM)
-           (RETURN (SEQ
-             (setq L (length FORM))
-             (IF (EQ L 0)
-                 (RETURN (COND ((NULL QFLAG)
-                                `((cond ((not (simple-vector-p ,sv)) (go bad))))))))
-             (setq I (1- L))
-         LP  (setq A (elt FORM I))
-             (COND ((AND (NULL W) (OR (consp A) (simple-vector-p A)))
-                    (COND ((consp AVL) (setq W (car (RESETQ AVL (cdr AVL)))))
-                          ((setq PVL (CONS (setq W (GENSYM)) PVL))))))
-             (setq C (NCONC (COND ((IDENTP A) `((setq ,a (ELT ,sv ,i))))
-                                  ((OR (consp A) (simple-vector-p A))
-                                   `((setq ,w (ELT ,sv ,i))
-                                     ,@(dcqgenexp w a eqtag qflag))))
-                            C))
-             (if (EQ I 0) (GO RET))
-             (setq I (1- I))
-             (GO LP)
-         RET (if W (setq AVL (CONS W AVL)))
-             (COND ((NULL QFLAG)
-                    `((COND ((OR (NOT (simple-vector-p ,sv)) (< (length ,sv) ,l))
-                             (GO BAD)))
-                      ,@c))
-                   ('T C)))))
-          ((NOT (consp FORM)) (RETURN NIL))
-          ((AND EQTAG (EQ (car FORM) EQTAG))
-           (RETURN
-             (COND
-               ((OR (NOT (EQ 3 (LENGTH FORM))) (NOT (IDENTP (car (setq FORM (cdr FORM))))))
-                (MACRO-INVALIDARGS 'DCQ\/QDCQ FORM (MAKESTRING "invalid pattern.")))
-               (`((setq ,(car form) ,sv)  ,@(DCQGENEXP SV (CADR FORM) EQTAG QFLAG)))))))
-    (setq A (car FORM))
-    (setq D (cdr FORM))
-    (setq C (COND ((IDENTP A) `((setq ,a (CAR ,sv))))
-                  ((OR (consp A) (simple-vector-p A))
-                   (COND ((AND (NULL D) (IDENTP SV)) )
-                         ((COND ((consp AVL) (setq W (car (RESETQ AVL (cdr AVL)))))
-                                ((setq PVL (CONS (setq W (GENSYM)) PVL)) ) ) ) )
-                   (COND ((AND (consp A) EQTAG (EQ (car A) EQTAG))
-                          (DCQGENEXP (LIST 'CAR SV) A EQTAG QFLAG) )
-                         (`((setq ,(or w sv) (CAR ,sv))
-                            ,@(DCQGENEXP (OR W SV) A EQTAG QFLAG)))))))
-    (setq C (NCONC C (COND ((IDENTP D) `((setq ,d (CDR ,sv))))
-                           ((OR (consp D) (simple-vector-p D))
-                            (COND
-                              ((OR W (IDENTP SV)) )
-                              ((COND ((consp AVL)
-                                      (setq W (car (RESETQ AVL (cdr AVL)))) )
-                                     ((setq PVL (CONS (setq W (GENSYM)) PVL)) ) ) ) )
-                            (COND ((AND (consp D) EQTAG (EQ (car D) EQTAG))
-                                   (DCQGENEXP (LIST 'CDR SV) D EQTAG QFLAG) )
-                                  (`((setq ,(or w sv) (CDR ,sv))
-                                     ,@(DCQGENEXP (OR W SV) D EQTAG QFLAG))))))))
-    (COND (W (setq AVL (CONS W AVL))))
-    (RETURN (COND ((NULL QFLAG) `((COND ((ATOM ,sv) (GO BAD))) ,@c)) (C)))))
-)
-
-
-; 19.3 Searching
-
-; Generate code for EQQ
-
-(eval-when 
- #+:common-lisp (:compile-toplevel :load-toplevel :execute)
- #-:common-lisp (compile load eval)
- (defun ECQEXP (FORM QFLAG)
-  (PROG (SV PVL CODE)
-        (declare (special pvl))
-        (setq SV (GENSYM))
-        (setq CODE (ECQGENEXP SV FORM QFLAG))
-        (RETURN
-              `(LAMBDA (,sv)
-                 (PROG ,pvl
-                       ,@code
-                       (RETURN 'true)
-                    BAD (RETURN NIL) ) ))))
-)
-
-; Generate code for EQQ innards
-
-(eval-when 
- #+:common-lisp (:compile-toplevel :load-toplevel :execute)
- #-:common-lisp (compile load eval)
- (defun ECQGENEXP (SV FORM QFLAG)
-  (PROG (D A I L C W)
-        (declare (special pvl))
-        (COND
-          ((EQ FORM SV) (RETURN NIL))
-          ((OR
-              (IDENTP FORM)
-              (NUMP FORM)
-              (AND (consp FORM) (EQ (qcar FORM) 'QUOTE)))
-           (RETURN
-             `((COND ((NOT (EQ ,form ,sv)) (GO BAD))) )))
-          ((simple-vector-p FORM)
-           (RETURN (SEQ
-              (setq L (length FORM))
-              (if (EQ L 0)
-                  (RETURN
-                    (COND ((NULL QFLAG)
-                           `((COND ((NOT (simple-vector-p ,sv)) (GO BAD))) )))
-                    ))
-              (setq I (1- L))
-           LP (setq A (elt FORM I))
-              (if (AND (NULL W) (OR (consp A) (simple-vector-p A)))
-                  (push (setq W (GENSYM)) PVL))
-              (setq C
-                    (NCONC
-                      (COND
-                        ( (OR
-                            (IDENTP A)
-                            (NUMP A)
-                            (AND (consp A) (EQ (qcar A) 'QUOTE)))
-                         `((COND ( (NOT (EQ ,a (ELT ,sv ,i)))
-                                  (GO BAD) ) ) ) )
-                        ( (OR (consp A) (simple-vector-p A))
-                         `((setq ,w (ELT ,sv ,i))
-                           ,@(ECQGENEXP W A QFLAG))))
-                      C) )
-              (if (EQ I 0) (GO RET) )
-              (setq I (1- I))
-              (GO LP)
-           RET
-              (COND
-                ( (NULL QFLAG)
-                 `((COND ( (OR
-                             (NOT (simple-vector-p ,sv))
-                             (< (length ,sv) ,l))
-                          (GO BAD) ) )
-                   ,@c))
-                ( 'T C ) )) ))
-          ( (NOT (consp FORM))
-           (RETURN NIL) ) )
-        (setq A (car FORM))
-        (setq D (cdr FORM))
-        (if (OR (consp A) (simple-vector-p A) (consp D) (simple-vector-p D))
-           (setq PVL (CONS (setq W (GENSYM)) PVL)))
-        (setq C
-              (COND
-                ( (OR (IDENTP A) (NUMP A) (AND (consp A) (EQ (car A) 'QUOTE)))
-                 `((COND ((NOT (EQ ,a (CAR ,sv))) (GO BAD))) ))
-                ( (OR (consp A) (simple-vector-p A))
-                 `((setq ,w (CAR ,sv))
-                   ,@(ECQGENEXP W A QFLAG)))))
-        (setq C
-              (NCONC
-                C
-                (COND
-                  ( (OR (IDENTP D) (NUMP D) (AND (consp D)
-                                                 (EQ (car D) 'QUOTE)))
-                   `((COND ((NOT (EQ ,d (CDR ,sv))) (GO BAD))) ))
-                  ( (OR (consp D) (simple-vector-p D))
-                   `((setq ,sv (CDR ,sv))
-                     ,@(ECQGENEXP SV D QFLAG))))))
-        (RETURN
-          (COND
-            ( (NULL QFLAG)
-             `((COND ( (ATOM ,sv)
-                      (GO BAD) ) )
-               ,@c))
-            ( 'T
-             C ) )) ) )
-)
-
-; 19.4 Updating
-
-; Generate code for RPLQ exprs
-
-(eval-when 
- #+:common-lisp (:compile-toplevel :load-toplevel :execute)
- #-:common-lisp (compile load eval)
- (defun RCQEXP (FORM)
-    (PROG (SV PVL CODE)
-          (declare (special pvl))
-      (setq SV (GENSYM))
-      (setq CODE (RCQGENEXP SV FORM NIL))
-      (RETURN
-        `(LAMBDA (,sv)
-              (PROG ,pvl
-                ,@code
-                (RETURN 'true)
-            BAD (RETURN NIL) ) ))))
-)
-
-; Generate code for RPLQ expr innards
-
-(eval-when 
- #+:common-lisp (:compile-toplevel :load-toplevel :execute)
- #-:common-lisp (compile load eval)
- (defun RCQGENEXP (SV FORM QFLAG)
-    (PROG (D A I L C W)
-          (declare (special pvl))
-      (COND
-        ( (EQ FORM SV)
-          (RETURN NIL) )
-        ( (simple-vector-p FORM)
-         (RETURN (SEQ
-            (setq L (length FORM))
-            (if (EQ L 0) (RETURN NIL))
-            (setq I (1- L))
-        LP  (setq A (elt FORM I))
-            (COND
-              ( (AND
-                  (NULL W)
-                  (OR (AND (consp A) (NOT (EQ (car A) 'QUOTE)))
-                           (simple-vector-p A)))
-                (setq PVL (CONS (setq W (GENSYM)) PVL)) ) )
-            (setq C
-              (NCONC
-                (COND
-                  ( (OR
-                      (IDENTP A)
-                      (NUMP A)
-                      (AND (consp A) (EQ (car A) 'QUOTE)))
-                    `((SETELT ,sv ,i ,a)))
-                  ( (OR (consp A) (simple-vector-p A))
-                    `((setq ,w (ELT ,sv ,i))
-                      ,@(RCQGENEXP W A QFLAG))))
-                C) )
-            (COND
-              ( (EQ I 0)
-                (GO RET) ) )
-            (setq I (1- I))
-            (GO LP)
-        RET (RETURN
-              (COND
-                ( (NULL QFLAG)
-                  `((COND ( (OR
-                              (NOT (simple-vector-p ,sv))
-                              (< (length ,sv) ,l))
-                            (GO BAD) ) )
-                    ,@c))
-                ( 'T
-                  C ) )) )))
-        ( (NOT (consp FORM))
-          (RETURN NIL) ) )
-      (setq A (car FORM))
-      (setq D (cdr FORM))
-      (cond
-        ( (or (and (consp A) (NOT (EQ (car A) 'QUOTE))) (simple-vector-p A))
-          (setq PVL (CONS (setq W (GENSYM)) PVL)) ) )
-      (setq C
-        (COND
-          ( (OR (IDENTP A) (NUMP A) (AND (consp A) (EQ (car A) 'QUOTE)))
-            `((rplaca ,sv ,a)))
-          ( (OR (consp A) (simple-vector-p A))
-            `((setq ,w (CAR ,sv))
-              ,@(RCQGENEXP W A QFLAG)))))
-      (setq C
-        (NCONC
-          C
-          (COND
-            ( (OR (IDENTP D) (NUMP D) (AND (consp D) (EQ (car D) 'QUOTE)))
-              `((RPLACD ,sv ,d)))
-            ( (OR (consp D) (simple-vector-p D))
-              `((setq ,sv (CDR ,sv))
-                ,@(RCQGENEXP SV D QFLAG))))))
-      (RETURN
-        (COND
-          ( (NULL QFLAG)
-            `((COND ( (ATOM ,sv)
-                      (GO BAD) ) )
-              ,@c))
-          ( 'T
-            C ) )) ) )
-)
-
-; 22.0 Internal and External Forms
-
-; 23.0 Reading
-
-
-(define-function 'next #'read-char)
-
-; 24.0 Printing
-
-<<stringimage fix>>
-(define-function 'printexp #'princ)
-(define-function 'prin0  #'prin1)
-
-(defun |F,PRINT-ONE| (form &optional (stream *standard-output*))
- (declare (ignore stream))
-    (let ((*print-level* 4) (*print-length* 4))
-       (prin1 form) (terpri)))
-
-(defun prettyprint (x &optional (stream *standard-output*))
-  (prettyprin0 x stream) (terpri stream))
-
-(defun prettyprin0 (x &optional (stream *standard-output*))
-  (let ((*print-pretty* t) (*print-array* t))
-    (prin1 x stream)))
-
-(defun vmprint (x &optional (stream *standard-output*))
-  (prin1 x stream) (terpri stream))
-
-(defun tab (sint &optional (stream t))
-  (format stream "~vT" sint))
-
-; 27.0 Stream I/O
-
-
-; 27.1 Creation
-
-(defun MAKE-INSTREAM (filespec &optional (recnum 0))
- (declare (ignore recnum))
-   (cond ((numberp filespec) (make-synonym-stream '*terminal-io*))
-         ((null filespec) (error "not handled yet"))
-         (t (open (make-input-filename filespec)
-                  :direction :input :if-does-not-exist nil))))
-
-(defun MAKE-OUTSTREAM (filespec &optional (width nil) (recnum 0))
- (declare (ignore width) (ignore recnum))
-   (cond ((numberp filespec) (make-synonym-stream '*terminal-io*))
-         ((null filespec) (error "not handled yet"))
-         (t (open (make-filename filespec) :direction :output))))
-
-(defun MAKE-APPENDSTREAM (filespec &optional (width nil) (recnum 0))
- "fortran support"
- (declare (ignore width) (ignore recnum))
- (cond 
-  ((numberp filespec) (make-synonym-stream '*terminal-io*))
-  ((null filespec) (error "make-appendstream: not handled yet"))
-  ('else (open (make-filename filespec) :direction :output
-          :if-exists :append :if-does-not-exist :create))))
-
-(defun DEFIOSTREAM (stream-alist buffer-size char-position)
- (declare (ignore buffer-size))
-   (let ((mode (or (cdr (assoc 'MODE stream-alist)) 'INPUT))
-         (filename (cdr (assoc 'FILE stream-alist)))
-         (dev (cdr (assoc 'DEVICE stream-alist))))
-      (if (EQ dev 'CONSOLE) (make-synonym-stream '*terminal-io*)
-	(let ((strm (case mode
-			  ((OUTPUT O) (open (make-filename filename)
-					    :direction :output))
-			  ((INPUT I) (open (make-input-filename filename)
-					   :direction :input)))))
-	  (if (and (numberp char-position) (> char-position 0))
-	      (file-position strm char-position))
-	  strm))))
-
-(defun shut (st) (if (is-console st) st
-		   (if (streamp st) (close st) -1)))
-
-(defun EOFP (stream) (null (peek-char nil stream nil nil)))
-
-; 28.0 Key addressed I/O
-
-
-; 46.0 Call tracing
-
-
-(defun EMBEDDED () (mapcar #'car *embedded-functions*))
-
-(defun EMBED (CURRENT-BINDING NEW-DEFINITION)
-  (PROG
-#+:CCL (OP BV BODY OLD-DEF *COMP)
-#-:CCL (OP BV BODY OLD-DEF)
-      (COND
-        ( (NOT (IDENTP CURRENT-BINDING))
-          (SETQ CURRENT-BINDING
-                (error (format nil "invalid argument ~s to EMBED" CURRENT-BINDING))) ) )
-      (SETQ OLD-DEF (symbol-function CURRENT-BINDING))
-      (SETQ NEW-DEFINITION
-        (SETF (symbol-function CURRENT-BINDING)
-          (COND
-            ( (NOT (consp NEW-DEFINITION))
-              NEW-DEFINITION )
-            ( (AND
-                (DCQ (OP BV . BODY) NEW-DEFINITION)
-                (OR (EQ OP 'LAMBDA) (EQ OP 'MLAMBDA)))
-              (COND
-                ( (NOT (MEMQ CURRENT-BINDING (FLAT-BV-LIST BV)))
-                 `(,OP ,BV ((LAMBDA (,CURRENT-BINDING) . ,BODY) ',OLD-DEF))
-                   )
-                ( 'T
-                  NEW-DEFINITION ) ) )
-            ( 'T
-              `((LAMBDA (,CURRENT-BINDING) ,NEW-DEFINITION) ',OLD-DEF)))
-            ) )
-#+:CCL (IF (CONSP NEW-DEFINITION) (SETQ NEW-DEFINITION (CDR NEW-DEFINITION)))
-      (push (LIST CURRENT-BINDING NEW-DEFINITION OLD-DEF) *embedded-functions*)
-      (RETURN CURRENT-BINDING) ) )
-
-(defun UNEMBED (CURRENT-BINDING)
-    (PROG
-#+:CCL  (TMP E-LIST CUR-DEF *COMP)
-#-:CCL  (TMP E-LIST CUR-DEF)
-      (SETQ E-LIST *embedded-functions*)
-      (SETQ CUR-DEF (symbol-function CURRENT-BINDING))
-#+:CCL (IF (CONSP CUR-DEF) (SETQ CUR-DEF (CDR CUR-DEF)))
-      (COND
-        ( (NOT (consp E-LIST))
-          NIL )
-        ( (ECQ ((CURRENT-BINDING CUR-DEF)) E-LIST)
-          (SETF (symbol-function CURRENT-BINDING) (QCADDAR E-LIST))
-          (SETQ *embedded-functions* (QCDR E-LIST))
-          (RETURN CURRENT-BINDING) )
-        ( 'T
-          (SEQ
-            (SETQ TMP E-LIST)
-        LP  (COND
-              ( (NOT (consp (QCDR TMP)))
-                (EXIT NIL) )
-              ( (NULL (ECQ ((CURRENT-BINDING CUR-DEF)) (QCDR TMP)))
-                (SETQ TMP (QCDR TMP))
-                (GO LP) )
-              ( 'T
-                (SETF (symbol-function  CURRENT-BINDING) (QCAR (QCDDADR TMP)))
-                (RPLACD TMP (QCDDR TMP))
-                (RETURN CURRENT-BINDING) ) ) ) ) )
-      (RETURN NIL) ))
-
-(defun FLAT-BV-LIST (BV-LIST)
-  (PROG (TMP1)
-      (RETURN
-        (COND
-          ( (VARP BV-LIST)
-            (LIST BV-LIST) )
-          ( (REFVECP BV-LIST)
-            (FLAT-BV-LIST (VEC2LIST (MAPELT #'FLAT-BV-LIST BV-LIST))) )
-          ( (NOT (consp BV-LIST))
-            NIL )
-          ( (EQ '= (SETQ TMP1 (QCAR BV-LIST)))
-            (FLAT-BV-LIST (QCDR BV-LIST)) )
-          ( (VARP TMP1)
-            (CONS TMP1 (FLAT-BV-LIST (QCDR BV-LIST))) )
-          ( (AND (NOT (consp TMP1)) (NOT (REFVECP TMP1)))
-            (FLAT-BV-LIST (QCDR BV-LIST)) )
-          ( 'T
-            (NCONC (FLAT-BV-LIST TMP1) (FLAT-BV-LIST (QCDR BV-LIST))) ) )) ))
-
-(defun VARP (TEST-ITEM)
-    (COND
-      ( (IDENTP TEST-ITEM)
-        TEST-ITEM )
-      ( (AND
-          (consp TEST-ITEM)
-          (OR (EQ (QCAR TEST-ITEM) 'FLUID) (EQ (QCAR TEST-ITEM) 'LEX))
-          (consp (QCDR TEST-ITEM))
-          (IDENTP (QCADR TEST-ITEM)))
-        TEST-ITEM )
-      ( 'T
-        NIL ) ) )
-
-; 48.0 Miscellaneous CMS Interactions
-
-(defun CurrentTime ()
-  (multiple-value-bind (sec min hour day month year) (get-decoded-time)
-    (format nil "~2,'0D/~2,'0D/~2,'0D~2,'0D:~2,'0D:~2,'0D"
-	    month day (rem year 100) hour min sec)))
-
-(defun $screensize () '(24 80))          ; You tell me!!
-
-; 97.0 Stuff In The Manual But Wierdly Documented
-
-(defun EBCDIC (x) (code-char x))
-
-;; This isn't really compatible but is as close as you can get in common lisp
-;; In place of ((one-of 1 2 3) l)  you should use
-;;   (funcall (one-of 1 2 3) l)
-
-(defun doDSETQ (form pattern exp)
-  (let (PVL AVL)
-    (declare (special PVL AVL))
-    (COND ((IDENTP PATTERN)
-           (LIST 'SETQ PATTERN EXP))
-          ((AND (NOT (consp PATTERN)) (NOT (simple-vector-p PATTERN)))
-           (MACRO-INVALIDARGS 'DSETQ FORM "constant target."))
-          ((let* ((SV (GENSYM))
-                  (E-PART (DCQGENEXP (LIST 'IDENTITY SV) PATTERN '= NIL)))
-             (setq e-part
-                   `(LAMBDA (,sv)
-                      (PROG ,pvl
-                            ,@e-part
-                            (RETURN ,sv)
-                         BAD (RETURN (SETQERROR ,sv)))))
-             `(,e-part ,exp))))))
-
-(defun SETQERROR (&rest FORM) (error (format nil "in destructuring ~S" FORM)))
-
-
-
-
-(defun MACRO-INVALIDARGS (NAME FORM MESSAGE)
-    (setq MACERRORCOUNT  (+ 1 (eval 'MACERRORCOUNT)))
-    (error (format nil 
-                   "invalid arguments to macro ~S with invalid argument ~S, ~S"
-                   name form message)))
-
-(defun MACRO-MISSINGARGS (NAME ignore N)
-  (declare (ignore ignore))
-  (setq MACERRORCOUNT (+ 1 (eval 'MACERRORCOUNT)))
-  (let ((nargs (abs N)))
-    (error (concatenate 'string (symbol-name NAME) " requires "
-			(if (minusp N) "at least " "exactly ")
-			(case nargs (0 "no") (1 "one") (2 "two") (3 "three")
-			      (4 "four") (5 "five") (6 "six")
-			      (t (princ-to-string nargs)))
-			(if (eq nargs 1) " argument," " arguments,")))))
-
-(defun MACERR (MESSAGE &rest ignore)
-  (declare (ignore ignore))
-      (setq MACERRORCOUNT (+ 1 (eval 'MACERRORCOUNT)))
-      (error
-        (LIST "in the expression:" MESSAGE))
-      ())
-
-#+Lucid
-(defun numberofargs (x)
-  (setq x (system::arglist x))
-  (let ((nx (- (length x) (length (memq '&aux x)))))
-    (if (memq '&rest x) (setq nx (- (1- nx))))
-    (if (memq '&optional x) (setq nx (- (1- (abs nx)))))
-    nx))
-
-; 98.0 Stuff Not In The VMLisp Manual That We Like
-
-; A version of GET that works with lists
-
-;; GETL(SYM, KEY)
-;;   KEY: a SYMBOL
-;;   SYM: a SYMBOL or a LIST whose elements are SYMBOLs or LISTs.
-;; Returns:
-;;   when SYM is a SYMBOL, returns the KEY-property of SYM.
-;;   when SYM is a LIST, returns the either the KEY-property of the
-;;   first SYMBOL of SYM that has the KEY-property, or the CDR of the
-;;   first cons-cell whose CAR is EQ KEY.
-(defun getl (sym key)
-  (cond ((symbolp sym)
-	 (get sym key))
-	((null sym) nil)
-	((consp sym)
-	 (let ((sym-1 (car sym)))
-	   (cond ((symbolp sym-1)
-		  (get sym-1 key))
-		 ((and (consp sym-1)
-		       (symbolp (car sym-1)))
-		  (if (eq (car sym-1) key)
-		      (cdr sym-1)
-		    (getl (cdr sym) key))))))))
-		      
-; The following should actually position the cursor at the sint'th line of the screen:
-
-(defun $showline (cvec sint) (terpri) sint (princ cvec))
-
-; 99.0 Ancient Stuff We Decided To Keep
-
-(defun LAM\,EVALANDFILEACTQ (name &optional (form name))
-    (LAM\,FILEACTQ name form) (eval form))
-
-(defun LAM\,FILEACTQ (name form)
-       (if *FILEACTQ-APPLY* (FUNCALL *FILEACTQ-APPLY* name form)))
-
-(defun CALLBELOW (&rest junk) junk) ; to invoke system dependent code?
-
-(define-function 'EVA1 #'eval) ;EVA1 and VMLISP EVAL make lexicals visible
-(define-function 'EVALFUN #'eval) ;EVALFUN drops lexicals before evaluating
-(define-function 'EVA1FUN #'EVALFUN)
-
-(defun PLACEP (item) (eq item *read-place-holder*))
-(defun VMREAD (&optional (st *standard-input*) (eofval *read-place-holder*))
-  (read st nil eofval))
-(defun |read-line| (st &optional (eofval *read-place-holder*))
-  (read-line st nil eofval))
-
-(defun STATEP (item)
- (declare (ignore item))
-   nil) ;no state objects
-(defun FUNARGP (item)
- (declare (ignore item))
-  nil) ;can't tell closures from other functions
-(defun PAPPP (item)
- (declare (ignore item))
-  nil) ;no partial application objects
-
-#+Lucid
-(defun gcmsg (x)
-   (prog1 (not system::*gc-silence*) (setq system::*gc-silence* (not x))))
-#+(OR IBCL KCL)
-(defun gcmsg (x)
-   (prog1 system:*gbc-message* (setq system:*gbc-message* x)))
-#+:cmulisp
-(defun gcmsg (x)
-   (prog1 ext:*gc-verbose* (setq ext:*gc-verbose* x)))
-#+:allegro
-(defun gcmsg (x))
-
-#+Lucid
-(defun reclaim () (system:gc))
-#+:cmulisp
-(defun reclaim () (ext:gc))
-#+(OR IBCL KCL)
-(defun reclaim () (gbc t))
-#+:allegro
-(defun reclaim () (excl::gc t))
-#+:CCL
-(defun reclaim () (gc))
-
-#+Lucid
-(defun BPINAME (func)
-  (if (functionp func)
-      (if (symbolp func) func
-	(let ((name (svref func 0)))
-	  (if (and (consp name) (eq (car name) 'SYSTEM::NAMED-LAMBDA))
-	      (cadr name)
-	    name)) )))
-
-#+(OR IBCL KCL)
-(defun BPINAME (func)
-  (if (functionp func)
-      (cond ((symbolp func) func)
-	    ((and (consp func) (eq (car func) 'LAMBDA-BLOCK))
-	      (cadr func))
-	    ((compiled-function-p func)
-	     (system:compiled-function-name func))
-	    ('t func))))
-#+:cmulisp
-(defun BPINAME (func)
- (when (functionp func)
-  (cond
-    ((symbolp func) func)
-    ((and (consp func) (eq (car func) 'lambda)) (second (third func)))
-    ((compiled-function-p func)
-      (system::%primitive header-ref func system::%function-name-slot))
-    ('else func))))
-#+:allegro
-(defun bpiname (func)
- func)
-#+:CCL
-(defun bpiname (x)
-   (if (symbolp x)
-     (intern (symbol-name (symbol-function x)) "BOOT")
-    nil))
-
-#+:SBCL
-(defun BPINAME (x)
-  (multiple-value-bind (l c n)
-   (function-lambda-expression x)
-   (declare (ignore l c))
-   n))
-
-(defun LISTOFQUOTES (bpi)
- (declare (ignore bpi))
-  ())
-
-#+Lucid
-(defun LISTOFFREES (bpi)
-  (if (compiled-function-p bpi)
-      (let ((end (- (lucid::procedure-length bpi) 2)))
-	(do ((i 3 (1+ i))
-	     (ans nil))
-	    ((> i end) ans)
-	    (let ((locexp (svref bpi i)))
-	      (if (symbolp locexp) (push locexp ans)))))))
-
-#-Lucid
-(defun LISTOFFREES (bpi)
- (declare (ignore bpi))
- ())
-
-  
-#+(and :Lucid (not :ibm/370))
-(defun OBEY (S)
-  (system::run-aix-program (make-absolute-filename "/lib/obey")
-		       :arguments	(list "-c" S)))
-#+:cmulisp
-(defun OBEY (S)
-   (ext:run-program (make-absolute-filename "/lib/obey")
-		    (list "-c" S) :input t :output t))
-#+(OR IBCL KCL :CCL)
-(defun OBEY (S) (SYSTEM S))
-
-#+:allegro
-(defun OBEY (S) (excl::run-shell-command s))
-
-(defun RE-ENABLE-INT (number-of-handler) number-of-handler)
-
-
-(defun QUOREM (i j r) ; never used, refed in parini.boot
-  (multiple-value-bind (x y) (truncate i j)
-   (rplaca (the cons r) x) (rplacd (the cons r) y)))
-
-(defun MAKE-BVEC (n)
- (make-array (list n) :element-type 'bit :initial-element 0))
-
-@
-\eject
-\begin{thebibliography}{99}
-\bibitem{1} nothing
-\end{thebibliography}
-\end{document}