aboutsummaryrefslogtreecommitdiff
path: root/src/interp/vmlisp.lisp.pamphlet
diff options
context:
space:
mode:
authordos-reis <gdr@axiomatics.org>2007-08-14 05:14:52 +0000
committerdos-reis <gdr@axiomatics.org>2007-08-14 05:14:52 +0000
commitab8cc85adde879fb963c94d15675783f2cf4b183 (patch)
treec202482327f474583b750b2c45dedfc4e4312b1d /src/interp/vmlisp.lisp.pamphlet
downloadopen-axiom-ab8cc85adde879fb963c94d15675783f2cf4b183.tar.gz
Initial population.
Diffstat (limited to 'src/interp/vmlisp.lisp.pamphlet')
-rw-r--r--src/interp/vmlisp.lisp.pamphlet2115
1 files changed, 2115 insertions, 0 deletions
diff --git a/src/interp/vmlisp.lisp.pamphlet b/src/interp/vmlisp.lisp.pamphlet
new file mode 100644
index 00000000..17b98975
--- /dev/null
+++ b/src/interp/vmlisp.lisp.pamphlet
@@ -0,0 +1,2115 @@
+%% 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]])
+<<*>>=
+<<license>>
+(defpackage "VMLISP"
+ #+:common-lisp (:use "COMMON-LISP-USER" "COMMON-LISP")
+ #-:common-lisp (:use "USER" "SYSTEM" "LISP")
+ (:use "AxiomCore"))
+
+@
+
+We plan to move the content of [[VMLISP]] to [[BOOT]].
+
+
+\subsection{Exported symbols}
+
+
+<<*>>=
+;;; Definitions for package VMLISP of type EXPORT
+(in-package "VMLISP")
+(export
+ '(VMLISP::SINTP VMLISP::$FCOPY
+ VMLISP::PUT VMLISP::PNAME
+ VMLISP::QVELT-1 VMLISP::QSETVELT-1 vmlisp::throw-protect
+ VMLISP::EQCAR
+ VMLISP::DEFIOSTREAM VMLISP::RDEFIOSTREAM VMLISP::MLAMBDA
+ VMLISP::QSLESSP VMLISP::QSDIFFERENCE VMLISP::QSQUOTIENT
+ VMLISP::ERROROUTSTREAM VMLISP::CREATE-SBC VMLISP::LASTPAIR
+ VMLISP::EQSUBSTLIST VMLISP::QCAAAR VMLISP::$TOTAL-ELAPSED-TIME
+ VMLISP::QUOTIENT VMLISP::SORTGREATERP VMLISP::LIBSTREAM-DIRNAME
+ VMLISP::QSETREFV VMLISP::QSTRINGLENGTH VMLISP::EVALFUN
+ VMLISP::QCDAR VMLISP::TEMPUS-FUGIT VMLISP::QSPLUS VMLISP::QSABSVAL
+ VMLISP::QSZEROP VMLISP::QSMIN VMLISP::QSLEFTSHIFT
+ VMLISP::SETDIFFERENCE VMLISP::RPLQ VMLISP::CATCHALL
+ VMLISP::RECOMPILE-DIRECTORY VMLISP::MDEF VMLISP::LINTP
+ VMLISP::NILFN VMLISP::TAB VMLISP::QCDDR VMLISP::IOSTATE
+ VMLISP::SFP VMLISP::NE VMLISP::STRGREATERP VMLISP::|startsId?|
+ VMLISP::USE-VMLISP-SYNTAX VMLISP::RCLASS VMLISP::|idChar?|
+ VMLISP::SEQ VMLISP::FIXP VMLISP::MAKE-CVEC VMLISP::MAKE-BVEC
+ VMLISP::|F,PRINT-ONE| VMLISP::HASHUEQUAL VMLISP::$OUTFILEP
+ VMLISP::TIMES VMLISP::DIFFERENCE VMLISP::MSUBST VMLISP::DIVIDE
+ VMLISP::|remove| VMLISP::GETL VMLISP::QCADAR VMLISP::QCAAAAR
+ VMLISP::RECLAIM VMLISP::ORADDTEMPDEFS VMLISP::NAMEDERRSET
+ VMLISP::TRIMSTRING VMLISP::CURRINDEX VMLISP::EVALANDFILEACTQ
+ VMLISP::LISPLIB VMLISP::FLUID VMLISP::MDEFX VMLISP::COMP370
+ VMLISP::NEQ VMLISP::GETREFV VMLISP::|log| VMLISP::QVSIZE
+ VMLISP::MBPIP VMLISP::RPLNODE VMLISP::QSORT
+ VMLISP::PLACEP VMLISP::RREAD VMLISP::BINTP VMLISP::QSODDP
+ VMLISP::O VMLISP::RVECP VMLISP::CHAR2NUM VMLISP::POPP
+ VMLISP::QCDAADR VMLISP::HKEYS VMLISP::HASHCVEC VMLISP::HASHID
+ VMLISP::REMOVEQ VMLISP::LISTOFFUNCTIONS
+ VMLISP::QCADAAR VMLISP::ABSVAL VMLISP::VMPRINT
+ VMLISP::MAKE-APPENDSTREAM VMLISP::MAKE-INPUT-FILENAME
+ VMLISP::MAKE-INSTREAM VMLISP::HASHTABLEP VMLISP::UPCASE
+ VMLISP::LOADCOND VMLISP::STRPOSL VMLISP::STATEP VMLISP::QCDADR
+ VMLISP::HREMPROP VMLISP::LAM VMLISP::FBPIP VMLISP::NCONC2
+ VMLISP::GETFULLSTR VMLISP::I VMLISP::HREM
+ VMLISP::*LISP-BIN-FILETYPE* VMLISP::INT2RNUM VMLISP::EBCDIC
+ VMLISP::$INFILEP VMLISP::BFP VMLISP::NUMP VMLISP::UNEMBED
+ VMLISP::PAIRP VMLISP::BOOLEANP VMLISP::FIX VMLISP::REMAINDER
+ VMLISP::RE-ENABLE-INT VMLISP::QCAADDR VMLISP::QCDDADR
+ VMLISP::$LISTFILE VMLISP::IVECP VMLISP::LIST2VEC
+ VMLISP::|LAM,FILEACTQ| VMLISP::LISTOFQUOTES
+ VMLISP::$ERASE VMLISP::QSDEC1 VMLISP::QSDIFFERENCE
+ VMLISP::QSSUB1 VMLISP::QCAR VMLISP::EVA1FUN VMLISP::IS-CONSOLE
+ VMLISP::MAKESTRING VMLISP::CUROUTSTREAM VMLISP::QCDDDR
+ VMLISP::QCDADAR VMLISP::MAKE-ABSOLUTE-FILENAME VMLISP::SUFFIX
+ VMLISP::FUNARGP VMLISP::VM/ VMLISP::QRPLACA VMLISP::GGREATERP
+ VMLISP::CGREATERP VMLISP::RNUMP VMLISP::RESETQ VMLISP::QRPLACD
+ VMLISP::SORTBY VMLISP::CVECP VMLISP::SETELT VMLISP::HGET
+ VMLISP::$DIRECTORY-LIST VMLISP::LN VMLISP::|member|
+ VMLISP::$LIBRARY-DIRECTORY-LIST VMLISP::VEC-SETELT
+ VMLISP::QCSIZE VMLISP::QCADDDR VMLISP::RWRITE VMLISP::SUBLOAD
+ VMLISP::STRINGIMAGE VMLISP::$CLEAR VMLISP::|read-line|
+ VMLISP::PROPLIST VMLISP::INTP VMLISP::OUTPUT VMLISP::CONSOLE
+ VMLISP::QCDDDAR VMLISP::ADDOPTIONS VMLISP::$FILETYPE-TABLE
+ VMLISP::QSMINUSP VMLISP::|assoc| VMLISP::SETSIZE VMLISP::QCDR
+ VMLISP::EFFACE VMLISP::COPY VMLISP::DOWNCASE VMLISP::LC2UC
+ VMLISP::EMBED VMLISP::SETANDFILEQ VMLISP::QSMAX
+ VMLISP::LIST2REFVEC VMLISP::MACRO-INVALIDARGS VMLISP::EMBEDDED
+ VMLISP::REFVECP VMLISP::CLOSEDFN VMLISP::MAKE-HASHTABLE
+ VMLISP::MAKE-FILENAME VMLISP::|$defaultMsgDatabaseName|
+ VMLISP::LEXGREATERP
+ VMLISP::IDENTP VMLISP::QSINC1 VMLISP::QESET VMLISP::MRP
+ VMLISP::LESSP VMLISP::RPLPAIR VMLISP::QVELT VMLISP::QRPLQ
+ VMLISP::MACERR VMLISP::*FILEACTQ-APPLY* VMLISP::HPUT*
+ VMLISP::$FILEP VMLISP::MAKE-FULL-CVEC VMLISP::HCLEAR
+ VMLISP::ERRORINSTREAM VMLISP::HPUTPROP
+ VMLISP::STRING2ID-N VMLISP::CALLBELOW VMLISP::BPINAME
+ VMLISP::CHANGELENGTH VMLISP::ECQ VMLISP::OBEY VMLISP::QASSQ
+ VMLISP::DCQ VMLISP::SHUT VMLISP::FILE VMLISP::HPUT
+ VMLISP::MAKEPROP VMLISP::GREATERP VMLISP::MEMQ
+ VMLISP::REROOT VMLISP::DIG2FIX VMLISP::L-CASE
+ VMLISP::TEREAD VMLISP::QSREMAINDER VMLISP::$FINDFILE
+ VMLISP::EQQ VMLISP::PRETTYPRINT VMLISP::HASHEQ VMLISP::LOG2
+ VMLISP::U-CASE VMLISP::NREMOVE VMLISP::QREFELT VMLISP::SIZE
+ VMLISP::EOFP VMLISP::QCDAAR VMLISP::RSHUT VMLISP::ADD1
+ VMLISP::QMEMQ VMLISP::SUBSTRING VMLISP::LOADVOL
+ VMLISP::QSTIMES VMLISP::STRINGLENGTH VMLISP::NEXT
+ VMLISP::DEVICE VMLISP::MAPELT VMLISP::LENGTHOFBPI
+ VMLISP::DIGITP VMLISP::QLENGTH VMLISP::QCAAADR VMLISP::CVEC
+ VMLISP::VEC2LIST VMLISP::MODE VMLISP::MAKE-VEC VMLISP::GCMSG
+ VMLISP::CONCAT VMLISP::$SHOWLINE VMLISP::QCAADR VMLISP::QCDDAR
+ VMLISP::QCDAAAR VMLISP::RDROPITEMS VMLISP::VECP
+ VMLISP::|union| VMLISP::ONE-OF VMLISP::NULLOUTSTREAM
+ VMLISP::QSGREATERP VMLISP::MINUS VMLISP::MAXINDEX
+ VMLISP::GETSTR VMLISP::QCADADR VMLISP::PRIN2CVEC
+ VMLISP::CURRENTTIME VMLISP::$REPLACE VMLISP::UNIONQ
+ VMLISP::NREMOVEQ VMLISP::CURINSTREAM VMLISP::MAKE-OUTSTREAM
+ VMLISP::APPLX VMLISP::LASTNODE VMLISP::SUBSTQ VMLISP::TRUEFN
+ VMLISP::|last| VMLISP::RPLACSTR VMLISP::SETQP VMLISP::QCADDR
+ VMLISP::QCAADAR VMLISP::QCDDAAR VMLISP::|intersection|
+ VMLISP::HASHTABLE-CLASS VMLISP::$CURRENT-DIRECTORY
+ VMLISP::*COMP370-APPLY* VMLISP::QSETVELT VMLISP::MOVEVEC
+ VMLISP::ID VMLISP::DEFINE-FUNCTION VMLISP::MSUBSTQ VMLISP::|nsubst|
+ VMLISP::LISTOFFLUIDS VMLISP::SUB1 VMLISP::NUMBEROFARGS
+ VMLISP::VMREAD VMLISP::SMINTP VMLISP::$SCREENSIZE
+ VMLISP::LISTOFFREES VMLISP::QCDADDR VMLISP::COMPRREAD
+ VMLISP::GENSYMP VMLISP::IFCAR VMLISP::QSETQ
+ VMLISP::QCADDAR VMLISP::*LISP-SOURCE-FILETYPE* VMLISP::KOMPILE
+ VMLISP::INPUT VMLISP::PAPPP VMLISP::UEQUAL VMLISP::COMPRWRITE
+ VMLISP::SUBRP VMLISP::ASSEMBLE VMLISP::|LAM,EVALANDFILEACTQ|
+ VMLISP::|$msgDatabaseName| VMLISP::IFCDR VMLISP::QVMAXINDEX
+ VMLISP::$SPADROOT VMLISP::PRIN0 VMLISP::PRETTYPRIN0
+ VMLISP::STACKLIFO VMLISP::ASSQ VMLISP::PRINTEXP
+ VMLISP::QCDDDDR VMLISP::QSADD1
+ VMLISP::SETDIFFERENCEQ VMLISP::STRPOS VMLISP::CONSTANT
+ VMLISP::QCAAR VMLISP::HCOUNT VMLISP::RCOPYITEMS
+ VMLISP::QSMINUS VMLISP::EVA1 VMLISP::OPTIONLIST
+ VMLISP::NUM2CHAR VMLISP::QENUM VMLISP::QEQQ
+ VMLISP::$TOTAL-GC-TIME VMLISP::CHARP VMLISP::QCADR
+ VMLISP::INTERSECTIONQ VMLISP::DSETQ VMLISP::FETCHCHAR
+ VMLISP::STRCONC VMLISP::MACRO-MISSINGARGS VMLISP::RPACKFILE
+ VMLISP::EXIT VMLISP::PLUS VMLISP::RKEYIDS
+ VMLISP::COMPILE-LIB-FILE VMLISP::RECOMPILE-LIB-FILE-IF-NECESSARY))
+
+@
+
+
+\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)
+
+@
+
+
+<<*>>=
+; 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 "VMLISP")
+
+; #-:common-lisp
+; (setq *features* (adjoin :common-lisp *features*))
+
+;; 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 (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 (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 (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 |startsId?| (x)
+ `(or (alpha-char-p ,x) (member ,x '(#\? #\% #\!) :test #'char=)))
+
+(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
+
+#-(or :CCL (and :Lucid (not :rios)))
+(defun define-function (f v)
+ (setf (symbol-function f) v))
+#+:CCL
+(defun define-function (f v)
+ (setf (symbol-function f) v)
+ (setf (get f 's:newname) 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)))))
+
+#-:CCL
+(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)
+
+#-:CCL
+(defun QUOTIENT (x y)
+ (cond ((or (floatp x) (floatp y)) (lisp:/ x y))
+ (t (truncate x y))))
+#+:CCL
+(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))
+#+:CCL (r (lisp::make-simple-string (- (+ l1 length2) length1)))
+#-:CCL (r (lisp::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 (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 (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 (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 (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 (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 (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) (int-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
+
+; (defun getl (sym key )
+; (cond ((consp sym) (cdr (assoc key sym :test #'eq)))
+; ((symbolp sym) (get sym key))))
+(defun getl (sym key )
+ (cond ((consp sym) (cdr (assq key sym)))
+ ((symbolp sym) (get 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))
+
+(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}