From c6aaf74d20ebe898ec3ebe8839bfca3f5b195814 Mon Sep 17 00:00:00 2001 From: Tim Daly Date: Sat, 25 Apr 2015 08:17:05 -0400 Subject: [PATCH] books/bookvol5 move/collect/reorder algebra support code The Common Lisp Algebra Support chapter contains functions which are used in the algebra. These were collected and reordered by domain. --- books/bookvol5.pamphlet | 2519 ++++++++++++++++++++------------------- books/bookvol9.pamphlet | 4 +- changelog | 6 + patch | 10 +- src/axiom-website/patches.html | 4 + src/interp/vmlisp.lisp.pamphlet | 16 - 6 files changed, 1307 insertions(+), 1252 deletions(-) diff --git a/books/bookvol5.pamphlet b/books/bookvol5.pamphlet index d4b0941..dcb6d1c 100644 --- a/books/bookvol5.pamphlet +++ b/books/bookvol5.pamphlet @@ -45103,6 +45103,178 @@ database format. \end{chunk} \chapter{Special Lisp Functions} +\defun{compiledLookup}{compiledLookup} +\calls{compiledLookup}{isDomain} +\calls{compiledLookup}{NRTevalDomain} +\begin{chunk}{defun compiledLookup} +(defun |compiledLookup| (op sig dollar) + (unless (|isDomain| dollar) (setq dollar (|NRTevalDomain| dollar))) + (|basicLookup| op sig dollar dollar)) + +\end{chunk} + +\defun{basicLookup}{basicLookup} +\calls{basicLookup}{spadcall} +\calls{basicLookup}{hashCode?} +\calls{basicLookup}{opIsHasCat} +\calls{basicLookup}{HasCategory} +\calls{basicLookup}{hashType} +\calls{basicLookup}{hashString} +\calls{basicLookup}{error} +\calls{basicLookup}{vecp} +\calls{basicLookup}{isNewWorldDomain} +\calls{basicLookup}{oldCompLookup} +\calls{basicLookup}{lookupInDomainVector} +\refsdollar{basicLookup}{hashSeg} +\refsdollar{basicLookup}{hashOpSet} +\refsdollar{basicLookup}{hashOpApply} +\refsdollar{basicLookup}{hashOp0} +\refsdollar{basicLookup}{hashOp1} +\begin{chunk}{defun basicLookup} +(defun |basicLookup| (op sig domain dollar) + (let (hashPercent box dispatch lookupFun hashSig val boxval) + (declare (special |$hashSeg| |$hashOpSet| |$hashOpApply| |$hashOp0| + |$hashOp1|)) + (cond + ((vecp domain) + (if (|isNewWorldDomain| domain) + (|oldCompLookup| op sig domain dollar) + (|lookupInDomainVector| op sig domain dollar))) + (t + (setq hashPercent + (if (vecp dollar) + (|hashType| (elt dollar 0) 0) + (|hashType| dollar 0))) + (setq box (cons nil nil)) + (cond + ((null (vecp (setq dispatch (car domain)))) + (|error| '|bad domain format|)) + (t + (setq lookupFun (elt dispatch 3)) + (cond + ((eql (elt dispatch 0) 0) + (setq hashSig + (cond + ((|hashCode?| sig) sig) + ((|opIsHasCat| op) (|hashType| sig hashPercent)) + (t (|hashType| (cons '|Mapping| sig) hashPercent)))) + (when (symbolp op) + (cond + ((eq op '|Zero|) (setq op |$hashOp0|)) + ((eq op '|One|) (setq op |$hashOp1|)) + ((eq op '|elt|) (setq op |$hashOpApply|)) + ((eq op '|setelt|) (setq op |$hashOpSet|)) + (t (setq op (|hashString| (symbol-name op)))))) + (cond + ((setq val + (car + (spadcall (cdr domain) dollar op hashSig box nil lookupFun))) + val) + ((|hashCode?| sig) nil) + ((or (> (|#| sig) 1) (|opIsHasCat| op)) nil) + ((setq boxval + (spadcall (cdr dollar) dollar op + (|hashType| (car sig) hashPercent) + box nil lookupFun)) + (cons #'identity (car boxval))) + (t nil))) + ((|opIsHasCat| op) (|HasCategory| domain sig)) + (t + (when (|hashCode?| op) + (cond + ((eql op |$hashOp1|) (setq op '|One|)) + ((eql op |$hashOp0|) (setq op '|Zero|)) + ((eql op |$hashOpApply|) (setq op '|elt|)) + ((eql op |$hashOpSet|) (setq op '|setelt|)) + ((eql op |$hashSeg|) (setq op 'segment)))) + (cond + ((and (|hashCode?| sig) (eql sig hashPercent)) + (spadcall + (car (spadcall (cdr dollar) dollar op '($) box nil lookupFun)))) + (t + (car + (spadcall (cdr dollar) dollar op sig box nil lookupFun)))))))))))) + +\end{chunk} + +\defun{lookupInDomainVector}{lookupInDomainVector} +\calls{lookupInDomainVector}{basicLookupCheckDefaults} +\calls{lookupInDomainVector}{spadcall} +\begin{chunk}{defun lookupInDomainVector} +(defun |lookupInDomainVector| (op sig domain dollar) + (if (consp domain) + (|basicLookupCheckDefaults| op sig domain domain) + (spadcall op sig dollar (elt domain 1)))) + +\end{chunk} + +\defun{basicLookupCheckDefaults}{basicLookupCheckDefaults} +\calls{basicLookupCheckDefaults}{vecp} +\calls{basicLookupCheckDefaults}{error} +\calls{basicLookupCheckDefaults}{hashType} +\calls{basicLookupCheckDefaults}{hashCode?} +\calls{basicLookupCheckDefaults}{hashString} +\calls{basicLookupCheckDefaults}{spadcall} +\refsdollar{basicLookupCheckDefaults}{lookupDefaults} +\begin{chunk}{defun basicLookupCheckDefaults} +(defun |basicLookupCheckDefaults| (op sig domain dollar) + (declare (ignore domain)) + (let (box dispatch lookupFun hashPercent hashSig) + (declare (special |$lookupDefaults|)) + (setq box (cons nil nil)) + (cond + ((null (vecp (setq dispatch (car dollar)))) + (|error| '|bad domain format|)) + (t + (setq lookupFun (elt dispatch 3)) + (cond + ((eql (elt dispatch 0) 0) + (setq hashPercent + (if (vecp dollar) + (|hashType| (elt dollar 0) 0) + (|hashType| dollar 0))) + (setq hashSig + (if (|hashCode?| sig) + sig + (|hashType| (cons '|Mapping| sig) hashPercent))) + (when (symbolp op) (setq op (|hashString| (symbol-name op)))) + (car (spadcall (cdr dollar) dollar op hashSig + box (null |$lookupDefaults|) lookupFun))) + (t + (car (spadcall (cdr dollar) dollar op sig box + (null |$lookupDefaults|) lookupFun)))))))) + +\end{chunk} + +\defun{oldCompLookup}{oldCompLookup} +\calls{oldCompLookup}{lookupInDomainVector} +\defsdollar{oldCompLookup}{lookupDefaults} +\begin{chunk}{defun oldCompLookup} +(defun |oldCompLookup| (op sig domvec dollar) + (let (|$lookupDefaults| u) + (declare (special |$lookupDefaults|)) + (setq |$lookupDefaults| nil) + (cond + ((setq u (|lookupInDomainVector| op sig domvec dollar)) + u) + (t + (setq |$lookupDefaults| t) + (|lookupInDomainVector| op sig domvec dollar))))) + +\end{chunk} + +\defun{NRTevalDomain}{NRTevalDomain} +\calls{NRTevalDomain}{qcar} +\calls{NRTevalDomain}{eval} +\calls{NRTevalDomain}{evalDomain} +\begin{chunk}{defun NRTevalDomain} +(defun |NRTevalDomain| (form) + (if (and (consp form) (eq (qcar form) 'setelt)) + (|eval| form) + (|evalDomain| form))) + +\end{chunk} + \section{Axiom control structure macros} Axiom used various control structures in the boot code which are not available in Common Lisp. We write some macros here to make the boot @@ -45514,1127 +45686,1120 @@ but the Axiom semantics are not the same. Because Axiom was originally written in Maclisp, then VMLisp, and then Common Lisp some of these old semantics survive. -\section{ApplicationProgramInterface} -\defun{reportinstantiations}{Report what domains get instantiated} -\begin{chunk}{defun reportinstantiations} -(defun reportinstantiations (b) - (setq |$reportInstantiations| b)) -\end{chunk} +%%% A %%% -\section{InputForm} -\defun{unparseInputForm}{unparseInputForm} -This fixes bug 7217. The default title generation is bogus. -This is called from the unparse function in InputForm, bookvol10.3 -Given a form, $u$, we try to recover the input line that created it. - -\defsdollar{unparseInputForm}{InteractiveMode} -\defsdollar{unparseInputForm}{formatSigAsTex} -\begin{chunk}{defun unparseInputForm} -(defun |unparseInputForm| (u) - (let (|$formatSigAsTeX| |$InteractiveMode|) - (declare (special |$formatSigAsTeX| |$InteractiveMode|)) - (setq |$formatSigAsTeX| 1) - (setq |$InteractiveMode| nil) - (|form2StringLocal| u))) +\section{\enspace{}AlgebraicFunction} +\defun{retract}{retract} +\calls{retract}{objMode} +\calls{retract}{objVal} +\calls{retract}{isWrapped} +\calls{retract}{qcar} +\calls{retract}{retract1} +\calls{retract}{mkObj} +\refsdollar{retract}{EmptyMode} +\begin{chunk}{defun retract} +(defun |retract| (object) + (labels ( + (retract1 (object) + (let (type val underDomain objectp) + (declare (special |$SingleInteger| |$Integer| |$NonNegativeInteger| + |$PositiveInteger|)) + (setq type (|objMode| object)) + (cond + ((stringp type) '|failed|) + (t + (setq val (|objVal| object)) + (cond + ((equal type |$PositiveInteger|) (mkObj val |$NonNegativeInteger|)) + ((equal type |$NonNegativeInteger|) (mkObj val |$Integer|)) + ((and (equal type |$Integer|) (typep (|unwrap| val) 'fixnum)) + (mkObj val |$SingleInteger|)) + (t + (cond + ((or (eql 1 (|#| type)) + (and (consp type) (eq (qcar type) '|Union|)) + (and (consp type) (eq (qcar type) '|FunctionCalled|) + (and (consp (qcdr type)) (eq (qcddr type) nil))) + (and (consp type) (eq (qcar type) '|OrderedVariableList|) + (and (consp (qcdr type)) (eq (qcddr type) nil))) + (and (consp type) (eq (qcar type) '|Variable|) + (and (consp (qcdr type)) (eq (qcddr type) nil)))) + (if (setq objectp (|retract2Specialization| object)) + objectp + '|failed|)) + ((null (setq underDomain (|underDomainOf| type))) + '|failed|) + ; try to retract the "coefficients", e.g. P RN -> P I or M RN -> M I + (t + (setq objectp (|retractUnderDomain| object type underDomain)) + (cond + ((not (eq objectp '|failed|)) objectp) + ; see if we can use the retract functions + ((setq objectp (|coerceRetract| object underDomain)) objectp) + ; see if we have a special case here + ((setq objectp (|retract2Specialization| object)) objectp) + (t '|failed|))))))))))) + (let (type val ans) + (declare (special |$EmptyMode|)) + (setq type (|objMode| object)) + (cond + ((stringp type) '|failed|) + ((equal type |$EmptyMode|) '|failed|) + (t + (setq val (|objVal| object)) + (cond + ((and (null (|isWrapped| val)) + (null (and (consp val) (eq (qcar val) 'map)))) + '|failed|) + (t + (cond + ((eq (setq ans (retract1 (mkObj val type))) '|failed|) + ans) + (t + (mkObj (|objVal| ans) (|objMode| ans))))))))))) \end{chunk} -\section{Void} -\defun{voidValue}{voidValue} -\begin{chunk}{defun voidValue} -(defun |voidValue| () "()") +\section{\enspace{}Any} +\defun{spad2BootCoerce}{spad2BootCoerce} +\begin{chunk}{defun spad2BootCoerce} +(defun |spad2BootCoerce| (x source target) + (let (xp) + (cond + ((null (|isValidType| source)) + (|throwKeyedMsg| "%1p is not a valid type." (list source))) + ((null (|isValidType| target)) + (|throwKeyedMsg| "%1p is not a valid type." (list target))) + ((setq xp (|coerceInteractive| (mkObjWrap x source) target)) + (|objValUnwrap| xp)) + (t + (|throwKeyedMsgCannotCoerceWithValue| (|wrap| x) source target))))) \end{chunk} -\section{U8Vector} - -\defmacro{qvlenU8} -\begin{chunk}{defmacro qvlenU8} -(defmacro qvlenU8 (v) - `(length (the (simple-array (unsigned-byte 8) (*)) ,v))) - +\section{ApplicationProgramInterface} +\defun{reportinstantiations}{Report what domains get instantiated} +\begin{chunk}{defun reportinstantiations} +(defun reportinstantiations (b) + (setq |$reportInstantiations| b)) \end{chunk} -\defmacro{eltU8} -\begin{chunk}{defmacro eltU8} -(defmacro eltU8 (v i) - `(aref (the (simple-array (unsigned-byte 8) (*)) ,v) ,i)) - -\end{chunk} +%%% B %%% -\defmacro{seteltU8} -\begin{chunk}{defmacro seteltU8} -(defmacro seteltU8 (v i s) - `(setf (aref (the (simple-array (unsigned-byte 8) (*)) ,v) ,i), s)) +\section{\enspace{}Boolean} +\defun{BooleanEquality}{The Boolean = function support} +\begin{chunk}{defun BooleanEquality 0} +(defun |BooleanEquality| (x y) (if x y (null y))) \end{chunk} -\defun{getRefvU8}{getRefvU8} -\begin{chunk}{defun getRefvU8} -(defun getRefvU8 (n x) - (make-array n :initial-element x :element-type '(unsigned-byte 8))) - -\end{chunk} +%%% C %%% -\section{U16Vector} +\section{\enspace{}Char} -\defmacro{qvlenU16} -\begin{chunk}{defmacro qvlenU16} -(defmacro qvlenU16 (v) - `(length (the (simple-array (unsigned-byte 16) (*)) ,v))) +\defun{upcase}{upcase} +\calls{upcase}{identp} +\begin{chunk}{defun upcase} +(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)))) \end{chunk} -\defmacro{eltU16} -\begin{chunk}{defmacro eltU16} -(defmacro eltU16 (v i) - `(aref (the (simple-array (unsigned-byte 16) (*)) ,v) ,i)) +\defun{downcase}{downcase} +\calls{downcase}{identp} +\begin{chunk}{defun downcase} +(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)))) \end{chunk} -\defmacro{seteltU16} -\begin{chunk}{defmacro seteltU16} -(defmacro seteltU16 (v i s) - `(setf (aref (the (simple-array (unsigned-byte 16) (*)) ,v) ,i), s)) - -\end{chunk} +\section{\enspace{}ComplexDoubleFloatMatrix} -\defun{getRefvU16}{getRefvU16} -\begin{chunk}{defun getRefvU16} -(defun getRefvU16 (n x) - (make-array n :initial-element x :element-type '(unsigned-byte 16))) +\defmacro{make-cdouble-matrix}{ComplexDoubleFloatMatrix function support} +\begin{chunk}{defmacro make-cdouble-matrix} +(defmacro make-cdouble-matrix (n m) + `(make-array (list ,n (* 2 ,m)) :element-type 'double-float)) \end{chunk} -\section{U32Vector} - -\defmacro{qvlenU32} -\begin{chunk}{defmacro qvlenU32} -(defmacro qvlenU32 (v) - `(length (the (simple-array (unsigned-byte 32) (*)) ,v))) +\defmacro{cdaref2}{ComplexDoubleFloatMatrix function support} +\begin{chunk}{defmacro cdaref2} +(defmacro cdaref2 (ov oi oj) + (let ((v (gensym)) + (i (gensym)) + (j (gensym))) + `(let ((,v ,ov) + (,i ,oi) + (,j ,oj)) + (cons + (aref (the (simple-array double-float (* *)) ,v) ,i (* 2 ,j)) + (aref (the (simple-array double-float (* *)) ,v) + ,i (+ (* 2 ,j) 1)))))) \end{chunk} -\defmacro{eltU32} -\begin{chunk}{defmacro eltU32} -(defmacro eltU32 (v i) - `(aref (the (simple-array (unsigned-byte 32) (*)) ,v) ,i)) +\defmacro{cdsetaref2}{ComplexDoubleFloatMatrix function support} +\begin{chunk}{defmacro cdsetaref2} +(defmacro cdsetaref2 (ov oi oj os) + (let ((v (gensym)) + (i (gensym)) + (j (gensym)) + (s (gensym))) + `(let ((,v ,ov) + (,i ,oi) + (,j ,oj) + (,s ,os)) + (setf (aref (the (simple-array double-float (* *)) ,v) ,i (* 2 ,j)) + (car ,s)) + (setf (aref (the (simple-array double-float (* *)) ,v) + ,i (+ (* 2 ,j) 1)) + (cdr ,s)) + ,s))) \end{chunk} -\defmacro{seteltU32} -\begin{chunk}{defmacro seteltU32} -(defmacro seteltU32 (v i s) - `(setf (aref (the (simple-array (unsigned-byte 32) (*)) ,v) ,i), s)) +\defmacro{cdanrows}{ComplexDoubleFloatMatrix function support} +\begin{chunk}{defmacro cdanrows} +(defmacro cdanrows (v) + `(array-dimension (the (simple-array double-float (* *)) ,v) 0)) \end{chunk} -\defun{getRefvU32}{getRefvU32} -\begin{chunk}{defun getRefvU32} -(defun getRefvU32 (n x) - (make-array n :initial-element x :element-type '(unsigned-byte 32))) +\defmacro{cdancols}{ComplexDoubleFloatMatrix function support} +\begin{chunk}{defmacro cdancols} +(defmacro cdancols (v) + `(truncate + (array-dimension (the (simple-array double-float (* *)) ,v) 1) 2)) \end{chunk} -\section{U8Matrix} +\section{\enspace{}ComplexDoubleFloatVector} +Complex Double Float Vectors are simple arrays of lisp double-floats +made available at the Spad language level. Note that these vectors +are 0 based whereas other Spad language vectors are 1-based. +Complex array is implemented as an array of doubles. Each complex number +occupies two positions in the real array. -\defmacro{aref2U8} -\begin{chunk}{defmacro aref2U8} -(defmacro aref2U8 (v i j) - `(aref (the (simple-array (unsigned-byte 8) (* *)) ,v) ,i ,j)) +\defmacro{make-cdouble-vector}{ComplexDoubleFloatVector Qnew function support} +\begin{chunk}{defmacro make-cdouble-vector} +(defmacro make-cdouble-vector (n) + `(make-array (list (* 2 ,n)) :element-type 'double-float)) \end{chunk} -\defmacro{setAref2U8} -\begin{chunk}{defmacro setAref2U8} -(defmacro setAref2U8 (v i j s) - `(setf (aref (the (simple-array (unsigned-byte 8) (* *)) ,v) ,i ,j), s)) +\defmacro{cdelt}{ComplexDoubleFloatVector Qelt1 function support} +\begin{chunk}{defmacro cdelt} +(defmacro CDELT(ov oi) + (let ((v (gensym)) + (i (gensym))) + `(let ((,v ,ov) + (,i ,oi)) + (cons + (aref (the (simple-array double-float (*)) ,v) (* 2 ,i)) + (aref (the (simple-array double-float (*)) ,v) (+ (* 2 ,i) 1)))))) \end{chunk} -\defmacro{anrowsU8} -\begin{chunk}{defmacro anrowsU8} -(defmacro anrowsU8 (v) - `(array-dimension (the (simple-array (unsigned-byte 8) (* *)) ,v) 0)) +\defmacro{cdsetelt}{ComplexDoubleFloatVector Qsetelt1 function support} +\begin{chunk}{defmacro cdsetelt} +(defmacro cdsetelt(ov oi os) + (let ((v (gensym)) + (i (gensym)) + (s (gensym))) + `(let ((,v ,ov) + (,i ,oi) + (,s ,os)) + (setf (aref (the (simple-array double-float (*)) ,v) (* 2 ,i)) + (car ,s)) + (setf (aref (the (simple-array double-float (*)) ,v) (+ (* 2 ,i) 1)) + (cdr ,s)) + ,s))) \end{chunk} -\defmacro{ancolsU8} -\begin{chunk}{defmacro ancolsU8} -(defmacro ancolsU8 (v) - `(array-dimension (the (simple-array (unsigned-byte 8) (* *)) ,v) 1)) +\defmacro{cdlen}{ComplexDoubleFloatVector Qsize function support} +\begin{chunk}{defmacro cdlen} +(defmacro cdlen(v) + `(truncate (length (the (simple-array double-float (*)) ,v)) 2)) \end{chunk} -\defmacro{makeMatrixU8} -\begin{chunk}{defmacro makeMatrixU8} -(defmacro makeMatrixU8 (n m) - `(make-array (list ,n ,m) :element-type '(unsigned-byte 8) - :initial-element 0)) +%%% D %%% + +\section{\enspace{}Database} +\defun{stringMatches?}{Database elt function support} +\calls{stringMatches?}{basicMatch?} +\begin{chunk}{defun stringMatches?} +(defun |stringMatches?| (pattern subject) + (when (integerp (|basicMatch?| pattern subject)) t)) \end{chunk} -\defmacro{makeMatrix1U8} -\begin{chunk}{defmacro makeMatrix1U8} -(defmacro makeMatrix1U8 (n m s) - `(make-array (list ,n ,m) :element-type '(unsigned-byte 8) - :initial-element ,s)) +\section{\enspace{}DirectProduct} +\defun{vec2list}{vec2list} +\begin{chunk}{defun vec2list} +(defun vec2list (vec) (coerce vec 'list)) \end{chunk} -\section{InputForm} +\section{\enspace{}DoubleFloat} +These macros wrap their arguments with strong type information in +order to optimize doublefloat computatations. They are used directly +in the DoubleFloat domain (see Volume 10.3). -\defun{mkobjFn}{called by interpret function} -\begin{chunk}{defun mkObjFn 0} -(defun |mkObjFn| (val mode) - (cons mode val)) +\defmacro{DFLessThan} +Compute a strongly typed doublefloat comparison +See Steele Common Lisp 1990 p293 +\begin{chunk}{defmacro DFLessThan} +(defmacro DFLessThan (x y) + `(< (the double-float ,x) (the double-float ,y))) \end{chunk} -\defun{objValFn}{called by interpret function} -\begin{chunk}{defun objValFn 0} -(defun |objValFn| (obj) - (cdr obj)) +\defmacro{DFUnaryMinus} +Compute a strongly typed unary doublefloat minus +See Steele Common Lisp 1990 p295 +\begin{chunk}{defmacro DFUnaryMinus} +(defmacro DFUnaryMinus (x) + `(the double-float (- (the double-float ,x)))) \end{chunk} -\defun{objModeFn}{called by interpret function} -\begin{chunk}{defun objModeFn 0} -(defun |objModeFn| (obj) - (car obj)) +\defmacro{DFMinusp} +Compute a strongly typed unary doublefloat test for negative +See Steele Common Lisp 1990 p292 +\begin{chunk}{defmacro DFMinusp} +(defmacro DFMinusp (x) + `(minusp (the double-float ,x))) \end{chunk} +\defmacro{DFZerop} +Compute a strongly typed unary doublefloat test for zero +See Steele Common Lisp 1990 p292 +\begin{chunk}{defmacro DFZerop} +(defmacro DFZerop (x) + `(zerop (the double-float ,x))) -\section{U16Matrix} +\end{chunk} -\defmacro{aref2U16} -\begin{chunk}{defmacro aref2U16} -(defmacro aref2U16 (v i j) - `(aref (the (simple-array (unsigned-byte 16) (* *)) ,v) ,i ,j)) +\defmacro{DFAdd} +Compute a strongly typed doublefloat addition +See Steele Common Lisp 1990 p295 +\begin{chunk}{defmacro DFAdd} +(defmacro DFAdd (x y) + `(the double-float (+ (the double-float ,x) (the double-float ,y)))) \end{chunk} -\defmacro{setAref2U16} -\begin{chunk}{defmacro setAref2U16} -(defmacro setAref2U16 (v i j s) - `(setf (aref (the (simple-array (unsigned-byte 16) (* *)) ,v) ,i ,j), s)) +\defmacro{DFSubtract} +Compute a strongly typed doublefloat subtraction +See Steele Common Lisp 1990 p295 +\begin{chunk}{defmacro DFSubtract} +(defmacro DFSubtract (x y) + `(the double-float (- (the double-float ,x) (the double-float ,y)))) \end{chunk} -\defmacro{anrowsU16} -\begin{chunk}{defmacro anrowsU16} -(defmacro anrowsU16 (v) - `(array-dimension (the (simple-array (unsigned-byte 16) (* *)) ,v) 0)) +\defmacro{DFMultiply} +Compute a strongly typed doublefloat multiplication +See Steele Common Lisp 1990 p296 +\begin{chunk}{defmacro DFMultiply} +(defmacro DFMultiply (x y) + `(the double-float (* (the double-float ,x) (the double-float ,y)))) \end{chunk} -\defmacro{ancolsU16} -\begin{chunk}{defmacro ancolsU16} -(defmacro ancolsU16 (v) - `(array-dimension (the (simple-array (unsigned-byte 16) (* *)) ,v) 1)) +\defmacro{DFIntegerMultiply} +Compute a strongly typed doublefloat multiplication by an integer. +See Steele Common Lisp 1990 p296 +\begin{chunk}{defmacro DFIntegerMultiply} +(defmacro DFIntegerMultiply (i y) + `(the double-float (* (the integer ,i) (the double-float ,y)))) \end{chunk} -\defmacro{makeMatrixU16} -\begin{chunk}{defmacro makeMatrixU16} -(defmacro makeMatrixU16 (n m) - `(make-array (list ,n ,m) :element-type '(unsigned-byte 16) - :initial-element 0)) +\defmacro{DFMax} +Choose the maximum of two doublefloats. +See Steele Common Lisp 1990 p294 +\begin{chunk}{defmacro DFMax} +(defmacro DFMax (x y) + `(the double-float (max (the double-float ,x) (the double-float ,y)))) \end{chunk} -\defmacro{makeMatrix1U16} -\begin{chunk}{defmacro makeMatrix1U16} -(defmacro makeMatrix1U16 (n m s) - `(make-array (list ,n ,m) :element-type '(unsigned-byte 16) - :initial-element ,s)) +\defmacro{DFMin} +Choose the minimum of two doublefloats. +See Steele Common Lisp 1990 p294 +\begin{chunk}{defmacro DFMin} +(defmacro DFMin (x y) + `(the double-float (min (the double-float ,x) (the double-float ,y)))) \end{chunk} -\section{\enspace{}U32Matrix} +\defmacro{DFEql} +Compare two doublefloats for equality, where equality is eq, or numbers of +the same type with the same value. +See Steele Common Lisp 1990 p105 +\begin{chunk}{defmacro DFEql} +(defmacro DFEql (x y) + `(eql (the double-float ,x) (the double-float ,y))) -\defmacro{aref2U32} -\begin{chunk}{defmacro aref2U32} -(defmacro aref2U32 (v i j) - `(aref (the (simple-array (unsigned-byte 32) (* *)) ,v) ,i ,j)) +\end{chunk} + +\defmacro{DFDivide} +Divide a doublefloat by a a doublefloat +See Steele Common Lisp 1990 p296 +\begin{chunk}{defmacro DFDivide} +(defmacro DFDivide (x y) + `(the double-float (/ (the double-float ,x) (the double-float ,y)))) \end{chunk} -\defmacro{setAref2U32} -\begin{chunk}{defmacro setAref2U32} -(defmacro setAref2U32 (v i j s) - `(setf (aref (the (simple-array (unsigned-byte 32) (* *)) ,v) ,i ,j), s)) +\defmacro{DFIntegerDivide} +Divide a doublefloat by an integer +See Steele Common Lisp 1990 p296 +\begin{chunk}{defmacro DFIntegerDivide} +(defmacro DFIntegerDivide (x i) + `(the double-float (/ (the double-float ,x) (the integer ,i)))) \end{chunk} -\defmacro{anrowsU32} -\begin{chunk}{defmacro anrowsU32} -(defmacro anrowsU32 (v) - `(array-dimension (the (simple-array (unsigned-byte 32) (* *)) ,v) 0)) +\defmacro{DFSqrt} +Compute the doublefloat square root of $x$. The result will be complex +if the argument is negative. +See Steele Common Lisp 1990 p302 +\begin{chunk}{defmacro DFSqrt} +(defmacro DFSqrt (x) + `(sqrt (the double-float ,x))) \end{chunk} -\defmacro{ancolsU32} -\begin{chunk}{defmacro ancolsU32} -(defmacro ancolsU32 (v) - `(array-dimension (the (simple-array (unsigned-byte 32) (* *)) ,v) 1)) +\defmacro{DFLogE} +Compute the doublefloat log of $x$ with the base $e$. +The result will be complex if the argument is negative. +See Steele Common Lisp 1990 p301 +\begin{chunk}{defmacro DFLogE} +(defmacro DFLogE (x) + `(log (the double-float ,x))) \end{chunk} -\defmacro{makeMatrixU32} -\begin{chunk}{defmacro makeMatrixU32} -(defmacro makeMatrixU32 (n m) - `(make-array (list ,n ,m) :element-type '(unsigned-byte 32) - :initial-element 0)) +\defmacro{DFLog} +Compute the doublefloat log of $x$ with a given base $b$. +The result will be complex if $x$ is negative. +See Steele Common Lisp 1990 p301 +\begin{chunk}{defmacro DFLog} +(defmacro DFLog (x b) + `(log (the double-float ,x) (the fixnum ,b))) \end{chunk} -\defmacro{makeMatrix1U32} -\begin{chunk}{defmacro makeMatrix1U32} -(defmacro makeMatrix1U32 (n m s) - `(make-array (list ,n ,m) :element-type '(unsigned-byte 32) - :initial-element ,s)) +\defmacro{DFIntegerExpt} +Compute the doublefloat expt of $x$ with a given integer power $i$ +See Steele Common Lisp 1990 p300 +\begin{chunk}{defmacro DFIntegerExpt} +(defmacro DFIntegerExpt (x i) + `(the double-float (expt (the double-float ,x) (the integer ,i)))) \end{chunk} -\section{\enspace{}U32VectorPolynomialOperations} +\defmacro{DFExpt} +Compute the doublefloat expt of $x$ with a given power $p$. +The result could be complex if the base is negative and the power is +not an integer. +See Steele Common Lisp 1990 p300 +\begin{chunk}{defmacro DFExpt} +(defmacro DFExpt (x p) + `(expt (the double-float ,x) (the double-float ,p))) -\defmacro{qsMulAdd6432} -\begin{chunk}{defmacro qsMulAdd6432} -(defmacro qsMulAdd6432 (x y z) - `(the (unsigned-byte 64) - (+ (the (unsigned-byte 64) - (* (the (unsigned-byte 32) ,x) - (the (unsigned-byte 32) ,y))) - (the (unsigned-byte 64) ,z)))) +\end{chunk} + +\defmacro{DFExp} +Compute the doublefloat exp with power $e$ +See Steele Common Lisp 1990 p300 +\begin{chunk}{defmacro DFExp} +(defmacro DFExp (x) + `(the double-float (exp (the double-float ,x)))) \end{chunk} -\defmacro{qsMulMod32} -\begin{chunk}{defmacro qsMulMod32} -(defmacro qsMulMod32 (x y) - `(the (unsigned-byte 64) - (* (the (unsigned-byte 32) ,x) - (the (unsigned-byte 32) ,y)))) +\defmacro{DFSin} +Compute a strongly typed doublefloat sin +See Steele Common Lisp 1990 p304 +\begin{chunk}{defmacro DFSin} +(defmacro DFSin (x) + `(the double-float (sin (the double-float ,x)))) \end{chunk} -\defmacro{qsMod6432} -\begin{chunk}{defmacro qsMod6432} -(defmacro qsMod6432 (x p) - `(the (unsigned-byte 32) - (rem (the (unsigned-byte 64) ,x) (the (unsigned-byte 32) ,p)))) +\defmacro{DFCos} +Compute a strongly typed doublefloat cos +See Steele Common Lisp 1990 p304 +\begin{chunk}{defmacro DFCos} +(defmacro DFCos (x) + `(the double-float (cos (the double-float ,x)))) \end{chunk} -\defmacro{qsMulAddMod6432} -\begin{chunk}{defmacro qsMulAddMod6432} -(defmacro qsMulAddMod6432 (x y z p) - `(qsMod6432 (qsMulAdd6432 ,x ,y ,z) ,p)) +\defmacro{DFTan} +Compute a strongly typed doublefloat tan +See Steele Common Lisp 1990 p304 +\begin{chunk}{defmacro DFTan} +(defmacro DFTan (x) + `(the double-float (tan (the double-float ,x)))) \end{chunk} -\defmacro{qsMul6432} -\begin{chunk}{defmacro qsMul6432} -(defmacro qsMul6432 (x y) - `(the (unsigned-byte 64) - (* (the (unsigned-byte 32) ,x) - (the (unsigned-byte 32) ,y)))) +\defmacro{DFAsin} +Compute a strongly typed doublefloat asin. The result is complex if the +absolute value of the argument is greater than 1. +See Steele Common Lisp 1990 p305 +\begin{chunk}{defmacro DFAsin} +(defmacro DFAsin (x) + `(asin (the double-float ,x))) \end{chunk} -\defmacro{qsDot26432} -\begin{chunk}{defmacro qsDot26432} -(defmacro qsDot26432 (a1 b1 a2 b2) - `(qsMulAdd6432 ,a1 ,b1 (qsMul6432 ,a2 ,b2))) +\defmacro{DFAcos} +Compute a strongly typed doublefloat acos. The result is complex if the +absolute value of the argument is greater than 1. +See Steele Common Lisp 1990 p305 +\begin{chunk}{defmacro DFAcos} +(defmacro DFAcos (x) + `(acos (the double-float ,x))) \end{chunk} -\defmacro{qsDot2Mod6432} -\begin{chunk}{defmacro qsDot2Mod6432} -(defmacro qsDot2Mod6432 (a1 b1 a2 b2 p) - `(qsMod6432 (qsDot26432 ,a1 ,b1 ,a2 ,b2) ,p)) +\defmacro{DFAtan} +Compute a strongly typed doublefloat atan +See Steele Common Lisp 1990 p305 +\begin{chunk}{defmacro DFAtan} +(defmacro DFAtan (x) + `(the double-float (atan (the double-float ,x)))) \end{chunk} -\section{\enspace{}DirectProduct} -\defun{vec2list}{vec2list} -\begin{chunk}{defun vec2list} -(defun vec2list (vec) (coerce vec 'list)) +\defmacro{DFAtan2} +Compute a strongly typed doublefloat atan with 2 arguments + +\begin{tabular}{lllc} +$y = 0$ & $x > 0$ & Positive x-axis & 0\\ +$y > 0$ & $x > 0$ & Quadrant I & $0 <$ result $< \pi/2$\\ +$y > 0$ & $x = 0$ & Positive y-axis & $\pi/2$\\ +$y > 0$ & $x < 0$ & Quadrant II & $\pi/2 <$ result $<\pi$\\ +$y = 0$ & $x < 0$ & Negative x-axis & $\pi$\\ +$y < 0$ & $x < 0$ & Quadrant III & $-\pi <$ result $< -\pi/2$\\ +$y < 0$ & $x = 0$ & Negative y-axis & $-\pi/2$\\ +$y < 0$ & $x > 0$ & Quadrant IV & $-\pi/2 <$ result $< 0$\\ +$y = 0$ & $x = 0$ & Origin & error +\end{tabular} + +See Steele Common Lisp 1990 p306 +\begin{chunk}{defmacro DFAtan2} +(defmacro DFAtan2 (y x) + `(the double-float (atan (the double-float ,x) (the double-float ,y)))) \end{chunk} -\section{\enspace{}AlgebraicFunction} -\defun{retract}{retract} -\calls{retract}{objMode} -\calls{retract}{objVal} -\calls{retract}{isWrapped} -\calls{retract}{qcar} -\calls{retract}{retract1} -\calls{retract}{mkObj} -\refsdollar{retract}{EmptyMode} -\begin{chunk}{defun retract} -(defun |retract| (object) - (labels ( - (retract1 (object) - (let (type val underDomain objectp) - (declare (special |$SingleInteger| |$Integer| |$NonNegativeInteger| - |$PositiveInteger|)) - (setq type (|objMode| object)) - (cond - ((stringp type) '|failed|) - (t - (setq val (|objVal| object)) - (cond - ((equal type |$PositiveInteger|) (mkObj val |$NonNegativeInteger|)) - ((equal type |$NonNegativeInteger|) (mkObj val |$Integer|)) - ((and (equal type |$Integer|) (typep (|unwrap| val) 'fixnum)) - (mkObj val |$SingleInteger|)) - (t - (cond - ((or (eql 1 (|#| type)) - (and (consp type) (eq (qcar type) '|Union|)) - (and (consp type) (eq (qcar type) '|FunctionCalled|) - (and (consp (qcdr type)) (eq (qcddr type) nil))) - (and (consp type) (eq (qcar type) '|OrderedVariableList|) - (and (consp (qcdr type)) (eq (qcddr type) nil))) - (and (consp type) (eq (qcar type) '|Variable|) - (and (consp (qcdr type)) (eq (qcddr type) nil)))) - (if (setq objectp (|retract2Specialization| object)) - objectp - '|failed|)) - ((null (setq underDomain (|underDomainOf| type))) - '|failed|) - ; try to retract the "coefficients", e.g. P RN -> P I or M RN -> M I - (t - (setq objectp (|retractUnderDomain| object type underDomain)) - (cond - ((not (eq objectp '|failed|)) objectp) - ; see if we can use the retract functions - ((setq objectp (|coerceRetract| object underDomain)) objectp) - ; see if we have a special case here - ((setq objectp (|retract2Specialization| object)) objectp) - (t '|failed|))))))))))) - (let (type val ans) - (declare (special |$EmptyMode|)) - (setq type (|objMode| object)) - (cond - ((stringp type) '|failed|) - ((equal type |$EmptyMode|) '|failed|) - (t - (setq val (|objVal| object)) - (cond - ((and (null (|isWrapped| val)) - (null (and (consp val) (eq (qcar val) 'map)))) - '|failed|) - (t - (cond - ((eq (setq ans (retract1 (mkObj val type))) '|failed|) - ans) - (t - (mkObj (|objVal| ans) (|objMode| ans))))))))))) +\defmacro{DFSinh} +Compute a strongly typed doublefloat sinh +\[(e^z-e^{-z})/2\] +See Steele Common Lisp 1990 p308 +\begin{chunk}{defmacro DFSinh} +(defmacro DFSinh (x) + `(the double-float (sinh (the double-float ,x)))) \end{chunk} -\section{\enspace{}Any} -\defun{spad2BootCoerce}{spad2BootCoerce} -\begin{chunk}{defun spad2BootCoerce} -(defun |spad2BootCoerce| (x source target) - (let (xp) - (cond - ((null (|isValidType| source)) - (|throwKeyedMsg| "%1p is not a valid type." (list source))) - ((null (|isValidType| target)) - (|throwKeyedMsg| "%1p is not a valid type." (list target))) - ((setq xp (|coerceInteractive| (mkObjWrap x source) target)) - (|objValUnwrap| xp)) - (t - (|throwKeyedMsgCannotCoerceWithValue| (|wrap| x) source target))))) +\defmacro{DFCosh} +Compute a strongly typed doublefloat cosh +\[(e^z+e^{-z})/2\] +See Steele Common Lisp 1990 p308 +\begin{chunk}{defmacro DFCosh} +(defmacro DFCosh (x) + `(the double-float (cosh (the double-float ,x)))) \end{chunk} -\section{\enspace{}ParametricLinearEquations} -\defun{algCoerceInteractive}{algCoerceInteractive} -\begin{chunk}{defun algCoerceInteractive} -(defun |algCoerceInteractive| (p source target) - (let (|$useConvertForCoercions| u) - (declare (special |$useConvertForCoercions|)) - (setq |$useConvertForCoercions| t) - (setq source (|devaluate| source)) - (setq target (|devaluate| target)) - (setq u (|coerceInteractive| (mkObjWrap p source) target)) - (if u - (|objValUnwrap| u) - (|error| (list "can't convert" p "of mode" source "to mode" target))))) +\defmacro{DFTanh} +Compute a strongly typed doublefloat tanh +\[(e^z-e^{-z})/(e^z+e^{-z})\] +See Steele Common Lisp 1990 p308 +\begin{chunk}{defmacro DFTanh} +(defmacro DFTanh (x) + `(the double-float (tanh (the double-float ,x)))) \end{chunk} -\section{\enspace{}NumberFormats} -\defun{ncParseFromString}{ncParseFromString} -\begin{chunk}{defun ncParseFromString} -(defun |ncParseFromString| (s) - (|zeroOneTran| (catch 'SPAD_READER (|parseFromString| s)))) +\defmacro{DFAsinh} +Compute the inverse hyperbolic sin. +\[log\left(z+\sqrt{1+z^2}\right)\] +See Steele Common Lisp 1990 p308 +\begin{chunk}{defmacro DFAsinh} +(defmacro DFAsinh (x) + `(the double-float (asinh (the double-float ,x)))) \end{chunk} -\section{\enspace{}SingleInteger} -\defun{qsquotient}{qsquotient} -\begin{chunk}{defun qsquotient 0} -(defun qsquotient (a b) - (the fixnum (truncate (the fixnum a) (the fixnum b)))) +\defmacro{DFAcosh} +Compute the inverse hyperbolic cos. Note that the acosh function will return +a complex result if the argument is less than 1. +\[log\left(z+(z+1)\sqrt{(z-1)/(z+1)}\right)\] +See Steele Common Lisp 1990 p308 +\begin{chunk}{defmacro DFAcosh} +(defmacro DFAcosh (x) + `(acosh (the double-float ,x))) \end{chunk} -\defun{qsremainder}{qsremainder} -\begin{chunk}{defun qsremainder 0} -(defun qsremainder (a b) - (the fixnum (rem (the fixnum a) (the fixnum b)))) +\defmacro{DFAtanh} +Compute the inverse hyperbolic tan. Note that the acosh function will return +a complex result if the argument is greater than 1. +\[log\left((1+z)\sqrt{1/(1-z^2)}\right)\] +See Steele Common Lisp 1990 p308 +\begin{chunk}{defmacro DFAtanh} +(defmacro DFAtanh (x) + `(atanh (the double-float ,x))) \end{chunk} -\defmacro{qsdifference} -\begin{chunk}{defmacro qsdifference 0} -(defmacro qsdifference (x y) - `(the fixnum (- (the fixnum ,x) (the fixnum ,y)))) +\defun{integer-decode-float-numerator}{Machine specific float numerator} +This is used in the DoubleFloat integerDecode function +\begin{chunk}{defun integer-decode-float-numerator 0} +(defun integer-decode-float-numerator (x) + (integer-decode-float x)) \end{chunk} -\defmacro{qslessp} -\begin{chunk}{defmacro qslessp 0} -(defmacro qslessp (a b) - `(< (the fixnum ,a) (the fixnum ,b))) +\defun{integer-decode-float-denominator}{Machine specific float denominator} +This is used in the DoubleFloat integerDecode function +\begin{chunk}{defun integer-decode-float-denominator 0} +(defun integer-decode-float-denominator (x) + (multiple-value-bind (mantissa exponent sign) (integer-decode-float x) + (declare (ignore mantissa sign)) (expt 2 (abs exponent)))) \end{chunk} -\defmacro{qsadd1} -\begin{chunk}{defmacro qsadd1 0} -(defmacro qsadd1 (x) - `(the fixnum (1+ (the fixnum ,x)))) +\defun{integer-decode-float-sign}{Machine specific float sign} +This is used in the DoubleFloat integerDecode function +\begin{chunk}{defun integer-decode-float-sign 0} +(defun integer-decode-float-sign (x) + (multiple-value-bind (mantissa exponent sign) (integer-decode-float x) + (declare (ignore mantissa exponent)) sign)) \end{chunk} -\defmacro{qssub1} -\begin{chunk}{defmacro qssub1 0} -(defmacro qssub1 (x) - `(the fixnum (1- (the fixnum ,x)))) +\defun{integer-decode-float-exponent}{Machine specific float bit length} +This is used in the DoubleFloat integerDecode function +\begin{chunk}{defun integer-decode-float-exponent 0} +(defun integer-decode-float-exponent (x) + (multiple-value-bind (mantissa exponent sign) (integer-decode-float x) + (declare (ignore mantissa sign)) exponent)) \end{chunk} -\defmacro{qsminus} -\begin{chunk}{defmacro qsminus 0} -(defmacro qsminus (x) - `(the fixnum (minus (the fixnum ,x)))) +\defun{manexp}{Decode floating-point values} +This function is used by DoubleFloat to implement the ``mantissa'' and +``exponent'' functions. +\begin{chunk}{defun manexp 0} +(defun manexp (u) + (multiple-value-bind (f e s) + (decode-float u) + (cons (* s f) e))) \end{chunk} -\defmacro{qsplus} -\begin{chunk}{defmacro qsplus 0} -(defmacro qsplus (x y) - `(the fixnum (+ (the fixnum ,x) (the fixnum ,y)))) +\defun{cot}{The cotangent routine} +The cotangent function is defined as +\[cot(z) = \frac{1}{tan(z)}\] +\begin{chunk}{defun cot 0} +(defun cot (a) + (if (or (> a 1000.0) (< a -1000.0)) + (/ (cos a) (sin a)) + (/ 1.0 (tan a)))) \end{chunk} -\defmacro{qstimes} -\begin{chunk}{defmacro qstimes 0} -(defmacro qstimes (x y) - `(the fixnum (* (the fixnum ,x) (the fixnum ,y)))) +\defun{acot}{The inverse cotangent function} +The inverse cotangent (arc-cotangent) function is defined as +\[acot(z) = cot^{-1}(z) = tan^{-1}(\frac{1}{z})\] +See Steele Common Lisp 1990 pp305-307 +\begin{chunk}{defun acot 0} +(defun acot (a) + (if (> a 0.0) + (if (> a 1.0) + (atan (/ 1.0 a)) + (- (/ pi 2.0) (atan a))) + (if (< a -1.0) + (- pi (atan (/ -1.0 a))) + (+ (/ pi 2.0) (atan (- a)))))) \end{chunk} -\defmacro{qsabsval} -\begin{chunk}{defmacro qsabsval 0} -(defmacro qsabsval (x) - `(the fixnum (abs (the fixnum ,x)))) +\defun{sec}{The secant function} +\[sec(x) = \frac{1}{cos(x)}\] +\begin{chunk}{defun sec 0} +(defun sec (x) (/ 1 (cos x))) \end{chunk} -\defmacro{qsoddp} -\begin{chunk}{defmacro qsoddp 0} -(defmacro qsoddp (x) - `(oddp (the fixnum ,x))) +\defun{asec}{The inverse secant function} +\[asec(x) = acos\left(\frac{1}{x}\right)\] +\begin{chunk}{defun asec 0} +(defun asec (x) (acos (/ 1 x))) \end{chunk} -\defmacro{qszerop} -\begin{chunk}{defmacro qszerop 0} -(defmacro qszerop (x) - `(zerop (the fixnum ,x))) +\defun{csc}{The cosecant function} +\[csc(x) = \frac{1}{sin(x)}\] +\begin{chunk}{defun csc 0} +(defun csc (x) (/ 1 (sin x))) \end{chunk} -\defmacro{qsmax} -\begin{chunk}{defmacro qsmax 0} -(defmacro qsmax (x y) - `(the fixnum (max (the fixnum ,x) (the fixnum ,y)))) +\defun{acsc}{The inverse cosecant function} +\[acsc(x) = \frac{1}{asin(x)}\] +\begin{chunk}{defun acsc 0} +(defun acsc (x) (asin (/ 1 x))) \end{chunk} -\defmacro{qsmin} -\begin{chunk}{defmacro qsmin 0} -(defmacro qsmin (x y) - `(the fixnum (min (the fixnum ,x) (the fixnum ,y)))) +\defun{csch}{The hyperbolic cosecant function} +\[csch(x) = \frac{1}{sinh(x)} \] +\begin{chunk}{defun csch 0} +(defun csch (x) (/ 1 (sinh x))) \end{chunk} -\section{\enspace{}Boolean} -\defun{BooleanEquality}{The Boolean = function support} -\begin{chunk}{defun BooleanEquality 0} -(defun |BooleanEquality| (x y) (if x y (null y))) +\defun{coth}{The hyperbolic cotangent function} +\[coth(x) = cosh(x) csch(x)\] +\begin{chunk}{defun coth 0} +(defun coth (x) (* (cosh x) (csch x))) \end{chunk} -\section{\enspace{}IndexedBits} -\defmacro{truth-to-bit}{IndexedBits new function support} -\begin{chunk}{defmacro truth-to-bit} -(defmacro truth-to-bit (x) `(cond (,x 1) ('else 0))) +\defun{sech}{The hyperbolic secant function} +\[sech(x) = \frac{1}{cosh(x)}\] +\begin{chunk}{defun sech 0} +(defun sech (x) (/ 1 (cosh x))) \end{chunk} -\defun{bvec-make-full}{IndexedBits new function support} -\begin{chunk}{defun bvec-make-full 0} -(defun bvec-make-full (n x) - (make-array (list n) :element-type 'bit :initial-element x)) +\defun{acsch}{The inverse hyperbolic cosecant function} +\[acsch(x) = asinh\left(\frac{1}{x}\right)\] +\begin{chunk}{defun acsch 0} +(defun acsch (x) (asinh (/ 1 x))) \end{chunk} -\defmacro{bit-to-truth}{IndexedBits elt function support} -\begin{chunk}{defmacro bit-to-truth 0} -(defmacro bit-to-truth (b) `(eq ,b 1)) +\defun{acoth}{The inverse hyperbolic cotangent function} +\[acoth(x) = atanh\left(\frac{1}{x}\right)\] +\begin{chunk}{defun acoth 0} +(defun acoth (x) (atanh (/ 1 x))) \end{chunk} -\defmacro{bvec-elt}{IndexedBits elt function support} -\begin{chunk}{defmacro bvec-elt 0} -(defmacro bvec-elt (bv i) `(sbit ,bv ,i)) +\defun{asech}{The inverse hyperbolic secant function} +\[asech(x) = acosh\left(\frac{1}{x}\right)\] +\begin{chunk}{defun asech 0} +(defun asech (x) (acosh (/ 1 x))) \end{chunk} -\defmacro{bvec-setelt}{IndexedBits setelt function support} -\begin{chunk}{defmacro bvec-setelt} -(defmacro bvec-setelt (bv i x) `(setf (sbit ,bv ,i) ,x)) +\section{\enspace{}DoubleFloatMatrix} +\defmacro{make-double-matrix}{DoubleFloatMatrix qnew function support} +\begin{chunk}{defmacro make-double-matrix} +(defmacro make-double-matrix (n m) + `(make-array (list ,n ,m) :element-type 'double-float)) \end{chunk} -\defmacro{bvec-size}{IndexedBits length function support} -\begin{chunk}{defmacro bvec-size} -(defmacro bvec-size (bv) `(size ,bv)) +\defmacro{make-double-matrix1}{DoubleFloatMatrix new function support} +\begin{chunk}{defmacro make-double-matrix1} +(defmacro make-double-matrix1 (n m s) + `(make-array (list ,n ,m) :element-type 'double-float + :initial-element ,s)) \end{chunk} -\defun{bvec-concat}{IndexedBits concat function support} -\begin{chunk}{defun bvec-concat 0} -(defun bvec-concat (bv1 bv2) (concatenate '(vector bit) bv1 bv2)) +\defmacro{daref2}{DoubleFloatMatrix qelt function support} +\begin{chunk}{defmacro daref2} +(defmacro daref2 (v i j) + `(aref (the (simple-array double-float (* *)) ,v) ,i ,j)) \end{chunk} -\defun{bvec-copy}{IndexedBits copy function support} -\begin{chunk}{defun bvec-copy 0} -(defun bvec-copy (bv) (copy-seq bv)) +\defmacro{dsetaref2}{DoubleFloatMatrix qsetelt! function support} +\begin{chunk}{defmacro dsetaref2} +(defmacro dsetaref2 (v i j s) + `(setf (aref (the (simple-array double-float (* *)) ,v) ,i ,j) + ,s)) \end{chunk} -\defun{bvec-equal}{IndexedBits = function support} -\begin{chunk}{defun bvec-equal 0} -(defun bvec-equal (bv1 bv2) (equal bv1 bv2)) +\defmacro{danrows}{DoubleFloatMatrix nrows function support} +\begin{chunk}{defmacro danrows} +(defmacro danrows (v) + `(array-dimension (the (simple-array double-float (* *)) ,v) 0)) \end{chunk} -\defun{bvec-greater}{IndexedBits $<$ function support} -\begin{chunk}{defun bvec-greater 0} -(defun bvec-greater (bv1 bv2) - (let ((pos (mismatch bv1 bv2))) - (cond ((or (null pos) (>= pos (length bv1))) nil) - ((< pos (length bv2)) (> (bit bv1 pos) (bit bv2 pos))) - ((find 1 bv1 :start pos) t) - (t nil)))) +\defmacro{dancols}{DoubleFloatMatrix ncols function support} +\begin{chunk}{defmacro dancols} +(defmacro dancols (v) + `(array-dimension (the (simple-array double-float (* *)) ,v) 1)) \end{chunk} -\defun{bvec-and}{IndexedBits And function support} -\begin{chunk}{defun bvec-and 0} -(defun bvec-and (bv1 bv2) (bit-and bv1 bv2)) +\section{\enspace{}DoubleFloatVector} +Double Float Vectors are simple arrays of lisp double-floats +made available at the Spad language level. Note that these vectors +are 0 based whereas other Spad language vectors are 1-based. + +\defmacro{dlen}{DoubleFloatVector Qsize function support} +\begin{chunk}{defmacro dlen} +(defmacro dlen (v) + `(length (the (simple-array double-float (*)) ,v))) \end{chunk} -\defun{bvec-or}{IndexedBits Or function support} -\begin{chunk}{defun bvec-or 0} -(defun bvec-or (bv1 bv2) (bit-ior bv1 bv2)) +\defmacro{make-double-vector}{DoubleFloatVector Qnew function support} +\begin{chunk}{defmacro make-double-vector} +(defmacro make-double-vector (n) + `(make-array (list ,n) :element-type 'double-float)) \end{chunk} -\defun{bvec-xor}{IndexedBits xor function support} -\begin{chunk}{defun bvec-xor 0} -(defun bvec-xor (bv1 bv2) (bit-xor bv1 bv2)) +\defmacro{make-double-vector1}{DoubleFloatVector Qnew1 function support} +\begin{chunk}{defmacro make-double-vector1} +(defmacro make-double-vector1 (n s) + `(make-array (list ,n) :element-type 'double-float :initial-element ,s)) \end{chunk} -\defun{bvec-nand}{IndexedBits nand function support} -\begin{chunk}{defun bvec-nand 0} -(defun bvec-nand (bv1 bv2) (bit-nand bv1 bv2)) +\defmacro{delt}{DoubleFloatVector Qelt1 function support} +\begin{chunk}{defmacro delt} +(defmacro delt (v i) + `(aref (the (simple-array double-float (*)) ,v) ,i)) \end{chunk} -\defun{bvec-nor}{IndexedBits nor function support} -\begin{chunk}{defun bvec-nor 0} -(defun bvec-nor (bv1 bv2) (bit-nor bv1 bv2)) +\defmacro{dsetelt}{DoubleFloatVector Qsetelt1 function support} +\begin{chunk}{defmacro dsetelt} +(defmacro dsetelt (v i s) + `(setf (aref (the (simple-array double-float (*)) ,v) ,i) ,s)) \end{chunk} -\defun{bvec-not}{IndexedBits not function support} -\begin{chunk}{defun bvec-not 0} -(defun bvec-not (bv) (bit-not bv)) +%%% E %%% +%%% F %%% + +\section{\enspace{}FileName} +\defun{fnameMake}{FileName filename function implementation} +\calls{fnameMake}{StringToDir} +\begin{chunk}{defun fnameMake} +(defun |fnameMake| (d n e) + (if (string= e "") (setq e nil)) + (make-pathname :directory (|StringToDir| d) :name n :type e)) \end{chunk} -\section{\enspace{}KeyedAccessFile} -\defun{rdefinstream}{KeyedAccessFile defstream function support} -This is a simpler interpface to RDEFIOSTREAM -\calls{rdefinstream}{rdefiostream} -\begin{chunk}{defun rdefinstream} -(defun rdefinstream (&rest fn) - ;; following line prevents rdefiostream from adding a default filetype - (unless (rest fn) (setq fn (list (pathname (car fn))))) - (rdefiostream (list (cons 'file fn) '(mode . input)))) +\defun{StringToDir}{FileName filename support function} +\calls{StringToDir}{lastc} +\begin{chunk}{defun StringToDir} +(defun |StringToDir| (s) + (cond + ((string= s "/") '(:root)) + ((string= s "") nil) + (t + (let ((lastc (aref s (- (length s) 1)))) + (if (char= lastc #\/) + (pathname-directory (concat s "name.type")) + (pathname-directory (concat s "/name.type")) ))) )) \end{chunk} -\defun{rdefoutstream}{KeyedAccessFile defstream function support} -\calls{rdefoutstream}{rdefiostream} -\begin{chunk}{defun rdefoutstream} -(defun rdefoutstream (&rest fn) - ;; following line prevents rdefiostream from adding a default filetype - (unless (rest fn) (setq fn (list (pathname (car fn))))) - (rdefiostream (list (cons 'FILE fn) '(mode . OUTPUT)))) +\defun{fnameDirectory}{FileName directory function implementation} +\calls{fnameDirectory}{DirToString} +\begin{chunk}{defun fnameDirectory} +(defun |fnameDirectory| (f) + (|DirToString| (pathname-directory f))) \end{chunk} -\section{\enspace{}Table} -\defun{hashable}{Table InnerTable support} -We look inside the Key domain given to Table and find if there is an -equality predicate associated with the domain. If found then -Table will use a HashTable representation, otherwise it will use -an AssociationList representation. +\defun{DirToString}{FileName directory function support} +For example, ``/'' ``/u/smwatt'' ``../src'' +\begin{chunk}{defun DirToString 0} +(defun |DirToString| (d) + (cond + ((equal d '(:root)) "/") + ((null d) "") + ('t (string-right-trim "/" (namestring (make-pathname :directory d)))) )) -\calls{hashable}{knownEqualPred} -\calls{hashable}{compiledLookup} -\calls{hashable}{Boolean} -\calls{hashable}{bpiname} -\calls{hashable}{knownEqualPred} -\begin{chunk}{defun hashable} -(defun |hashable| (dom) - (labels ( - (|knownEqualPred| (dom) - (let ((fun (|compiledLookup| '= '((|Boolean|) $ $) dom))) - (if fun - (get (bpiname (car fun)) '|SPADreplace|) - nil)))) - (member (|knownEqualPred| dom) '(eq eql equal)))) +\end{chunk} + +\defun{fnameName}{FileName name function implementation} +\begin{chunk}{defun fnameName 0} +(defun |fnameName| (f) + (let ((s (pathname-name f))) + (if s s "") )) \end{chunk} -\defun{compiledLookup}{compiledLookup} -\calls{compiledLookup}{isDomain} -\calls{compiledLookup}{NRTevalDomain} -\begin{chunk}{defun compiledLookup} -(defun |compiledLookup| (op sig dollar) - (unless (|isDomain| dollar) (setq dollar (|NRTevalDomain| dollar))) - (|basicLookup| op sig dollar dollar)) +\defun{fnameType}{FileName extension function implementation} +\begin{chunk}{defun fnameType 0} +(defun |fnameType| (f) + (let ((s (pathname-type f))) + (if s s "") )) \end{chunk} -\defun{basicLookup}{basicLookup} -\calls{basicLookup}{spadcall} -\calls{basicLookup}{hashCode?} -\calls{basicLookup}{opIsHasCat} -\calls{basicLookup}{HasCategory} -\calls{basicLookup}{hashType} -\calls{basicLookup}{hashString} -\calls{basicLookup}{error} -\calls{basicLookup}{vecp} -\calls{basicLookup}{isNewWorldDomain} -\calls{basicLookup}{oldCompLookup} -\calls{basicLookup}{lookupInDomainVector} -\refsdollar{basicLookup}{hashSeg} -\refsdollar{basicLookup}{hashOpSet} -\refsdollar{basicLookup}{hashOpApply} -\refsdollar{basicLookup}{hashOp0} -\refsdollar{basicLookup}{hashOp1} -\begin{chunk}{defun basicLookup} -(defun |basicLookup| (op sig domain dollar) - (let (hashPercent box dispatch lookupFun hashSig val boxval) - (declare (special |$hashSeg| |$hashOpSet| |$hashOpApply| |$hashOp0| - |$hashOp1|)) - (cond - ((vecp domain) - (if (|isNewWorldDomain| domain) - (|oldCompLookup| op sig domain dollar) - (|lookupInDomainVector| op sig domain dollar))) - (t - (setq hashPercent - (if (vecp dollar) - (|hashType| (elt dollar 0) 0) - (|hashType| dollar 0))) - (setq box (cons nil nil)) - (cond - ((null (vecp (setq dispatch (car domain)))) - (|error| '|bad domain format|)) - (t - (setq lookupFun (elt dispatch 3)) - (cond - ((eql (elt dispatch 0) 0) - (setq hashSig - (cond - ((|hashCode?| sig) sig) - ((|opIsHasCat| op) (|hashType| sig hashPercent)) - (t (|hashType| (cons '|Mapping| sig) hashPercent)))) - (when (symbolp op) - (cond - ((eq op '|Zero|) (setq op |$hashOp0|)) - ((eq op '|One|) (setq op |$hashOp1|)) - ((eq op '|elt|) (setq op |$hashOpApply|)) - ((eq op '|setelt|) (setq op |$hashOpSet|)) - (t (setq op (|hashString| (symbol-name op)))))) - (cond - ((setq val - (car - (spadcall (cdr domain) dollar op hashSig box nil lookupFun))) - val) - ((|hashCode?| sig) nil) - ((or (> (|#| sig) 1) (|opIsHasCat| op)) nil) - ((setq boxval - (spadcall (cdr dollar) dollar op - (|hashType| (car sig) hashPercent) - box nil lookupFun)) - (cons #'identity (car boxval))) - (t nil))) - ((|opIsHasCat| op) (|HasCategory| domain sig)) - (t - (when (|hashCode?| op) - (cond - ((eql op |$hashOp1|) (setq op '|One|)) - ((eql op |$hashOp0|) (setq op '|Zero|)) - ((eql op |$hashOpApply|) (setq op '|elt|)) - ((eql op |$hashOpSet|) (setq op '|setelt|)) - ((eql op |$hashSeg|) (setq op 'segment)))) - (cond - ((and (|hashCode?| sig) (eql sig hashPercent)) - (spadcall - (car (spadcall (cdr dollar) dollar op '($) box nil lookupFun)))) - (t - (car - (spadcall (cdr dollar) dollar op sig box nil lookupFun)))))))))))) +\defun{fnameExists?}{FileName exists? function implementation} +\begin{chunk}{defun fnameExists? 0} +(defun |fnameExists?| (f) + (if (probe-file (namestring f)) 't nil)) \end{chunk} -\defun{lookupInDomainVector}{lookupInDomainVector} -\calls{lookupInDomainVector}{basicLookupCheckDefaults} -\calls{lookupInDomainVector}{spadcall} -\begin{chunk}{defun lookupInDomainVector} -(defun |lookupInDomainVector| (op sig domain dollar) - (if (consp domain) - (|basicLookupCheckDefaults| op sig domain domain) - (spadcall op sig dollar (elt domain 1)))) +\defun{fnameReadable?}{FileName readable? function implementation} +\begin{chunk}{defun fnameReadable? 0} +(defun |fnameReadable?| (f) + (let ((s (open f :direction :input :if-does-not-exist nil))) + (cond (s (close s) t) (t nil)) )) \end{chunk} -\defun{basicLookupCheckDefaults}{basicLookupCheckDefaults} -\calls{basicLookupCheckDefaults}{vecp} -\calls{basicLookupCheckDefaults}{error} -\calls{basicLookupCheckDefaults}{hashType} -\calls{basicLookupCheckDefaults}{hashCode?} -\calls{basicLookupCheckDefaults}{hashString} -\calls{basicLookupCheckDefaults}{spadcall} -\refsdollar{basicLookupCheckDefaults}{lookupDefaults} -\begin{chunk}{defun basicLookupCheckDefaults} -(defun |basicLookupCheckDefaults| (op sig domain dollar) - (declare (ignore domain)) - (let (box dispatch lookupFun hashPercent hashSig) - (declare (special |$lookupDefaults|)) - (setq box (cons nil nil)) - (cond - ((null (vecp (setq dispatch (car dollar)))) - (|error| '|bad domain format|)) - (t - (setq lookupFun (elt dispatch 3)) - (cond - ((eql (elt dispatch 0) 0) - (setq hashPercent - (if (vecp dollar) - (|hashType| (elt dollar 0) 0) - (|hashType| dollar 0))) - (setq hashSig - (if (|hashCode?| sig) - sig - (|hashType| (cons '|Mapping| sig) hashPercent))) - (when (symbolp op) (setq op (|hashString| (symbol-name op)))) - (car (spadcall (cdr dollar) dollar op hashSig - box (null |$lookupDefaults|) lookupFun))) - (t - (car (spadcall (cdr dollar) dollar op sig box - (null |$lookupDefaults|) lookupFun)))))))) +\defun{fnameWritable?}{FileName writeable? function implementation} +\calls{fnameWritable?}{myWriteable?} +\begin{chunk}{defun fnameWritable?} +(defun |fnameWritable?| (f) + (|myWritable?| (namestring f)) ) \end{chunk} -\defun{oldCompLookup}{oldCompLookup} -\calls{oldCompLookup}{lookupInDomainVector} -\defsdollar{oldCompLookup}{lookupDefaults} -\begin{chunk}{defun oldCompLookup} -(defun |oldCompLookup| (op sig domvec dollar) - (let (|$lookupDefaults| u) - (declare (special |$lookupDefaults|)) - (setq |$lookupDefaults| nil) - (cond - ((setq u (|lookupInDomainVector| op sig domvec dollar)) - u) - (t - (setq |$lookupDefaults| t) - (|lookupInDomainVector| op sig domvec dollar))))) +\defun{myWritable?}{FileName writeable? function support} +\calls{myWritable?}{error} +\calls{myWritable?}{fnameExists?} +\calls{myWritable?}{fnameDirectory} +\calls{myWritable?}{writeablep} +\begin{chunk}{defun myWritable?} +(defun |myWritable?| (s) + (if (not (stringp s)) (|error| "``myWritable?'' requires a string arg.")) + (if (string= s "") (setq s ".")) + (if (not (|fnameExists?| s)) (setq s (|fnameDirectory| s))) + (if (string= s "") (setq s ".")) + (if (> (|writeablep| s) 0) 't nil) ) \end{chunk} -\defun{NRTevalDomain}{NRTevalDomain} -\calls{NRTevalDomain}{qcar} -\calls{NRTevalDomain}{eval} -\calls{NRTevalDomain}{evalDomain} -\begin{chunk}{defun NRTevalDomain} -(defun |NRTevalDomain| (form) - (if (and (consp form) (eq (qcar form) 'setelt)) - (|eval| form) - (|evalDomain| form))) +\defun{fnameNew}{FileName new function implementation} +\calls{fnameNew}{fnameMake} +\begin{chunk}{defun fnameNew} +(defun |fnameNew| (d n e) + (if (not (|myWritable?| d)) + nil + (do ((fn)) + (nil) + (setq fn (|fnameMake| d (string (gensym n)) e)) + (if (not (probe-file (namestring fn))) + (return-from |fnameNew| fn)) ))) \end{chunk} -\section{\enspace{}Plot3d} -We catch numeric errors and throw a different failure than normal. -The trapNumericErrors macro will return a pair of the the form -{\tt Union(type-of-form, "failed")}. This pair is tested for eq-ness -so it has to be unique. It lives in the defvar \verb|$numericFailure|. -The old value of the \verb|$BreakMode| variable is saved in a defvar -named \verb|$oldBreakMode|. +%%% G %%% +%%% H %%% +%%% I %%% -\defdollar{numericFailure} -This is a failed union branch which is the value returned for numeric failure. -\begin{chunk}{initvars} -(defvar |$numericFailure| (cons 1 "failed")) +\section{\enspace{}IndexedBits} +\defmacro{truth-to-bit}{IndexedBits new function support} +\begin{chunk}{defmacro truth-to-bit} +(defmacro truth-to-bit (x) `(cond (,x 1) ('else 0))) \end{chunk} -\defdollar{oldBreakMode} -\begin{chunk}{initvars} -(defvar |$oldBreakMode| nil "the old value of the $BreakMode variable") +\defun{bvec-make-full}{IndexedBits new function support} +\begin{chunk}{defun bvec-make-full 0} +(defun bvec-make-full (n x) + (make-array (list n) :element-type 'bit :initial-element x)) \end{chunk} -\defmacro{trapNumericErrors} -The following macro evaluates form returning Union(type-of form, "failed"). -It is used in the {\tt myTrap} local function in Plot3d. -\begin{chunk}{defmacro trapNumericErrors} -(defmacro |trapNumericErrors| (form) - `(let ((|$oldBreakMode| |$BreakMode|) (|$BreakMode| '|trapNumerics|) (val)) - (declare (special |$BreakMode| |$numericFailure| |$oldBreakMode|)) - (setq val (catch '|trapNumerics| ,form)) - (if (eq val |$numericFailure|) val (cons 0 val)))) +\defmacro{bit-to-truth}{IndexedBits elt function support} +\begin{chunk}{defmacro bit-to-truth 0} +(defmacro bit-to-truth (b) `(eq ,b 1)) \end{chunk} -\section{\enspace{}DoubleFloatVector} -Double Float Vectors are simple arrays of lisp double-floats -made available at the Spad language level. Note that these vectors -are 0 based whereas other Spad language vectors are 1-based. - -\defmacro{dlen}{DoubleFloatVector Qsize function support} -\begin{chunk}{defmacro dlen} -(defmacro dlen (v) - `(length (the (simple-array double-float (*)) ,v))) +\defmacro{bvec-elt}{IndexedBits elt function support} +\begin{chunk}{defmacro bvec-elt 0} +(defmacro bvec-elt (bv i) `(sbit ,bv ,i)) \end{chunk} -\defmacro{make-double-vector}{DoubleFloatVector Qnew function support} -\begin{chunk}{defmacro make-double-vector} -(defmacro make-double-vector (n) - `(make-array (list ,n) :element-type 'double-float)) +\defmacro{bvec-setelt}{IndexedBits setelt function support} +\begin{chunk}{defmacro bvec-setelt} +(defmacro bvec-setelt (bv i x) `(setf (sbit ,bv ,i) ,x)) \end{chunk} -\defmacro{make-double-vector1}{DoubleFloatVector Qnew1 function support} -\begin{chunk}{defmacro make-double-vector1} -(defmacro make-double-vector1 (n s) - `(make-array (list ,n) :element-type 'double-float :initial-element ,s)) +\defmacro{bvec-size}{IndexedBits length function support} +\begin{chunk}{defmacro bvec-size} +(defmacro bvec-size (bv) `(size ,bv)) \end{chunk} -\defmacro{delt}{DoubleFloatVector Qelt1 function support} -\begin{chunk}{defmacro delt} -(defmacro delt (v i) - `(aref (the (simple-array double-float (*)) ,v) ,i)) +\defun{bvec-concat}{IndexedBits concat function support} +\begin{chunk}{defun bvec-concat 0} +(defun bvec-concat (bv1 bv2) (concatenate '(vector bit) bv1 bv2)) \end{chunk} -\defmacro{dsetelt}{DoubleFloatVector Qsetelt1 function support} -\begin{chunk}{defmacro dsetelt} -(defmacro dsetelt (v i s) - `(setf (aref (the (simple-array double-float (*)) ,v) ,i) ,s)) +\defun{bvec-copy}{IndexedBits copy function support} +\begin{chunk}{defun bvec-copy 0} +(defun bvec-copy (bv) (copy-seq bv)) \end{chunk} -\section{\enspace{}ComplexDoubleFloatVector} -Complex Double Float Vectors are simple arrays of lisp double-floats -made available at the Spad language level. Note that these vectors -are 0 based whereas other Spad language vectors are 1-based. -Complex array is implemented as an array of doubles. Each complex number -occupies two positions in the real array. - -\defmacro{make-cdouble-vector}{ComplexDoubleFloatVector Qnew function support} -\begin{chunk}{defmacro make-cdouble-vector} -(defmacro make-cdouble-vector (n) - `(make-array (list (* 2 ,n)) :element-type 'double-float)) +\defun{bvec-equal}{IndexedBits = function support} +\begin{chunk}{defun bvec-equal 0} +(defun bvec-equal (bv1 bv2) (equal bv1 bv2)) \end{chunk} -\defmacro{cdelt}{ComplexDoubleFloatVector Qelt1 function support} -\begin{chunk}{defmacro cdelt} -(defmacro CDELT(ov oi) - (let ((v (gensym)) - (i (gensym))) - `(let ((,v ,ov) - (,i ,oi)) - (cons - (aref (the (simple-array double-float (*)) ,v) (* 2 ,i)) - (aref (the (simple-array double-float (*)) ,v) (+ (* 2 ,i) 1)))))) +\defun{bvec-greater}{IndexedBits $<$ function support} +\begin{chunk}{defun bvec-greater 0} +(defun bvec-greater (bv1 bv2) + (let ((pos (mismatch bv1 bv2))) + (cond ((or (null pos) (>= pos (length bv1))) nil) + ((< pos (length bv2)) (> (bit bv1 pos) (bit bv2 pos))) + ((find 1 bv1 :start pos) t) + (t nil)))) \end{chunk} -\defmacro{cdsetelt}{ComplexDoubleFloatVector Qsetelt1 function support} -\begin{chunk}{defmacro cdsetelt} -(defmacro cdsetelt(ov oi os) - (let ((v (gensym)) - (i (gensym)) - (s (gensym))) - `(let ((,v ,ov) - (,i ,oi) - (,s ,os)) - (setf (aref (the (simple-array double-float (*)) ,v) (* 2 ,i)) - (car ,s)) - (setf (aref (the (simple-array double-float (*)) ,v) (+ (* 2 ,i) 1)) - (cdr ,s)) - ,s))) +\defun{bvec-and}{IndexedBits And function support} +\begin{chunk}{defun bvec-and 0} +(defun bvec-and (bv1 bv2) (bit-and bv1 bv2)) \end{chunk} -\defmacro{cdlen}{ComplexDoubleFloatVector Qsize function support} -\begin{chunk}{defmacro cdlen} -(defmacro cdlen(v) - `(truncate (length (the (simple-array double-float (*)) ,v)) 2)) +\defun{bvec-or}{IndexedBits Or function support} +\begin{chunk}{defun bvec-or 0} +(defun bvec-or (bv1 bv2) (bit-ior bv1 bv2)) \end{chunk} -\section{\enspace{}DoubleFloatMatrix} -\defmacro{make-double-matrix}{DoubleFloatMatrix qnew function support} -\begin{chunk}{defmacro make-double-matrix} -(defmacro make-double-matrix (n m) - `(make-array (list ,n ,m) :element-type 'double-float)) +\defun{bvec-xor}{IndexedBits xor function support} +\begin{chunk}{defun bvec-xor 0} +(defun bvec-xor (bv1 bv2) (bit-xor bv1 bv2)) \end{chunk} -\defmacro{make-double-matrix1}{DoubleFloatMatrix new function support} -\begin{chunk}{defmacro make-double-matrix1} -(defmacro make-double-matrix1 (n m s) - `(make-array (list ,n ,m) :element-type 'double-float - :initial-element ,s)) +\defun{bvec-nand}{IndexedBits nand function support} +\begin{chunk}{defun bvec-nand 0} +(defun bvec-nand (bv1 bv2) (bit-nand bv1 bv2)) \end{chunk} -\defmacro{daref2}{DoubleFloatMatrix qelt function support} -\begin{chunk}{defmacro daref2} -(defmacro daref2 (v i j) - `(aref (the (simple-array double-float (* *)) ,v) ,i ,j)) +\defun{bvec-nor}{IndexedBits nor function support} +\begin{chunk}{defun bvec-nor 0} +(defun bvec-nor (bv1 bv2) (bit-nor bv1 bv2)) \end{chunk} -\defmacro{dsetaref2}{DoubleFloatMatrix qsetelt! function support} -\begin{chunk}{defmacro dsetaref2} -(defmacro dsetaref2 (v i j s) - `(setf (aref (the (simple-array double-float (* *)) ,v) ,i ,j) - ,s)) +\defun{bvec-not}{IndexedBits not function support} +\begin{chunk}{defun bvec-not 0} +(defun bvec-not (bv) (bit-not bv)) \end{chunk} -\defmacro{danrows}{DoubleFloatMatrix nrows function support} -\begin{chunk}{defmacro danrows} -(defmacro danrows (v) - `(array-dimension (the (simple-array double-float (* *)) ,v) 0)) +\section{\enspace{}IndexCard} +\defun{alqlGetOrigin}{IndexCard origin function support} +\calls{alqlGetOrigin}{dbPart} +\calls{alqlGetOrigin}{charPosition} +\calls{alqlGetOrigin}{substring} +\begin{chunk}{defun alqlGetOrigin} +(defun |alqlGetOrigin| (x) + (let (field k) + (setq field (|dbPart| x 5 1)) + (setq k (|charPosition| #\( field 2)) + (substring field 1 (1- k)))) \end{chunk} -\defmacro{dancols}{DoubleFloatMatrix ncols function support} -\begin{chunk}{defmacro dancols} -(defmacro dancols (v) - `(array-dimension (the (simple-array double-float (* *)) ,v) 1)) +\defun{alqlGetParams}{IndexCard origin function support} +\calls{alqlGetParams}{dbPart} +\calls{alqlGetParams}{charPosition} +\calls{alqlGetParams}{substring} +\begin{chunk}{defun alqlGetParams} +(defun |alqlGetParams| (x) + (let (field k) + (setq field (|dbPart| x 5 1)) + (setq k (|charPosition| #\( field 2)) + (substring field k nil))) \end{chunk} -\section{\enspace{}ComplexDoubleFloatMatrix} - -\defmacro{make-cdouble-matrix}{ComplexDoubleFloatMatrix function support} -\begin{chunk}{defmacro make-cdouble-matrix} -(defmacro make-cdouble-matrix (n m) - `(make-array (list ,n (* 2 ,m)) :element-type 'double-float)) +\defun{alqlGetKindString}{IndexCard elt function support} +\calls{alqlGetKindString}{dbPart} +\calls{alqlGetKindString}{substring} +\begin{chunk}{defun alqlGetKindString} +(defun |alqlGetKindString| (x) + (if (or (char= (elt x 0) #\a) (char= (elt x 0) #\o)) + (substring (|dbPart| x 5 1) 0 1) + (substring x 0 1))) \end{chunk} -\defmacro{cdaref2}{ComplexDoubleFloatMatrix function support} -\begin{chunk}{defmacro cdaref2} -(defmacro cdaref2 (ov oi oj) - (let ((v (gensym)) - (i (gensym)) - (j (gensym))) - `(let ((,v ,ov) - (,i ,oi) - (,j ,oj)) - (cons - (aref (the (simple-array double-float (* *)) ,v) ,i (* 2 ,j)) - (aref (the (simple-array double-float (* *)) ,v) - ,i (+ (* 2 ,j) 1)))))) +\section{InputForm} + +\defun{mkobjFn}{called by interpret function} +\begin{chunk}{defun mkObjFn 0} +(defun |mkObjFn| (val mode) + (cons mode val)) \end{chunk} -\defmacro{cdsetaref2}{ComplexDoubleFloatMatrix function support} -\begin{chunk}{defmacro cdsetaref2} -(defmacro cdsetaref2 (ov oi oj os) - (let ((v (gensym)) - (i (gensym)) - (j (gensym)) - (s (gensym))) - `(let ((,v ,ov) - (,i ,oi) - (,j ,oj) - (,s ,os)) - (setf (aref (the (simple-array double-float (* *)) ,v) ,i (* 2 ,j)) - (car ,s)) - (setf (aref (the (simple-array double-float (* *)) ,v) - ,i (+ (* 2 ,j) 1)) - (cdr ,s)) - ,s))) +\defun{objValFn}{called by interpret function} +\begin{chunk}{defun objValFn 0} +(defun |objValFn| (obj) + (cdr obj)) \end{chunk} -\defmacro{cdanrows}{ComplexDoubleFloatMatrix function support} -\begin{chunk}{defmacro cdanrows} -(defmacro cdanrows (v) - `(array-dimension (the (simple-array double-float (* *)) ,v) 0)) +\defun{objModeFn}{called by interpret function} +\begin{chunk}{defun objModeFn 0} +(defun |objModeFn| (obj) + (car obj)) \end{chunk} -\defmacro{cdancols}{ComplexDoubleFloatMatrix function support} -\begin{chunk}{defmacro cdancols} -(defmacro cdancols (v) - `(truncate - (array-dimension (the (simple-array double-float (* *)) ,v) 1) 2)) +\defun{unparseInputForm}{unparseInputForm} +This fixes bug 7217. The default title generation is bogus. +This is called from the unparse function in InputForm, bookvol10.3 +Given a form, $u$, we try to recover the input line that created it. + +\defsdollar{unparseInputForm}{InteractiveMode} +\defsdollar{unparseInputForm}{formatSigAsTex} +\begin{chunk}{defun unparseInputForm} +(defun |unparseInputForm| (u) + (let (|$formatSigAsTeX| |$InteractiveMode|) + (declare (special |$formatSigAsTeX| |$InteractiveMode|)) + (setq |$formatSigAsTeX| 1) + (setq |$InteractiveMode| nil) + (|form2StringLocal| u))) \end{chunk} - \section{\enspace{}Integer} \defun{divide2}{Integer divide function support} Note that this is defined as a SPADReplace function in Integer @@ -46685,44 +46850,45 @@ function is called directly. This could be lifted up into the spad code. \end{chunk} -\section{\enspace{}IndexCard} -\defun{alqlGetOrigin}{IndexCard origin function support} -\calls{alqlGetOrigin}{dbPart} -\calls{alqlGetOrigin}{charPosition} -\calls{alqlGetOrigin}{substring} -\begin{chunk}{defun alqlGetOrigin} -(defun |alqlGetOrigin| (x) - (let (field k) - (setq field (|dbPart| x 5 1)) - (setq k (|charPosition| #\( field 2)) - (substring field 1 (1- k)))) +%%% J %%% +%%% K %%% + +\section{\enspace{}KeyedAccessFile} +\defun{rdefinstream}{KeyedAccessFile defstream function support} +This is a simpler interpface to RDEFIOSTREAM +\calls{rdefinstream}{rdefiostream} +\begin{chunk}{defun rdefinstream} +(defun rdefinstream (&rest fn) + ;; following line prevents rdefiostream from adding a default filetype + (unless (rest fn) (setq fn (list (pathname (car fn))))) + (rdefiostream (list (cons 'file fn) '(mode . input)))) \end{chunk} -\defun{alqlGetParams}{IndexCard origin function support} -\calls{alqlGetParams}{dbPart} -\calls{alqlGetParams}{charPosition} -\calls{alqlGetParams}{substring} -\begin{chunk}{defun alqlGetParams} -(defun |alqlGetParams| (x) - (let (field k) - (setq field (|dbPart| x 5 1)) - (setq k (|charPosition| #\( field 2)) - (substring field k nil))) +\defun{rdefoutstream}{KeyedAccessFile defstream function support} +\calls{rdefoutstream}{rdefiostream} +\begin{chunk}{defun rdefoutstream} +(defun rdefoutstream (&rest fn) + ;; following line prevents rdefiostream from adding a default filetype + (unless (rest fn) (setq fn (list (pathname (car fn))))) + (rdefiostream (list (cons 'FILE fn) '(mode . OUTPUT)))) \end{chunk} -\defun{alqlGetKindString}{IndexCard elt function support} -\calls{alqlGetKindString}{dbPart} -\calls{alqlGetKindString}{substring} -\begin{chunk}{defun alqlGetKindString} -(defun |alqlGetKindString| (x) - (if (or (char= (elt x 0) #\a) (char= (elt x 0) #\o)) - (substring (|dbPart| x 5 1) 0 1) - (substring x 0 1))) +%%% L %%% +%%% M %%% +%%% N %%% + +\section{\enspace{}NumberFormats} +\defun{ncParseFromString}{ncParseFromString} +\begin{chunk}{defun ncParseFromString} +(defun |ncParseFromString| (s) + (|zeroOneTran| (catch 'SPAD_READER (|parseFromString| s)))) \end{chunk} +%%% O %%% + \section{\enspace{}OperationsQuery} \defun{getBrowseDatabase}{OperationQuery getDatabase function support} @@ -46748,589 +46914,482 @@ appropriate entries in the browser database. The legal values for arg are \end{chunk} -\section{\enspace{}Database} -\defun{stringMatches?}{Database elt function support} -\calls{stringMatches?}{basicMatch?} -\begin{chunk}{defun stringMatches?} -(defun |stringMatches?| (pattern subject) - (when (integerp (|basicMatch?| pattern subject)) t)) - -\end{chunk} - -\section{\enspace{}FileName} -\defun{fnameMake}{FileName filename function implementation} -\calls{fnameMake}{StringToDir} -\begin{chunk}{defun fnameMake} -(defun |fnameMake| (d n e) - (if (string= e "") (setq e nil)) - (make-pathname :directory (|StringToDir| d) :name n :type e)) - -\end{chunk} +%%% P %%% -\defun{StringToDir}{FileName filename support function} -\calls{StringToDir}{lastc} -\begin{chunk}{defun StringToDir} -(defun |StringToDir| (s) - (cond - ((string= s "/") '(:root)) - ((string= s "") nil) - (t - (let ((lastc (aref s (- (length s) 1)))) - (if (char= lastc #\/) - (pathname-directory (concat s "name.type")) - (pathname-directory (concat s "/name.type")) ))) )) +\section{\enspace{}ParametricLinearEquations} +\defun{algCoerceInteractive}{algCoerceInteractive} +\begin{chunk}{defun algCoerceInteractive} +(defun |algCoerceInteractive| (p source target) + (let (|$useConvertForCoercions| u) + (declare (special |$useConvertForCoercions|)) + (setq |$useConvertForCoercions| t) + (setq source (|devaluate| source)) + (setq target (|devaluate| target)) + (setq u (|coerceInteractive| (mkObjWrap p source) target)) + (if u + (|objValUnwrap| u) + (|error| (list "can't convert" p "of mode" source "to mode" target))))) \end{chunk} -\defun{fnameDirectory}{FileName directory function implementation} -\calls{fnameDirectory}{DirToString} -\begin{chunk}{defun fnameDirectory} -(defun |fnameDirectory| (f) - (|DirToString| (pathname-directory f))) - -\end{chunk} +\section{\enspace{}Plot3d} +We catch numeric errors and throw a different failure than normal. +The trapNumericErrors macro will return a pair of the the form +{\tt Union(type-of-form, "failed")}. This pair is tested for eq-ness +so it has to be unique. It lives in the defvar \verb|$numericFailure|. +The old value of the \verb|$BreakMode| variable is saved in a defvar +named \verb|$oldBreakMode|. -\defun{DirToString}{FileName directory function support} -For example, ``/'' ``/u/smwatt'' ``../src'' -\begin{chunk}{defun DirToString 0} -(defun |DirToString| (d) - (cond - ((equal d '(:root)) "/") - ((null d) "") - ('t (string-right-trim "/" (namestring (make-pathname :directory d)))) )) +\defdollar{numericFailure} +This is a failed union branch which is the value returned for numeric failure. +\begin{chunk}{initvars} +(defvar |$numericFailure| (cons 1 "failed")) \end{chunk} -\defun{fnameName}{FileName name function implementation} -\begin{chunk}{defun fnameName 0} -(defun |fnameName| (f) - (let ((s (pathname-name f))) - (if s s "") )) +\defdollar{oldBreakMode} +\begin{chunk}{initvars} +(defvar |$oldBreakMode| nil "the old value of the $BreakMode variable") \end{chunk} -\defun{fnameType}{FileName extension function implementation} -\begin{chunk}{defun fnameType 0} -(defun |fnameType| (f) - (let ((s (pathname-type f))) - (if s s "") )) +\defmacro{trapNumericErrors} +The following macro evaluates form returning Union(type-of form, "failed"). +It is used in the {\tt myTrap} local function in Plot3d. +\begin{chunk}{defmacro trapNumericErrors} +(defmacro |trapNumericErrors| (form) + `(let ((|$oldBreakMode| |$BreakMode|) (|$BreakMode| '|trapNumerics|) (val)) + (declare (special |$BreakMode| |$numericFailure| |$oldBreakMode|)) + (setq val (catch '|trapNumerics| ,form)) + (if (eq val |$numericFailure|) val (cons 0 val)))) \end{chunk} -\defun{fnameExists?}{FileName exists? function implementation} -\begin{chunk}{defun fnameExists? 0} -(defun |fnameExists?| (f) - (if (probe-file (namestring f)) 't nil)) - -\end{chunk} +%%% Q %%% +%%% R %%% +%%% S %%% -\defun{fnameReadable?}{FileName readable? function implementation} -\begin{chunk}{defun fnameReadable? 0} -(defun |fnameReadable?| (f) - (let ((s (open f :direction :input :if-does-not-exist nil))) - (cond (s (close s) t) (t nil)) )) +\section{\enspace{}SingleInteger} +\defun{qsquotient}{qsquotient} +\begin{chunk}{defun qsquotient 0} +(defun qsquotient (a b) + (the fixnum (truncate (the fixnum a) (the fixnum b)))) \end{chunk} -\defun{fnameWritable?}{FileName writeable? function implementation} -\calls{fnameWritable?}{myWriteable?} -\begin{chunk}{defun fnameWritable?} -(defun |fnameWritable?| (f) - (|myWritable?| (namestring f)) ) +\defun{qsremainder}{qsremainder} +\begin{chunk}{defun qsremainder 0} +(defun qsremainder (a b) + (the fixnum (rem (the fixnum a) (the fixnum b)))) \end{chunk} -\defun{myWritable?}{FileName writeable? function support} -\calls{myWritable?}{error} -\calls{myWritable?}{fnameExists?} -\calls{myWritable?}{fnameDirectory} -\calls{myWritable?}{writeablep} -\begin{chunk}{defun myWritable?} -(defun |myWritable?| (s) - (if (not (stringp s)) (|error| "``myWritable?'' requires a string arg.")) - (if (string= s "") (setq s ".")) - (if (not (|fnameExists?| s)) (setq s (|fnameDirectory| s))) - (if (string= s "") (setq s ".")) - (if (> (|writeablep| s) 0) 't nil) ) +\defmacro{qsdifference} +\begin{chunk}{defmacro qsdifference 0} +(defmacro qsdifference (x y) + `(the fixnum (- (the fixnum ,x) (the fixnum ,y)))) \end{chunk} -\defun{fnameNew}{FileName new function implementation} -\calls{fnameNew}{fnameMake} -\begin{chunk}{defun fnameNew} -(defun |fnameNew| (d n e) - (if (not (|myWritable?| d)) - nil - (do ((fn)) - (nil) - (setq fn (|fnameMake| d (string (gensym n)) e)) - (if (not (probe-file (namestring fn))) - (return-from |fnameNew| fn)) ))) +\defmacro{qslessp} +\begin{chunk}{defmacro qslessp 0} +(defmacro qslessp (a b) + `(< (the fixnum ,a) (the fixnum ,b))) \end{chunk} -\section{\enspace{}DoubleFloat} -These macros wrap their arguments with strong type information in -order to optimize doublefloat computatations. They are used directly -in the DoubleFloat domain (see Volume 10.3). - -\defmacro{DFLessThan} -Compute a strongly typed doublefloat comparison -See Steele Common Lisp 1990 p293 -\begin{chunk}{defmacro DFLessThan} -(defmacro DFLessThan (x y) - `(< (the double-float ,x) (the double-float ,y))) +\defmacro{qsadd1} +\begin{chunk}{defmacro qsadd1 0} +(defmacro qsadd1 (x) + `(the fixnum (1+ (the fixnum ,x)))) \end{chunk} -\defmacro{DFUnaryMinus} -Compute a strongly typed unary doublefloat minus -See Steele Common Lisp 1990 p295 -\begin{chunk}{defmacro DFUnaryMinus} -(defmacro DFUnaryMinus (x) - `(the double-float (- (the double-float ,x)))) +\defmacro{qssub1} +\begin{chunk}{defmacro qssub1 0} +(defmacro qssub1 (x) + `(the fixnum (1- (the fixnum ,x)))) \end{chunk} -\defmacro{DFMinusp} -Compute a strongly typed unary doublefloat test for negative -See Steele Common Lisp 1990 p292 -\begin{chunk}{defmacro DFMinusp} -(defmacro DFMinusp (x) - `(minusp (the double-float ,x))) +\defmacro{qsminus} +\begin{chunk}{defmacro qsminus 0} +(defmacro qsminus (x) + `(the fixnum (minus (the fixnum ,x)))) \end{chunk} -\defmacro{DFZerop} -Compute a strongly typed unary doublefloat test for zero -See Steele Common Lisp 1990 p292 -\begin{chunk}{defmacro DFZerop} -(defmacro DFZerop (x) - `(zerop (the double-float ,x))) +\defmacro{qsplus} +\begin{chunk}{defmacro qsplus 0} +(defmacro qsplus (x y) + `(the fixnum (+ (the fixnum ,x) (the fixnum ,y)))) \end{chunk} -\defmacro{DFAdd} -Compute a strongly typed doublefloat addition -See Steele Common Lisp 1990 p295 -\begin{chunk}{defmacro DFAdd} -(defmacro DFAdd (x y) - `(the double-float (+ (the double-float ,x) (the double-float ,y)))) +\defmacro{qstimes} +\begin{chunk}{defmacro qstimes 0} +(defmacro qstimes (x y) + `(the fixnum (* (the fixnum ,x) (the fixnum ,y)))) \end{chunk} -\defmacro{DFSubtract} -Compute a strongly typed doublefloat subtraction -See Steele Common Lisp 1990 p295 -\begin{chunk}{defmacro DFSubtract} -(defmacro DFSubtract (x y) - `(the double-float (- (the double-float ,x) (the double-float ,y)))) +\defmacro{qsabsval} +\begin{chunk}{defmacro qsabsval 0} +(defmacro qsabsval (x) + `(the fixnum (abs (the fixnum ,x)))) \end{chunk} -\defmacro{DFMultiply} -Compute a strongly typed doublefloat multiplication -See Steele Common Lisp 1990 p296 -\begin{chunk}{defmacro DFMultiply} -(defmacro DFMultiply (x y) - `(the double-float (* (the double-float ,x) (the double-float ,y)))) +\defmacro{qsoddp} +\begin{chunk}{defmacro qsoddp 0} +(defmacro qsoddp (x) + `(oddp (the fixnum ,x))) \end{chunk} -\defmacro{DFIntegerMultiply} -Compute a strongly typed doublefloat multiplication by an integer. -See Steele Common Lisp 1990 p296 -\begin{chunk}{defmacro DFIntegerMultiply} -(defmacro DFIntegerMultiply (i y) - `(the double-float (* (the integer ,i) (the double-float ,y)))) +\defmacro{qszerop} +\begin{chunk}{defmacro qszerop 0} +(defmacro qszerop (x) + `(zerop (the fixnum ,x))) \end{chunk} -\defmacro{DFMax} -Choose the maximum of two doublefloats. -See Steele Common Lisp 1990 p294 -\begin{chunk}{defmacro DFMax} -(defmacro DFMax (x y) - `(the double-float (max (the double-float ,x) (the double-float ,y)))) +\defmacro{qsmax} +\begin{chunk}{defmacro qsmax 0} +(defmacro qsmax (x y) + `(the fixnum (max (the fixnum ,x) (the fixnum ,y)))) \end{chunk} -\defmacro{DFMin} -Choose the minimum of two doublefloats. -See Steele Common Lisp 1990 p294 -\begin{chunk}{defmacro DFMin} -(defmacro DFMin (x y) - `(the double-float (min (the double-float ,x) (the double-float ,y)))) +\defmacro{qsmin} +\begin{chunk}{defmacro qsmin 0} +(defmacro qsmin (x y) + `(the fixnum (min (the fixnum ,x) (the fixnum ,y)))) \end{chunk} -\defmacro{DFEql} -Compare two doublefloats for equality, where equality is eq, or numbers of -the same type with the same value. -See Steele Common Lisp 1990 p105 -\begin{chunk}{defmacro DFEql} -(defmacro DFEql (x y) - `(eql (the double-float ,x) (the double-float ,y))) +%%% T %%% -\end{chunk} +\section{\enspace{}Table} +\defun{hashable}{Table InnerTable support} +We look inside the Key domain given to Table and find if there is an +equality predicate associated with the domain. If found then +Table will use a HashTable representation, otherwise it will use +an AssociationList representation. -\defmacro{DFDivide} -Divide a doublefloat by a a doublefloat -See Steele Common Lisp 1990 p296 -\begin{chunk}{defmacro DFDivide} -(defmacro DFDivide (x y) - `(the double-float (/ (the double-float ,x) (the double-float ,y)))) +\calls{hashable}{knownEqualPred} +\calls{hashable}{compiledLookup} +\calls{hashable}{Boolean} +\calls{hashable}{bpiname} +\calls{hashable}{knownEqualPred} +\begin{chunk}{defun hashable} +(defun |hashable| (dom) + (labels ( + (|knownEqualPred| (dom) + (let ((fun (|compiledLookup| '= '((|Boolean|) $ $) dom))) + (if fun + (get (bpiname (car fun)) '|SPADreplace|) + nil)))) + (member (|knownEqualPred| dom) '(eq eql equal)))) \end{chunk} -\defmacro{DFIntegerDivide} -Divide a doublefloat by an integer -See Steele Common Lisp 1990 p296 -\begin{chunk}{defmacro DFIntegerDivide} -(defmacro DFIntegerDivide (x i) - `(the double-float (/ (the double-float ,x) (the integer ,i)))) +%%% U %%% -\end{chunk} +\section{U8Vector} -\defmacro{DFSqrt} -Compute the doublefloat square root of $x$. The result will be complex -if the argument is negative. -See Steele Common Lisp 1990 p302 -\begin{chunk}{defmacro DFSqrt} -(defmacro DFSqrt (x) - `(sqrt (the double-float ,x))) +\defmacro{qvlenU8} +\begin{chunk}{defmacro qvlenU8} +(defmacro qvlenU8 (v) + `(length (the (simple-array (unsigned-byte 8) (*)) ,v))) \end{chunk} -\defmacro{DFLogE} -Compute the doublefloat log of $x$ with the base $e$. -The result will be complex if the argument is negative. -See Steele Common Lisp 1990 p301 -\begin{chunk}{defmacro DFLogE} -(defmacro DFLogE (x) - `(log (the double-float ,x))) +\defmacro{eltU8} +\begin{chunk}{defmacro eltU8} +(defmacro eltU8 (v i) + `(aref (the (simple-array (unsigned-byte 8) (*)) ,v) ,i)) \end{chunk} -\defmacro{DFLog} -Compute the doublefloat log of $x$ with a given base $b$. -The result will be complex if $x$ is negative. -See Steele Common Lisp 1990 p301 -\begin{chunk}{defmacro DFLog} -(defmacro DFLog (x b) - `(log (the double-float ,x) (the fixnum ,b))) +\defmacro{seteltU8} +\begin{chunk}{defmacro seteltU8} +(defmacro seteltU8 (v i s) + `(setf (aref (the (simple-array (unsigned-byte 8) (*)) ,v) ,i), s)) \end{chunk} -\defmacro{DFIntegerExpt} -Compute the doublefloat expt of $x$ with a given integer power $i$ -See Steele Common Lisp 1990 p300 -\begin{chunk}{defmacro DFIntegerExpt} -(defmacro DFIntegerExpt (x i) - `(the double-float (expt (the double-float ,x) (the integer ,i)))) +\defun{getRefvU8}{getRefvU8} +\begin{chunk}{defun getRefvU8} +(defun getRefvU8 (n x) + (make-array n :initial-element x :element-type '(unsigned-byte 8))) \end{chunk} -\defmacro{DFExpt} -Compute the doublefloat expt of $x$ with a given power $p$. -The result could be complex if the base is negative and the power is -not an integer. -See Steele Common Lisp 1990 p300 -\begin{chunk}{defmacro DFExpt} -(defmacro DFExpt (x p) - `(expt (the double-float ,x) (the double-float ,p))) +\section{U16Vector} + +\defmacro{qvlenU16} +\begin{chunk}{defmacro qvlenU16} +(defmacro qvlenU16 (v) + `(length (the (simple-array (unsigned-byte 16) (*)) ,v))) \end{chunk} -\defmacro{DFExp} -Compute the doublefloat exp with power $e$ -See Steele Common Lisp 1990 p300 -\begin{chunk}{defmacro DFExp} -(defmacro DFExp (x) - `(the double-float (exp (the double-float ,x)))) +\defmacro{eltU16} +\begin{chunk}{defmacro eltU16} +(defmacro eltU16 (v i) + `(aref (the (simple-array (unsigned-byte 16) (*)) ,v) ,i)) \end{chunk} -\defmacro{DFSin} -Compute a strongly typed doublefloat sin -See Steele Common Lisp 1990 p304 -\begin{chunk}{defmacro DFSin} -(defmacro DFSin (x) - `(the double-float (sin (the double-float ,x)))) +\defmacro{seteltU16} +\begin{chunk}{defmacro seteltU16} +(defmacro seteltU16 (v i s) + `(setf (aref (the (simple-array (unsigned-byte 16) (*)) ,v) ,i), s)) \end{chunk} -\defmacro{DFCos} -Compute a strongly typed doublefloat cos -See Steele Common Lisp 1990 p304 -\begin{chunk}{defmacro DFCos} -(defmacro DFCos (x) - `(the double-float (cos (the double-float ,x)))) +\defun{getRefvU16}{getRefvU16} +\begin{chunk}{defun getRefvU16} +(defun getRefvU16 (n x) + (make-array n :initial-element x :element-type '(unsigned-byte 16))) \end{chunk} -\defmacro{DFTan} -Compute a strongly typed doublefloat tan -See Steele Common Lisp 1990 p304 -\begin{chunk}{defmacro DFTan} -(defmacro DFTan (x) - `(the double-float (tan (the double-float ,x)))) +\section{U32Vector} + +\defmacro{qvlenU32} +\begin{chunk}{defmacro qvlenU32} +(defmacro qvlenU32 (v) + `(length (the (simple-array (unsigned-byte 32) (*)) ,v))) \end{chunk} -\defmacro{DFAsin} -Compute a strongly typed doublefloat asin. The result is complex if the -absolute value of the argument is greater than 1. -See Steele Common Lisp 1990 p305 -\begin{chunk}{defmacro DFAsin} -(defmacro DFAsin (x) - `(asin (the double-float ,x))) +\defmacro{eltU32} +\begin{chunk}{defmacro eltU32} +(defmacro eltU32 (v i) + `(aref (the (simple-array (unsigned-byte 32) (*)) ,v) ,i)) \end{chunk} -\defmacro{DFAcos} -Compute a strongly typed doublefloat acos. The result is complex if the -absolute value of the argument is greater than 1. -See Steele Common Lisp 1990 p305 -\begin{chunk}{defmacro DFAcos} -(defmacro DFAcos (x) - `(acos (the double-float ,x))) +\defmacro{seteltU32} +\begin{chunk}{defmacro seteltU32} +(defmacro seteltU32 (v i s) + `(setf (aref (the (simple-array (unsigned-byte 32) (*)) ,v) ,i), s)) \end{chunk} -\defmacro{DFAtan} -Compute a strongly typed doublefloat atan -See Steele Common Lisp 1990 p305 -\begin{chunk}{defmacro DFAtan} -(defmacro DFAtan (x) - `(the double-float (atan (the double-float ,x)))) +\defun{getRefvU32}{getRefvU32} +\begin{chunk}{defun getRefvU32} +(defun getRefvU32 (n x) + (make-array n :initial-element x :element-type '(unsigned-byte 32))) \end{chunk} -\defmacro{DFAtan2} -Compute a strongly typed doublefloat atan with 2 arguments +\section{U8Matrix} -\begin{tabular}{lllc} -$y = 0$ & $x > 0$ & Positive x-axis & 0\\ -$y > 0$ & $x > 0$ & Quadrant I & $0 <$ result $< \pi/2$\\ -$y > 0$ & $x = 0$ & Positive y-axis & $\pi/2$\\ -$y > 0$ & $x < 0$ & Quadrant II & $\pi/2 <$ result $<\pi$\\ -$y = 0$ & $x < 0$ & Negative x-axis & $\pi$\\ -$y < 0$ & $x < 0$ & Quadrant III & $-\pi <$ result $< -\pi/2$\\ -$y < 0$ & $x = 0$ & Negative y-axis & $-\pi/2$\\ -$y < 0$ & $x > 0$ & Quadrant IV & $-\pi/2 <$ result $< 0$\\ -$y = 0$ & $x = 0$ & Origin & error -\end{tabular} +\defmacro{aref2U8} +\begin{chunk}{defmacro aref2U8} +(defmacro aref2U8 (v i j) + `(aref (the (simple-array (unsigned-byte 8) (* *)) ,v) ,i ,j)) -See Steele Common Lisp 1990 p306 -\begin{chunk}{defmacro DFAtan2} -(defmacro DFAtan2 (y x) - `(the double-float (atan (the double-float ,x) (the double-float ,y)))) +\end{chunk} + +\defmacro{setAref2U8} +\begin{chunk}{defmacro setAref2U8} +(defmacro setAref2U8 (v i j s) + `(setf (aref (the (simple-array (unsigned-byte 8) (* *)) ,v) ,i ,j), s)) + +\end{chunk} + +\defmacro{anrowsU8} +\begin{chunk}{defmacro anrowsU8} +(defmacro anrowsU8 (v) + `(array-dimension (the (simple-array (unsigned-byte 8) (* *)) ,v) 0)) \end{chunk} -\defmacro{DFSinh} -Compute a strongly typed doublefloat sinh -\[(e^z-e^{-z})/2\] -See Steele Common Lisp 1990 p308 -\begin{chunk}{defmacro DFSinh} -(defmacro DFSinh (x) - `(the double-float (sinh (the double-float ,x)))) +\defmacro{ancolsU8} +\begin{chunk}{defmacro ancolsU8} +(defmacro ancolsU8 (v) + `(array-dimension (the (simple-array (unsigned-byte 8) (* *)) ,v) 1)) \end{chunk} -\defmacro{DFCosh} -Compute a strongly typed doublefloat cosh -\[(e^z+e^{-z})/2\] -See Steele Common Lisp 1990 p308 -\begin{chunk}{defmacro DFCosh} -(defmacro DFCosh (x) - `(the double-float (cosh (the double-float ,x)))) +\defmacro{makeMatrixU8} +\begin{chunk}{defmacro makeMatrixU8} +(defmacro makeMatrixU8 (n m) + `(make-array (list ,n ,m) :element-type '(unsigned-byte 8) + :initial-element 0)) \end{chunk} -\defmacro{DFTanh} -Compute a strongly typed doublefloat tanh -\[(e^z-e^{-z})/(e^z+e^{-z})\] -See Steele Common Lisp 1990 p308 -\begin{chunk}{defmacro DFTanh} -(defmacro DFTanh (x) - `(the double-float (tanh (the double-float ,x)))) +\defmacro{makeMatrix1U8} +\begin{chunk}{defmacro makeMatrix1U8} +(defmacro makeMatrix1U8 (n m s) + `(make-array (list ,n ,m) :element-type '(unsigned-byte 8) + :initial-element ,s)) \end{chunk} -\defmacro{DFAsinh} -Compute the inverse hyperbolic sin. -\[log\left(z+\sqrt{1+z^2}\right)\] -See Steele Common Lisp 1990 p308 -\begin{chunk}{defmacro DFAsinh} -(defmacro DFAsinh (x) - `(the double-float (asinh (the double-float ,x)))) +\section{U16Matrix} + +\defmacro{aref2U16} +\begin{chunk}{defmacro aref2U16} +(defmacro aref2U16 (v i j) + `(aref (the (simple-array (unsigned-byte 16) (* *)) ,v) ,i ,j)) \end{chunk} -\defmacro{DFAcosh} -Compute the inverse hyperbolic cos. Note that the acosh function will return -a complex result if the argument is less than 1. -\[log\left(z+(z+1)\sqrt{(z-1)/(z+1)}\right)\] -See Steele Common Lisp 1990 p308 -\begin{chunk}{defmacro DFAcosh} -(defmacro DFAcosh (x) - `(acosh (the double-float ,x))) +\defmacro{setAref2U16} +\begin{chunk}{defmacro setAref2U16} +(defmacro setAref2U16 (v i j s) + `(setf (aref (the (simple-array (unsigned-byte 16) (* *)) ,v) ,i ,j), s)) \end{chunk} -\defmacro{DFAtanh} -Compute the inverse hyperbolic tan. Note that the acosh function will return -a complex result if the argument is greater than 1. -\[log\left((1+z)\sqrt{1/(1-z^2)}\right)\] -See Steele Common Lisp 1990 p308 -\begin{chunk}{defmacro DFAtanh} -(defmacro DFAtanh (x) - `(atanh (the double-float ,x))) +\defmacro{anrowsU16} +\begin{chunk}{defmacro anrowsU16} +(defmacro anrowsU16 (v) + `(array-dimension (the (simple-array (unsigned-byte 16) (* *)) ,v) 0)) \end{chunk} -\defun{integer-decode-float-numerator}{Machine specific float numerator} -This is used in the DoubleFloat integerDecode function -\begin{chunk}{defun integer-decode-float-numerator 0} -(defun integer-decode-float-numerator (x) - (integer-decode-float x)) +\defmacro{ancolsU16} +\begin{chunk}{defmacro ancolsU16} +(defmacro ancolsU16 (v) + `(array-dimension (the (simple-array (unsigned-byte 16) (* *)) ,v) 1)) \end{chunk} -\defun{integer-decode-float-denominator}{Machine specific float denominator} -This is used in the DoubleFloat integerDecode function -\begin{chunk}{defun integer-decode-float-denominator 0} -(defun integer-decode-float-denominator (x) - (multiple-value-bind (mantissa exponent sign) (integer-decode-float x) - (declare (ignore mantissa sign)) (expt 2 (abs exponent)))) +\defmacro{makeMatrixU16} +\begin{chunk}{defmacro makeMatrixU16} +(defmacro makeMatrixU16 (n m) + `(make-array (list ,n ,m) :element-type '(unsigned-byte 16) + :initial-element 0)) \end{chunk} -\defun{integer-decode-float-sign}{Machine specific float sign} -This is used in the DoubleFloat integerDecode function -\begin{chunk}{defun integer-decode-float-sign 0} -(defun integer-decode-float-sign (x) - (multiple-value-bind (mantissa exponent sign) (integer-decode-float x) - (declare (ignore mantissa exponent)) sign)) +\defmacro{makeMatrix1U16} +\begin{chunk}{defmacro makeMatrix1U16} +(defmacro makeMatrix1U16 (n m s) + `(make-array (list ,n ,m) :element-type '(unsigned-byte 16) + :initial-element ,s)) \end{chunk} -\defun{integer-decode-float-exponent}{Machine specific float bit length} -This is used in the DoubleFloat integerDecode function -\begin{chunk}{defun integer-decode-float-exponent 0} -(defun integer-decode-float-exponent (x) - (multiple-value-bind (mantissa exponent sign) (integer-decode-float x) - (declare (ignore mantissa sign)) exponent)) +\section{\enspace{}U32Matrix} + +\defmacro{aref2U32} +\begin{chunk}{defmacro aref2U32} +(defmacro aref2U32 (v i j) + `(aref (the (simple-array (unsigned-byte 32) (* *)) ,v) ,i ,j)) \end{chunk} -\defun{manexp}{Decode floating-point values} -This function is used by DoubleFloat to implement the ``mantissa'' and -``exponent'' functions. -\begin{chunk}{defun manexp 0} -(defun manexp (u) - (multiple-value-bind (f e s) - (decode-float u) - (cons (* s f) e))) +\defmacro{setAref2U32} +\begin{chunk}{defmacro setAref2U32} +(defmacro setAref2U32 (v i j s) + `(setf (aref (the (simple-array (unsigned-byte 32) (* *)) ,v) ,i ,j), s)) \end{chunk} -\defun{cot}{The cotangent routine} -The cotangent function is defined as -\[cot(z) = \frac{1}{tan(z)}\] -\begin{chunk}{defun cot 0} -(defun cot (a) - (if (or (> a 1000.0) (< a -1000.0)) - (/ (cos a) (sin a)) - (/ 1.0 (tan a)))) +\defmacro{anrowsU32} +\begin{chunk}{defmacro anrowsU32} +(defmacro anrowsU32 (v) + `(array-dimension (the (simple-array (unsigned-byte 32) (* *)) ,v) 0)) \end{chunk} -\defun{acot}{The inverse cotangent function} -The inverse cotangent (arc-cotangent) function is defined as -\[acot(z) = cot^{-1}(z) = tan^{-1}(\frac{1}{z})\] -See Steele Common Lisp 1990 pp305-307 -\begin{chunk}{defun acot 0} -(defun acot (a) - (if (> a 0.0) - (if (> a 1.0) - (atan (/ 1.0 a)) - (- (/ pi 2.0) (atan a))) - (if (< a -1.0) - (- pi (atan (/ -1.0 a))) - (+ (/ pi 2.0) (atan (- a)))))) +\defmacro{ancolsU32} +\begin{chunk}{defmacro ancolsU32} +(defmacro ancolsU32 (v) + `(array-dimension (the (simple-array (unsigned-byte 32) (* *)) ,v) 1)) \end{chunk} -\defun{sec}{The secant function} -\[sec(x) = \frac{1}{cos(x)}\] -\begin{chunk}{defun sec 0} -(defun sec (x) (/ 1 (cos x))) +\defmacro{makeMatrixU32} +\begin{chunk}{defmacro makeMatrixU32} +(defmacro makeMatrixU32 (n m) + `(make-array (list ,n ,m) :element-type '(unsigned-byte 32) + :initial-element 0)) \end{chunk} -\defun{asec}{The inverse secant function} -\[asec(x) = acos\left(\frac{1}{x}\right)\] -\begin{chunk}{defun asec 0} -(defun asec (x) (acos (/ 1 x))) +\defmacro{makeMatrix1U32} +\begin{chunk}{defmacro makeMatrix1U32} +(defmacro makeMatrix1U32 (n m s) + `(make-array (list ,n ,m) :element-type '(unsigned-byte 32) + :initial-element ,s)) \end{chunk} -\defun{csc}{The cosecant function} -\[csc(x) = \frac{1}{sin(x)}\] -\begin{chunk}{defun csc 0} -(defun csc (x) (/ 1 (sin x))) +\section{\enspace{}U32VectorPolynomialOperations} + +\defmacro{qsMulAdd6432} +\begin{chunk}{defmacro qsMulAdd6432} +(defmacro qsMulAdd6432 (x y z) + `(the (unsigned-byte 64) + (+ (the (unsigned-byte 64) + (* (the (unsigned-byte 32) ,x) + (the (unsigned-byte 32) ,y))) + (the (unsigned-byte 64) ,z)))) \end{chunk} -\defun{acsc}{The inverse cosecant function} -\[acsc(x) = \frac{1}{asin(x)}\] -\begin{chunk}{defun acsc 0} -(defun acsc (x) (asin (/ 1 x))) +\defmacro{qsMulMod32} +\begin{chunk}{defmacro qsMulMod32} +(defmacro qsMulMod32 (x y) + `(the (unsigned-byte 64) + (* (the (unsigned-byte 32) ,x) + (the (unsigned-byte 32) ,y)))) \end{chunk} -\defun{csch}{The hyperbolic cosecant function} -\[csch(x) = \frac{1}{sinh(x)} \] -\begin{chunk}{defun csch 0} -(defun csch (x) (/ 1 (sinh x))) +\defmacro{qsMod6432} +\begin{chunk}{defmacro qsMod6432} +(defmacro qsMod6432 (x p) + `(the (unsigned-byte 32) + (rem (the (unsigned-byte 64) ,x) (the (unsigned-byte 32) ,p)))) \end{chunk} -\defun{coth}{The hyperbolic cotangent function} -\[coth(x) = cosh(x) csch(x)\] -\begin{chunk}{defun coth 0} -(defun coth (x) (* (cosh x) (csch x))) +\defmacro{qsMulAddMod6432} +\begin{chunk}{defmacro qsMulAddMod6432} +(defmacro qsMulAddMod6432 (x y z p) + `(qsMod6432 (qsMulAdd6432 ,x ,y ,z) ,p)) \end{chunk} -\defun{sech}{The hyperbolic secant function} -\[sech(x) = \frac{1}{cosh(x)}\] -\begin{chunk}{defun sech 0} -(defun sech (x) (/ 1 (cosh x))) +\defmacro{qsMul6432} +\begin{chunk}{defmacro qsMul6432} +(defmacro qsMul6432 (x y) + `(the (unsigned-byte 64) + (* (the (unsigned-byte 32) ,x) + (the (unsigned-byte 32) ,y)))) \end{chunk} -\defun{acsch}{The inverse hyperbolic cosecant function} -\[acsch(x) = asinh\left(\frac{1}{x}\right)\] -\begin{chunk}{defun acsch 0} -(defun acsch (x) (asinh (/ 1 x))) +\defmacro{qsDot26432} +\begin{chunk}{defmacro qsDot26432} +(defmacro qsDot26432 (a1 b1 a2 b2) + `(qsMulAdd6432 ,a1 ,b1 (qsMul6432 ,a2 ,b2))) \end{chunk} -\defun{acoth}{The inverse hyperbolic cotangent function} -\[acoth(x) = atanh\left(\frac{1}{x}\right)\] -\begin{chunk}{defun acoth 0} -(defun acoth (x) (atanh (/ 1 x))) +\defmacro{qsDot2Mod6432} +\begin{chunk}{defmacro qsDot2Mod6432} +(defmacro qsDot2Mod6432 (a1 b1 a2 b2 p) + `(qsMod6432 (qsDot26432 ,a1 ,b1 ,a2 ,b2) ,p)) \end{chunk} -\defun{asech}{The inverse hyperbolic secant function} -\[asech(x) = acosh\left(\frac{1}{x}\right)\] -\begin{chunk}{defun asech 0} -(defun asech (x) (acosh (/ 1 x))) +%%% V %%% + +\section{Void} +\defun{voidValue}{voidValue} +\begin{chunk}{defun voidValue} +(defun |voidValue| () "()") \end{chunk} @@ -60555,6 +60614,7 @@ digits in TechExplorer. Since Saturn is gone we can remove it. \getchunk{defun domArg} \getchunk{defun domArg2} \getchunk{defun doSystemCommand} +\getchunk{defun downcase} \getchunk{defun downlink} \getchunk{defun downlinkSaturn} \getchunk{defun dqConcat} @@ -61783,6 +61843,7 @@ digits in TechExplorer. Since Saturn is gone we can remove it. \getchunk{defun untraceDomainLocalOps} \getchunk{defun untraceMapSubNames} \getchunk{defun unwritable?} +\getchunk{defun upcase} \getchunk{defun updateCurrentInterpreterFrame} \getchunk{defun updateDatabase} \getchunk{defun updateFromCurrentInterpreterFrame} diff --git a/books/bookvol9.pamphlet b/books/bookvol9.pamphlet index ef8d017..768ca59 100644 --- a/books/bookvol9.pamphlet +++ b/books/bookvol9.pamphlet @@ -7734,7 +7734,7 @@ Code for encoding function names inside package or domain \defun{getCaps}{getCaps} \calls{getCaps}{stringimage} \calls{getCaps}{maxindex} -\calls{getCaps}{l-case} +\calls{getCaps}{downcase} \calls{getCaps}{strconc} \begin{chunk}{defun getCaps} (defun |getCaps| (x) @@ -7748,7 +7748,7 @@ Code for encoding function names inside package or domain ((null clist) "_") (t (setq tmp1 - (cons (first clist) (loop for u in (rest clist) collect (l-case u)))) + (cons (first clist) (loop for u in (rest clist) collect (downcase u)))) (let ((result "")) (loop for u in tmp1 do (setq result (strconc result u))) diff --git a/changelog b/changelog index c24c60f..cd06cd8 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,9 @@ +20150425 tpd src/axiom-website/patches.html 20150425.01.tpd.patch +20150425 tpd src/interp/vmlisp.lisp move/collect/reorder algebra support code +20150425 tpd books/bookvol9 move/collect/reorder algebra support code +20150425 tpd books/bookvol5 move/collect/reorder algebra support code +20150424 tpd src/axiom-website/patches.html 20150424.06.tpd.patch +20150324 tpd books/bookvol5 add )license command 20150424 tpd src/axiom-website/patches.html 20150424.05.tpd.patch 20150424 tpd books/bookvol5 remove )zsys support 20150424 tpd books/bookvol9 remove )zsys support diff --git a/patch b/patch index bd76c98..c47e8e8 100644 --- a/patch +++ b/patch @@ -1,6 +1,6 @@ -src/interp/vmlisp.lisp remove unused code +books/bookvol5 move/collect/reorder algebra support code + +The Common Lisp Algebra Support chapter contains functions which +are used in the algebra. These were collected and reordered by +domain. -This file contains a lot of code I wrote to port Axiom to different -systems (vmlisp, golden common lisp, maclisp, symbolics lisp, etc). -Most of this code is not used, especially the zsystemdevelopment -support which is also removed. diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 525795c..b24d44b 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -5032,6 +5032,10 @@ books/bookvolbib fix typo
books/bookvolbib fix typo
20150424.05.tpd.patch src/interp/vmlisp.lisp remove dead code, )zsys support code
+20150424.06.tpd.patch +books/bookvol5 add )license command
+20150425.01.tpd.patch +books/bookvol5 move/collect/reorder algebra support code
diff --git a/src/interp/vmlisp.lisp.pamphlet b/src/interp/vmlisp.lisp.pamphlet index 809d1d0..16934c5 100644 --- a/src/interp/vmlisp.lisp.pamphlet +++ b/src/interp/vmlisp.lisp.pamphlet @@ -602,22 +602,6 @@ documentclass{article} ; 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)))) - -(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 (defun put (sym ind val) (setf (get sym ind) val)) -- 1.7.5.4