From ab8cc85adde879fb963c94d15675783f2cf4b183 Mon Sep 17 00:00:00 2001 From: dos-reis Date: Tue, 14 Aug 2007 05:14:52 +0000 Subject: Initial population. --- src/interp/vmlisp.lisp.pamphlet | 2115 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 2115 insertions(+) create mode 100644 src/interp/vmlisp.lisp.pamphlet (limited to 'src/interp/vmlisp.lisp.pamphlet') 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} + +<>= +;; 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]]) +<<*>>= +<> +(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. + +<>= +;(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 + +<> +(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} -- cgit v1.2.3