diff --git a/changelog b/changelog index 344843e..600b39f 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,8 @@ +20090806 tpd src/axiom-website/patches.html 20090806.01.tpd.patch +20090806 tpd src/interp/Makefile remove macros.lisp +20090806 tpd src/interp/debugsys.lisp remove macros reference +20090806 tpd src/interp/vmlisp.lisp merge macros.lisp +20090806 tpd src/interp/macros.lisp removed, merged with vmlisp.lisp 20090805 tpd src/axiom-website/patches.html 20090805.04.tpd.patch 20090805 tpd src/interp/Makefile remove nlib.lisp 20090805 tpd src/interp/debugsys.lisp remove nlib reference diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 5681a33..a9f4901 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -1748,6 +1748,8 @@ vmlisp.lisp and bootfuns.lisp merged
vmlisp.lisp and union.lisp merged
20090805.04.tpd.patch vmlisp.lisp and nlib.lisp merged
+20090806.01.tpd.patch +vmlisp.lisp and macros.lisp merged
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index f2a884c..3777415 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -128,7 +128,7 @@ expanded in later compiles. All macros are assumed to be in this list of files. <>= DEP= ${MID}/vmlisp.lisp \ - ${MID}/macros.lisp ${MID}/comp.lisp \ + ${MID}/comp.lisp \ ${MID}/spaderror.lisp ${MID}/debug.lisp \ ${MID}/spad.lisp ${MID}/bits.lisp \ ${MID}/setq.lisp ${MID}/property.lisp \ @@ -176,7 +176,6 @@ The file http.lisp contains code to enable browser-based hyperdoc and graphics. <>= OBJS= ${OUT}/vmlisp.${O} \ - ${OUT}/macros.${O} \ ${OUT}/unlisp.${O} ${OUT}/setq.${LISP} \ ${OUT}/astr.${O} ${OUT}/bits.${O} \ ${OUT}/alql.${O} ${OUT}/buildom.${O} \ @@ -459,7 +458,7 @@ DOCFILES=${DOC}/alql.boot.dvi \ ${DOC}/i-syscmd.boot.dvi ${DOC}/iterator.boot.dvi \ ${DOC}/i-toplev.boot.dvi ${DOC}/i-util.boot.dvi \ ${DOC}/lisplib.boot.dvi ${DOC}/macex.boot.dvi \ - ${DOC}/macros.lisp.dvi ${DOC}/Makefile.dvi \ + ${DOC}/Makefile.dvi \ ${DOC}/mark.boot.dvi ${DOC}/match.boot.dvi \ ${DOC}/modemap.boot.dvi ${DOC}/monitor.lisp.dvi \ ${DOC}/msg.boot.dvi ${DOC}/msgdb.boot.dvi \ @@ -1318,40 +1317,6 @@ ${DOC}/hypertex.boot.dvi: ${IN}/hypertex.boot.pamphlet @ -\subsection{macros.lisp \cite{21}} -<>= -${OUT}/macros.${O}: ${MID}/macros.lisp - @ echo 63 making ${OUT}/macros.${O} from ${MID}/macros.lisp - @ ( cd ${MID} ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/macros.lisp"' \ - ':output-file "${OUT}/macros.${O}") (${BYE}))' | ${DEPSYS} ; \ - else \ - echo '(progn (compile-file "${MID}/macros.lisp"' \ - ':output-file "${OUT}/macros.${O}") (${BYE}))' | ${DEPSYS} \ - >${TMP}/trace ; \ - fi ) - -@ -<>= -${MID}/macros.lisp: ${IN}/macros.lisp.pamphlet - @ echo 64 making ${MID}/macros.lisp from ${IN}/macros.lisp.pamphlet - @ (cd ${MID} ; \ - ${TANGLE} ${IN}/macros.lisp.pamphlet >macros.lisp ) - -@ -<>= -${DOC}/macros.lisp.dvi: ${IN}/macros.lisp.pamphlet - @echo 65 making ${DOC}/macros.lisp.dvi from ${IN}/macros.lisp.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/macros.lisp.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} macros.lisp ; \ - rm -f ${DOC}/macros.lisp.pamphlet ; \ - rm -f ${DOC}/macros.lisp.tex ; \ - rm -f ${DOC}/macros.lisp ) - -@ - \subsection{monitor.lisp \cite{24}} <>= ${OUT}/monitor.${O}: ${MID}/monitor.lisp @@ -7519,10 +7484,6 @@ clean: <> <> -<> -<> -<> - <> <> @@ -7861,7 +7822,6 @@ pp \bibitem{14} {\bf \$SPAD/src/interp/debug.lisp.pamphlet} \bibitem{16} {\bf \$SPAD/src/interp/fortcall.boot.pamphlet} \bibitem{17} {\bf \$SPAD/src/interp/fname.lisp.pamphlet} -\bibitem{21} {\bf \$SPAD/src/interp/macros.lisp.pamphlet} \bibitem{24} {\bf \$SPAD/src/interp/monitor.lisp.pamphlet} \bibitem{25} {\bf \$SPAD/src/interp/newaux.lisp.pamphlet} \bibitem{27} {\bf \$SPAD/src/interp/nocompil.lisp.pamphlet} diff --git a/src/interp/debugsys.lisp.pamphlet b/src/interp/debugsys.lisp.pamphlet index 8c7397f..36574dd 100644 --- a/src/interp/debugsys.lisp.pamphlet +++ b/src/interp/debugsys.lisp.pamphlet @@ -85,7 +85,6 @@ loaded by hand we need to establish a value. (append (list (thesymb "/int/interp/vmlisp.lisp") - (thesymb "/int/interp/macros.lisp") (thesymb "/int/interp/unlisp.lisp") (thesymb "/int/interp/setq.lisp") (thesymb "/int/interp/astr.clisp") diff --git a/src/interp/macros.lisp.pamphlet b/src/interp/macros.lisp.pamphlet deleted file mode 100644 index 3b06048..0000000 --- a/src/interp/macros.lisp.pamphlet +++ /dev/null @@ -1,1675 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp macros.lisp} -\author{Timothy Daly} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\begin{verbatim} -PURPOSE: Provide generally useful macros and functions for MetaLanguage - and Boot code. Contents are organized along Common Lisp datatype - lines, with sections numbered to match the section headings of the - Common Lisp Reference Manual, by Guy Steele, Digital Press, 1984, - Digital Press Order Number EY-00031-DP. This way you can - look up the corresponding section in the manual and see if - there isn't a cleaner and non-VM-specific way of doing things. - -\end{verbatim} -\section{Performance change} -Camm has identified a performace problem during compiles. There is -a loop that continually adds one element to a vector. This causes -the vector to get extended by 1 and copied. These patches fix the -problem since vectors with fill pointers don't need to be copied. - -These cut out the lion's share of the gc problem -on this compile. 30min {\tt ->} 7 min on my box. There is still some gc -churning in cons pages due to many calls to 'list' with small n. One -can likely improve things further with an appropriate (declare -(:dynamic-extent ...)) in the right place -- gcl will allocate such -lists on the C stack (very fast). - -\subsection{lengthenvec} -The original code was: -\begin{verbatim} -(defun lengthenvec (v n) - (if (adjustable-array-p v) (adjust-array v n) - (replace (make-array n) v))) -\end{verbatim} - -<>= -(defun lengthenvec (v n) - (if - (and (array-has-fill-pointer-p v) (adjustable-array-p v)) - (if - (>= n (array-total-size v)) - (adjust-array v (* n 2) :fill-pointer n) - (progn - (setf (fill-pointer v) n) - v)) - (replace (make-array n :fill-pointer t) v))) - -@ -\subsection{make-init-vector} -The original code was -\begin{verbatim} -(defun make-init-vector (n val) (make-array n :initial-element val)) -\end{verbatim} - -<>= -(defun make-init-vector (n val) - (make-array n :initial-element val :fill-pointer t)) - -@ -\section{DEFUN CONTAINED} -The [[CONTAINED]] predicate is used to walk internal structures -such as modemaps to see if the $X$ object occurs within $Y$. One -particular use is in a function called [[isPartialMode]] (see -i-funsel.boot) to decide -if a modemap is only partially complete. If this is true then the -modemap will contain the constant [[$EmptyMode]]. So the call -ends up being [[CONTAINED |$EmptyMode| Y]]. -<>= -#-:CCL -(DEFUN CONTAINED (X Y) - (if (symbolp x) - (contained\,eq X Y) - (contained\,equal X Y))) - -(defun contained\,eq (x y) - (if (atom y) (eq x y) - (or (contained\,eq x (car y)) (contained\,eq x (cdr y))))) - -(defun contained\,equal (x y) - (cond ((atom y) (equal x y)) - ((equal x y) 't) - ('t (or (contained\,equal x (car y)) (contained\,equal x (cdr y)))))) - -@ -\section{License} -<>= -;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are -;; met: -;; -;; - Redistributions of source code must retain the above copyright -;; notice, this list of conditions and the following disclaimer. -;; -;; - Redistributions in binary form must reproduce the above copyright -;; notice, this list of conditions and the following disclaimer in -;; the documentation and/or other materials provided with the -;; distribution. -;; -;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the -;; names of its contributors may be used to endorse or promote products -;; derived from this software without specific prior written permission. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS -;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A -;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER -;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - -(provide 'Boot) - -(in-package "BOOT") - -(defvar |$compilingMap| ()) -(defvar |$definingMap| nil) - -(defmacro KAR (ARG) `(ifcar ,arg)) -(defmacro KDR (ARG) `(ifcdr ,arg)) -(defmacro KADR (ARG) `(ifcar (ifcdr ,arg))) -(defmacro KADDR (ARG) `(ifcar (ifcdr (ifcdr ,arg)))) - -; 5 PROGRAM STRUCTURE - -; 5.3 Top-Level Forms - -(defun SETANDFILE (x y) (LAM\,EVALANDFILEACTQ `(setq ,x ',y))) - -; 5.3.2 Declaring Global Variables and Named Constants - -(defmacro |function| (name) `(FUNCTION ,name)) -(defmacro |dispatchFunction| (name) `(FUNCTION ,name)) - -(defun |macrop| (fn) (and (identp fn) (macro-function fn))) - -; 6 PREDICATES - -; 6.2 Data Type Predicates - -; 6.3 Equality Predicates - -;; qeqcar should be used when you know the first arg is a pair -;; the second arg should either be a literal fixnum or a symbol -;; the car of the first arg is always of the same type as the second -;; use eql unless we are sure fixnums are represented canonically - -#-lucid -(defmacro qeqcar (x y) - (if (integerp y) `(eql (the fixnum (qcar ,x)) (the fixnum ,y)) - `(eq (qcar ,x) ,y))) - -#+lucid -(defmacro qeqcar (x y) `(eq (qcar ,x) ,y)) - - -(defun COMPARE (X Y) - "True if X is an atom or X and Y are lists and X and Y are equal up to X." - (COND ((ATOM X) T) - ((ATOM Y) NIL) - ((EQUAL (CAR X) (CAR Y)) (COMPARE (CDR X) (CDR Y))))) - - -(DEFUN ?ORDER (U V) "Multiple-type ordering relation." - (COND ((NULL U)) - ((NULL V) NIL) - ((ATOM U) - (if (ATOM V) - (COND ((NUMBERP U) (if (NUMBERP V) (> V U) T)) - ((NUMBERP V) NIL) - ((IDENTP U) (AND (IDENTP V) (string> (SYMBOL-NAME V) (SYMBOL-NAME U)))) - ((IDENTP V) NIL) - ((STRINGP U) (AND (STRINGP V) (string> V U))) - ((STRINGP V) NIL) - ((AND (VECP U) (VECP V)) - (AND (> (SIZE V) (SIZE U)) - (DO ((I 0 (1+ I))) - ((GT I (MAXINDEX U)) 'T) - (COND ((NOT (EQUAL (ELT U I) (ELT V I))) - (RETURN (?ORDER (ELT U I) (ELT V I)))))))) - ((croak "Do not understand"))) - T)) - ((ATOM V) NIL) - ((EQUAL U V)) - ((NOT (string> (write-to-string U) (write-to-string V)))))) - -(defmacro boot-equal (a b) - (cond ((ident-char-lit a) - `(or (eql ,a ,b) (eql (character ,a) ,b))) - ((ident-char-lit b) - `(or (eql ,a ,b) (eql ,a (character ,b)))) - (t `(eqqual ,a ,b)))) - -(defun ident-char-lit (x) - (and (eqcar x 'quote) (identp (cadr x)) (= (length (pname (cadr x))) 1))) - -(defmacro EQQUAL (a b) - (cond ((OR (EQUABLE a) (EQUABLE b)) `(eq ,a ,b)) - ((OR (numberp a) (numberp b)) `(eql ,a ,b)) - (t `(equal ,a ,b)))) - -(defmacro NEQUAL (a b) `(not (BOOT-EQUAL ,a ,b))) - -(defun EQUABLE (X) - (OR (NULL X) (AND (EQCAR X 'QUOTE) (symbolp (CADR X))))) - -; 7 CONTROL STRUCTURE - -; 7.1 Constants and Variables - -; 7.1.1 Reference - -(DEFUN MKQ (X) - "Evaluates an object and returns it with QUOTE wrapped around it." - (if (NUMBERP X) X (LIST 'QUOTE X))) - -; 7.2 Generalized Variables - -(defmacro IS (x y) `(dcq ,y ,x)) - -(defmacro LETT (var val &rest L) - (COND - (|$QuickLet| `(SETQ ,var ,val)) - (|$compilingMap| - ;; map tracing - `(PROGN - (SETQ ,var ,val) - (COND (|$letAssoc| - (|mapLetPrint| ,(MKQ var) - ,var - (QUOTE ,(KAR L)))) - ('T ,var)))) - ;; used for LETs in SPAD code --- see devious trick in COMP,TRAN,1 - ((ATOM var) - `(PROGN - (SETQ ,var ,val) - (IF |$letAssoc| - ,(cond ((null (cdr l)) - `(|letPrint| ,(MKQ var) ,var (QUOTE ,(KAR L)))) - ((and (eqcar (car l) 'SPADCALL) (= (length (car l)) 3)) - `(|letPrint3| ,(MKQ var) ,var ,(third (car l)) (QUOTE ,(KADR L)))) - (t `(|letPrint2| ,(MKQ var) ,(car l) (QUOTE ,(KADR L)))))) - ,var)) - ('T (ERROR "Cannot compileLET construct")))) - -(defmacro SPADLET (A B) - (if (ATOM A) `(SETQ ,A ,B) - `(OR (IS ,B ,A) (LET_ERROR ,(MK_LEFORM A) ,(MKQ B) )))) - -(defmacro RPLAC (&rest L) - (if (EQCAR (CAR L) 'ELT) - (LIST 'SETELT (CADAR L) (CADDR (CAR L)) (CADR L)) - (let ((A (CARCDREXPAND (CAR L) NIL)) (B (CADR L))) - (COND ((CDDR L) (ERROR 'RPLAC)) - ((EQCAR A 'CAR) (LIST 'RPLACA (CADR A) B)) - ((EQCAR A 'CDR) (LIST 'RPLACD (CADR A) B)) - ((ERROR 'RPLAC)))))) - -(MAPC #'(LAMBDA (J) (MAKEPROP (CAR J) 'SELCODE (CADR J))) - '((CAR 2) (CDR 3) (CAAR 4) (CADR 5) (CDAR 6) (CDDR 7) - (CAAAR 8) (CAADR 9) (CADAR 10) (CADDR 11) (CDAAR 12) - (CDADR 13) (CDDAR 14) (CDDDR 15) (CAAAAR 16) (CAAADR 17) - (CAADAR 18) (CAADDR 19) (CADAAR 20) (CADADR 21) (CADDAR 22) - (CADDDR 23) (CDAAAR 24) (CDAADR 25) (CDADAR 26) (CDADDR 27) - (CDDAAR 28) (CDDADR 29) (CDDDAR 30) (CDDDDR 31))) - -(eval-when (compile eval load) -(defun CARCDREXPAND (X FG) ; FG = TRUE FOR CAR AND CDR - (let (n hx) - (COND ((ATOM X) X) - ((SETQ N (GET (RENAME (SETQ HX (CARCDREXPAND (CAR X) FG))) 'SELCODE)) - (CARCDRX1 (CARCDREXPAND (CADR X) FG) N FG)) - ((CONS HX (MAPCAR #'(LAMBDA (Y) (CARCDREXPAND Y FG)) (CDR X))))))) - -(DEFUN RENAME (U) - (let (x) - (if (AND (IDENTP U) (SETQ X (GET U 'NEWNAM))) X U))) - -(defun CARCDRX1 (X N FG) ; FG = TRUE FOR CAR AND CDR - (COND ((< N 1) (fail)) - ((EQL N 1) X) - ((let ((D (DIVIDE N 2))) - (CARCDRX1 (LIST (if (EQL (CADR D) 0) (if FG 'CAR 'CAR) (if FG 'CDR 'CDR)) X) - (CAR D) - FG)))))) - - -; 7.3 Function Invocation - -(DEFUN APPLYR (L X) (if (not L) X (LIST (CAR L) (APPLYR (CDR L) X)))) - -; 7.8 Iteration - -; 7.8.2 General Iteration - -(defmacro REPEAT (&rest L) - (let ((U (REPEAT-TRAN L NIL))) (-REPEAT (CDR U) (CAR U)))) - -(defun REPEAT-TRAN (L LP) - (COND ((ATOM L) (ERROR "REPEAT FORMAT ERROR")) - ((MEMBER (KAR (KAR L)) - '(EXIT RESET IN ON GSTEP ISTEP STEP GENERAL UNTIL WHILE SUCHTHAT EXIT)) - (REPEAT-TRAN (CDR L) (CONS (CAR L) LP))) - ((CONS (NREVERSE LP) (MKPF L 'PROGN))))) - -(DEFUN MKPF (L OP) - (if (FLAGP OP 'NARY) (SETQ L (MKPFFLATTEN-1 L OP NIL))) - (MKPF1 L OP)) - -(DEFUN MKPFFLATTEN (X OP) - (COND ((ATOM X) X) - ((EQL (CAR X) OP) (CONS OP (MKPFFLATTEN-1 (CDR X) OP NIL))) - ((CONS (MKPFFLATTEN (CAR X) OP) (MKPFFLATTEN (CDR X) OP))))) - -(DEFUN MKPFFLATTEN-1 (L OP R) - (let (X) - (if (NULL L) - R - (MKPFFLATTEN-1 (CDR L) OP - (APPEND R (if (EQCAR (SETQ X - (MKPFFLATTEN (CAR L) OP)) OP) - (CDR X) (LIST X))))))) - -(DEFUN MKPF1 (L OP) - (let (X) (case OP (PLUS (COND ((EQL 0 (SETQ X (LENGTH - (SETQ L (S- L '(0 (ZERO))))))) 0) - ((EQL 1 X) (CAR L)) - ((CONS 'PLUS L)) )) - (TIMES (COND ((S* L '(0 (ZERO))) 0) - ((EQL 0 (SETQ X (LENGTH - (SETQ L (S- L '(1 (ONE))))))) 1) - ((EQL 1 X) (CAR L)) - ((CONS 'TIMES L)) )) - (QUOTIENT (COND ((GREATERP (LENGTH L) 2) (fail)) - ((EQL 0 (CAR L)) 0) - ((EQL (CADR L) 1) (CAR L)) - ((CONS 'QUOTIENT L)) )) - (MINUS (COND ((CDR L) (FAIL)) - ((NUMBERP (SETQ X (CAR L))) (MINUS X)) - ((EQCAR X 'MINUS) (CADR X)) - ((CONS 'MINUS L)) )) - (DIFFERENCE (COND ((GREATERP (LENGTH L) 2) (FAIL)) - ((EQUAL (CAR L) (CADR L)) '(ZERO)) - ((|member| (CAR L) '(0 (ZERO))) (MKPF (CDR L) 'MINUS)) - ((|member| (CADR L) '(0 (ZERO))) (CAR L)) - ((EQCAR (CADR L) 'MINUS) - (MKPF (LIST (CAR L) (CADADR L)) 'PLUS)) - ((CONS 'DIFFERENCE L)) )) - (EXPT (COND ((GREATERP (LENGTH L) 2) (FAIL)) - ((EQL 0 (CADR L)) 1) - ((EQL 1 (CADR L)) (CAR L)) - ((|member| (CAR L) '(0 1 (ZERO) (ONE))) (CAR L)) - ((CONS 'EXPT L)) )) - (OR (COND ((MEMBER 'T L) ''T) - ((EQL 0 (SETQ X (LENGTH (SETQ L (REMOVE NIL L))))) NIL) - ((EQL 1 X) (CAR L)) - ((CONS 'OR L)) )) - (|or| (COND ((MEMBER 'T L) 'T) - ((EQL 0 (SETQ X (LENGTH (SETQ L (REMOVE NIL L))))) NIL) - ((EQL 1 X) (CAR L)) - ((CONS 'or L)) )) - (NULL (COND ((CDR L) (FAIL)) - ((EQCAR (CAR L) 'NULL) (CADAR L)) - ((EQL (CAR L) 'T) NIL) - ((NULL (CAR L)) ''T) - ((CONS 'NULL L)) )) - (|and| (COND ((EQL 0 (SETQ X (LENGTH - (SETQ L (REMOVE T (REMOVE '|true| L)))))) T) - ((EQL 1 X) (CAR L)) - ((CONS '|and| L)) )) - (AND (COND ((EQL 0 (SETQ X (LENGTH - (SETQ L (REMOVE T (REMOVE '|true| L)))))) ''T) - ((EQL 1 X) (CAR L)) - ((CONS 'AND L)) )) - (PROGN (COND ((AND (NOT (ATOM L)) (NULL (LAST L))) - (if (CDR L) `(PROGN . ,L) (CAR L))) - ((NULL (SETQ L (REMOVE NIL L))) NIL) - ((CDR L) (CONS 'PROGN L)) - ((CAR L)))) - (SEQ (COND ((EQCAR (CAR L) 'EXIT) (CADAR L)) - ((CDR L) (CONS 'SEQ L)) - ((CAR L)))) - (LIST (if L (cons 'LIST L))) - (CONS (if (cdr L) (cons 'CONS L) (car L))) - (t (CONS OP L) )))) - -(defvar $TRACELETFLAG NIL "Also referred to in Comp.Lisp") - -(defmacro |Zero| (&rest L) - (declare (ignore l)) - "Needed by spadCompileOrSetq" 0) - -(defmacro |One| (&rest L) - (declare (ignore l)) - "Needed by spadCompileOrSetq" 1) - -(defun -REPEAT (BD SPL) - (let (u g g1 inc final xcl xv il rsl tll funPLUS funGT fun? funIdent - funPLUSform funGTform) - (DO ((X SPL (CDR X))) - ((ATOM X) - (LIST 'spadDO (NREVERSE IL) (LIST (MKPF (NREVERSE XCL) 'OR) XV) - (SEQOPT (CONS 'SEQ (NCONC (NREVERSE RSL) (LIST (LIST 'EXIT BD))))))) - (COND ((ATOM (CAR X)) (FAIL))) - (COND ((AND (EQ (CAAR X) 'STEP) - (|member| (CADDAR X) '(2 1 0 (|One|) (|Zero|))) - (|member| (CADR (CDDAR X)) '(1 (|One|)))) - (SETQ X (CONS (CONS 'ISTEP (CDAR X)) (CDR X))) )) - ; A hack to increase the likelihood of small integers - (SETQ U (CDAR X)) - (case (CAAR X) - (GENERAL (AND (CDDDR U) (PUSH (CADDDR U) XCL)) - (PUSH (LIST (CAR U) (CADR U) (CADDR U)) IL) ) - (GSTEP - (SETQ tll (CDDDDR U)) ;tll is (+fun >fun type? ident) - (SETQ funPLUSform (CAR tll)) - (SETQ funGTform (CAR (SETQ tll (QCDR tll)))) - (PUSH (LIST (SETQ funPLUS (GENSYM)) funPLUSform) IL) - (PUSH (LIST (SETQ funGT (GENSYM)) funGTform) IL) - (COND ((SETQ tll (CDR tll)) - (SETQ fun? (CAR tll)) - (SETQ funIdent (CAR (SETQ tll (QCDR tll)))))) - (IF (NOT (ATOM (SETQ inc (CADDR U)) )) - (PUSH (LIST (SETQ inc (GENSYM)) (CADDR U)) IL)) - (SETQ final (CADDDR U)) - (COND (final - (COND ((ATOM final)) - ((PUSH (LIST (SETQ final (GENSYM)) (CADDDR U)) IL))) - ; If CADDDR U is not an atom, only compute the value once - (PUSH - (if fun? - (if (FUNCALL fun? INC) - (if (FUNCALL (EVAL funGTform) INC funIdent) - (LIST 'FUNCALL funGT (CAR U) FINAL) - (LIST 'FUNCALL funGT FINAL (CAR U))) - (LIST 'IF (LIST 'FUNCALL funGT INC funIdent) - (LIST 'FUNCALL funGT (CAR U) FINAL) - (LIST 'FUNCALL funGT FINAL (CAR U)))) - (LIST 'FUNCALL funGT (CAR U) final)) - XCL))) - (PUSH (LIST (CAR U) (CADR U) (LIST 'FUNCALL funPLUS (CAR U) INC)) IL)) - (STEP - (IF (NOT (ATOM (SETQ inc (CADDR U)) )) - (PUSH (LIST (SETQ inc (GENSYM)) (CADDR U)) IL)) - (COND ((CDDDR U) - (COND ((ATOM (SETQ final (CADDDR U)) )) - ((PUSH (LIST (SETQ final (GENSYM)) (CADDDR U)) IL))) - ; If CADDDR U is not an atom, only compute the value once - (PUSH - (if (INTEGERP INC) - (LIST (if (MINUSP INC) '< '>) (CAR U) FINAL) - `(if (MINUSP ,INC) - (< ,(CAR U) ,FINAL) - (> ,(CAR U) ,FINAL))) - XCL))) - (PUSH (LIST (CAR U) (CADR U) (LIST '+ (CAR U) INC)) IL)) - (ISTEP - (IF (NOT (ATOM (SETQ inc (CADDR U)) )) - (PUSH (LIST (SETQ inc (GENSYM)) (CADDR U)) IL)) - (COND ((CDDDR U) - (COND ((ATOM (SETQ final (CADDDR U)) )) - ((PUSH (LIST (SETQ final (GENSYM)) (CADDDR U)) IL))) - ; If CADDDR U is not an atom, only compute the value once - (PUSH - (if (INTEGERP INC) - (LIST (if (QSMINUSP INC) 'QSLESSP 'QSGREATERP) - (CAR U) FINAL) - `(if (QSMINUSP ,INC) - (QSLESSP ,(CAR U) ,FINAL) - (QSGREATERP ,(CAR U) ,FINAL))) - XCL))) - (PUSH (LIST (CAR U) (CADR U) - (COND ((|member| INC '(1 (|One|))) - (MKQSADD1 (CAR U))) - ((LIST 'QSPLUS (CAR U) INC)) )) - IL)) - (ON (PUSH (LIST 'ATOM (CAR U)) XCL) - (PUSH (LIST (CAR U) (CADR U) (LIST 'CDR (CAR U))) IL)) - (RESET (PUSH (LIST 'PROGN (CAR U) NIL) XCL)) - (IN - (PUSH (LIST 'OR - (LIST 'ATOM (SETQ G (GENSYM))) - (CONS 'PROGN - (CONS - (LIST 'SETQ (CAR U) (LIST 'CAR G)) - (APPEND - (COND ((AND (symbol-package (car U)) $TRACELETFLAG) - (LIST (LIST '/TRACELET-PRINT (CAR U) - (CAR U)))) - (NIL)) - (LIST NIL)))) ) XCL) - (PUSH (LIST G (CADR U) (LIST 'CDR G)) IL) - (PUSH (LIST (CAR U) NIL) IL)) - (INDOM (SETQ G (GENSYM)) - (SETQ G1 (GENSYM)) - (PUSH (LIST 'ATOM G) XCL) - (PUSH (LIST G (LIST 'INDOM-FIRST (CADR U)) - (LIST 'INDOM-NEXT G1)) IL) - (PUSH (LIST (CAR U) NIL) IL) - (PUSH (LIST G1 NIL) IL) - (PUSH (LIST 'SETQ G1 (LIST 'CDR G)) RSL) - (PUSH (LIST 'SETQ (CAR U) (LIST 'CAR G)) RSL)) - (UNTIL (SETQ G (GENSYM)) (PUSH (LIST G NIL (CAR U)) IL) (PUSH G XCL)) - (WHILE (PUSH (LIST 'NULL (CAR U)) XCL)) - (SUCHTHAT (SETQ BD (LIST 'SUCHTHATCLAUSE BD (CAR U)))) - (EXIT (SETQ XV (CAR U))) (FAIL))))) - - -(defun SEQOPT (U) - (if (AND (EQCAR U 'SEQ) (EQCAR (CADR U) 'EXIT) (EQCAR (CADADR U) 'SEQ)) - (CADADR U) - U)) - -(defmacro SUCHTHATCLAUSE (&rest L) (LIST 'COND (LIST (CADR L) (CAR L)))) - -(defvar $NEWSPAD NIL) -(defvar $BOOT NIL) - -(defmacro spadDO (&rest OL) - (PROG (VARS L VL V U INITS U-VARS U-VALS ENDTEST EXITFORMS BODYFORMS) - (if (OR $BOOT (NOT $NEWSPAD)) (return (CONS 'DO OL))) - (SETQ L (copy-list OL)) - (if (OR (ATOM L) (ATOM (CDR L))) (GO BADO)) - (setq vl (POP L)) - (COND ((IDENTP VL) - (SETQ VARS (LIST VL)) - (AND (OR (ATOM L) - (ATOM (progn (setq inits (POP L)) L)) - (ATOM (progn (setq u-vals (pop L)) L))) - (GO BADO)) - (SETQ INITS (LIST INITS) U-VARS (LIST (CAR VARS)) U-VALS (LIST U-VALS)) - (setq endtest (POP L))) - ((prog nil - (COND ((NULL VL) (GO TG5)) ((ATOM VL) (GO BADO))) - G180 (AND (NOT (PAIRP (SETQ V (CAR VL)))) (SETQ V (LIST V))) - (AND (NOT (IDENTP (CAR V))) (GO BADO)) - (PUSH (CAR V) VARS) - (PUSH (COND ((PAIRP (CDR V)) (CADR V))) INITS) - (AND (PAIRP (CDR V)) - (PAIRP (CDDR V)) - (SEQ (PUSH (CAR V) U-VARS) - (PUSH (CADDR V) U-VALS))) - (AND (PAIRP (progn (POP VL) VL)) (GO G180)) - TG5 (setq exitforms (POP L)) - (and (PAIRP EXITFORMS) - (progn (setq endtest (POP EXITFORMS)) exitforms))))) - (AND L - (COND ((CDR L) (SETQ BODYFORMS (CONS 'SEQ L))) - ((NULL (EQCAR (CAR L) 'SEQ)) (SETQ BODYFORMS (CONS 'SEQ L))) - ((SETQ BODYFORMS (CAR L))))) - (SETQ EXITFORMS `(EXIT ,(MKPF EXITFORMS 'PROGN))) - (AND ENDTEST (SETQ ENDTEST (LIST 'COND (LIST ENDTEST '(GO G191))))) - (COND ((NULL U-VARS) (GO XT) ) - ((NULL (CDR U-VARS)) - (SEQ (SETQ U-VARS (LIST 'SETQ (CAR U-VARS) (CAR U-VALS))) - (GO XT)) )) - (SETQ VL (LIST 'SETQ (CAR U-VARS) (CAR U-VALS))) - (SEQ (SETQ V (CDR U-VARS)) (SETQ U (CDR U-VALS))) - TG (SETQ VL (LIST 'SETQ (CAR V) (LIST 'PROG1 (CAR U) VL))) - (POP U) - (AND (progn (POP V) V) (GO TG)) - (SETQ U-VARS VL) - XT (RETURN (COND - ((AND $NEWSPAD (NULL $BOOT)) - (CONS 'SEQ (NCONC (DO_LET VARS INITS) - (LIST 'G190 ENDTEST BODYFORMS U-VARS '(GO G190) - 'G191 EXITFORMS)))) - ((CONS `(LAMBDA ,(NRECONC VARS NIL) - (SEQ G190 ,ENDTEST ,BODYFORMS ,U-VARS (GO G190) G191 ,EXITFORMS)) - (NRECONC INITS NIL))))) - BADO (ERROR (FORMAT NIL "BAD DO FORMAT~%~A" OL)))) - -(defun DO_LET (VARS INITS) - (if (OR (NULL VARS) (NULL INITS)) NIL - (CONS (LIST 'SPADLET (CAR VARS) (CAR INITS)) - (DO_LET (CDR VARS) (CDR INITS))))) - -#-:CCL -(defun NREVERSE0 (X) ; Already built-in to CCL - "Returns LST, reversed. The argument is modified. -This version is needed so that (COLLECT (IN X Y) ... (RETURN 'JUNK))=>JUNK." - (if (ATOM X) X (NREVERSE X))) - -; 7.8.4 Mapping - -(defmacro COLLECT (&rest L) - (let ((U (REPEAT-TRAN L NIL))) - (CONS 'THETA (CONS '\, (NCONC (CAR U) (LIST (CDR U))))))) - -;; The following was changed to a macro for efficiency in CCL. To change -;; it back to a function would require recompilation of a large chunk of -;; the library. -(defmacro PRIMVEC2ARR (x) x) ;redefine to change Array rep - -(defmacro COLLECTVEC (&rest L) - `(PRIMVEC2ARR (COLLECTV ,@L))) - -(defmacro COLLECTV (&rest L) - (PROG (CONDS BODY ANS COUNTER X Y) - ;If we can work out how often we will go round - ;allocate a vector first - (SETQ CONDS NIL) - (SETQ BODY (REVERSE L)) - (SETQ ANS (GENSYM)) - (SETQ COUNTER NIL) - (SETQ X (CDR BODY)) - (SETQ BODY (CAR BODY)) -LP (COND ((NULL X) - (COND ((NULL COUNTER) - (SETQ COUNTER (GENSYM)) - (SETQ L (CONS (LIST 'ISTEP COUNTER 0 1) L)) )) - (RETURN (LIST 'PROGN - (LIST 'SPADLET ANS - (LIST 'GETREFV - (COND ((NULL CONDS) (fail)) - ((NULL (CDR CONDS)) - (CAR CONDS)) - ((CONS 'MIN CONDS)) ) )) - (CONS 'REPEAT (NCONC (CDR (REVERSE L)) - (LIST (LIST 'SETELT ANS COUNTER BODY)))) - ANS)) )) - (SETQ Y (CAR X)) - (SETQ X (CDR X)) - (COND ((MEMQ (CAR Y) '(SUCHTHAT WHILE UNTIL)) - (RETURN (LIST 'LIST2VEC (CONS 'COLLECT L)) )) - ((member (CAR Y) '(IN ON) :test #'eq) - (SETQ CONDS (CONS (LIST 'SIZE (CADDR Y)) CONDS)) - (GO LP)) - ((member (CAR Y) '(STEP ISTEP) :test #'eq) - (if (AND (EQL (CADDR Y) 0) (EQL (CADDDR Y) 1)) - (SETQ COUNTER (CADR Y)) ) - (COND ((CDDDDR Y) ; there may not be a limit - (SETQ CONDS (CONS - (COND ((EQL 1 (CADDDR Y)) - (COND ((EQL 1 (CADDR Y)) (CAR (CDDDDR Y))) - ((EQL 0 (CADDR Y)) (MKQSADD1 (CAR (CDDDDR Y)))) - ((MKQSADD1 `(- ,(CAR (CDDDDR Y)) ,(CADDR Y)))))) - ((EQL 1 (CADDR Y)) `(/ ,(CAR (CDDDDR Y)) ,(CADDR Y))) - ((EQL 0 (CADDR Y)) - `(/ ,(MKQSADD1 (CAR (CDDDDR Y))) ,(CADDR Y))) - (`(/ (- ,(MKQSADD1 (CAR (CDDDDR Y))) ,(CADDR Y)) - ,(CADDR Y)))) - CONDS)))) - (GO LP))) - (ERROR "Cannot handle macro expansion"))) - -(defun MKQSADD1 (X) - (COND ((ATOM X) `(QSADD1 ,X)) - ((AND (member (CAR X) '(-DIFFERENCE QSDIFFERENCE -) :test #'eq) - (EQL 1 (CADDR X))) - (CADR X)) - (`(QSADD1 ,X)))) - -; 7.10 Dynamic Non-local Exits - -(defmacro yield (L) - (let ((g (gensym))) - `(let ((,g (state))) - (if (statep ,g) (throw 'yield (list 'pair ,L) ,g))))) - -; 10.1 The Property List - -(DEFUN FLAG (L KEY) - "Set the KEY property of every item in list L to T." - (mapc #'(lambda (item) (makeprop item KEY T)) L)) - -(FLAG '(* + AND OR PROGN) 'NARY) ; flag for MKPF - -(DEFUN REMFLAG (L KEY) - "Set the KEY property of every item in list L to NIL." - (OR (ATOM L) (SEQ (REMPROP (CAR L) KEY) (REMFLAG (CDR L) KEY)))) - -(DEFUN FLAGP (X KEY) - "If X has a KEY property, then FLAGP is true." - (GET X KEY)) - -(defun PROPERTY (X IND N) - "Returns the Nth element of X's IND property, if it exists." - (let (Y) (if (AND (INTEGERP N) (SETQ Y (GET X IND)) (>= (LENGTH Y) N)) (ELEM Y N)))) - -; 10.3 Creating Symbols - -(defmacro INTERNL (a &rest b) (if (not b) `(intern ,a) `(intern (strconc ,a . ,b)))) - -(defvar $GENNO 0) - -(DEFUN GENVAR () (INTERNL "$" (STRINGIMAGE (SETQ $GENNO (1+ $GENNO))))) - -(DEFUN IS_GENVAR (X) - (AND (IDENTP X) - (let ((y (symbol-name x))) - (and (char= #\$ (elt y 0)) (> (size y) 1) (digitp (elt y 1)))))) - -(DEFUN IS_\#GENVAR (X) - (AND (IDENTP X) - (let ((y (symbol-name x))) - (and (char= #\# (ELT y 0)) (> (SIZE Y) 1) (DIGITP (ELT Y 1)))))) - -; 10.7 CATCH and THROW - -(defmacro SPADCATCH (&rest form) (CONS 'CATCH form)) - -(defmacro SPADTHROW (&rest form) (CONS 'THROW form)) - -; 12 NUMBERS - -; 12.3 Comparisons on Numbers - -(defmacro IEQUAL (&rest L) `(eql . ,L)) -(defmacro GE (&rest L) `(>= . ,L)) -(defmacro GT (&rest L) `(> . ,L)) -(defmacro LE (&rest L) `(<= . ,L)) -(defmacro LT (&rest L) `(< . ,L)) - -; 12.4 Arithmetic Operations - -(defmacro SPADDIFFERENCE (&rest x) `(- . ,x)) - -; 12.5 Irrational and Transcendental Functions - -; 12.5.1 Exponential and Logarithmic Functions - -(define-function 'QSEXPT #'expt) - -; 12.6 Small Finite Field ops with vector trimming - -;; following macros assume 0 <= x,y < z - -(defmacro qsaddmod (x y z) - `(let* ((sum (qsplus ,x ,y)) - (rsum (qsdifference sum ,z))) - (if (qsminusp rsum) sum rsum))) - -(defmacro qsdifmod (x y z) - `(let ((dif (qsdifference ,x ,y))) - (if (qsminusp dif) (qsplus dif ,z) dif))) - -(defmacro qsmultmod (x y z) - `(rem (* ,x ,y) ,z)) - -(defun TRIMLZ (vec) - (declare (simple-vector vec)) - (let ((n (position 0 vec :from-end t :test-not #'eql))) - (cond ((null n) (vector)) - ((eql n (qvmaxindex vec)) vec) - (t (subseq vec 0 (+ n 1)))))) - -;; In CCL ASH assumes a 2's complement machine. We use ASH in Integer and -;; assume we have a sign and magnitude setup. -#+:CCL (defmacro ash (u v) `(lisp::ash1 ,u ,v)) - -; 14 SEQUENCES - -; 14.1 Simple Sequence Functions - -(DEFUN NLIST (N FN) - "Returns a list of N items, each initialized to the value of an - invocation of FN" - (if (LT N 1) NIL (CONS (EVAL FN) (NLIST (SUB1 N) FN)))) - -(define-function 'getchar #'elt) - -(defun GETCHARN (A M) "Return the code of the Mth character of A" - (let ((a (if (identp a) (symbol-name a) a))) (char-code (elt A M)))) - -; 14.2 Concatenating, Mapping, and Reducing Sequences - -(DEFUN STRINGPAD (STR N) - (let ((M (length STR))) - (if (>= M N) - STR - (concatenate 'string str (make-string (- N M) :initial-element #\Space))))) - -(DEFUN STRINGSUFFIX (TARGET SOURCE) "Suffix source to target if enough room else nil." - (concatenate 'string target source)) - -(defun NSTRCONC (s1 s2) (concatenate 'string (string s1) (string s2))) - -(defmacro spadREDUCE (OP AXIS BOD) (REDUCE-1 OP AXIS BOD)) - -(MAPC #'(LAMBDA (X) (MAKEPROP (CAR X) 'THETA (CDR X))) - '((PLUS 0) (+ (|Zero|)) (|lcm| (|One|)) (STRCONC "") (|strconc| "") - (MAX -999999) (MIN 999999) (TIMES 1) (* (|One|)) (CONS NIL) - (APPEND NIL) (|append| NIL) (UNION NIL) (UNIONQ NIL) (|gcd| (|Zero|)) - (|union| NIL) (NCONC NIL) (|and| |true|) (|or| |false|) (AND 'T) - (OR NIL))) - -(define-function '|append| #'APPEND) - -;;(defun |delete| (item list) ; renaming from DELETE is done in DEF -;; (cond ((atom list) list) -;; ((equalp item (qcar list)) (|delete| item (qcdr list))) -;; ('t (cons (qcar list) (|delete| item (qcdr list)))))) - -(defun |delete| (item sequence) - (cond ((symbolp item) (remove item sequence :test #'eq)) - ((and (atom item) (not (arrayp item))) (remove item sequence)) - (T (remove item sequence :test #'equalp)))) - -(MAPC #'(LAMBDA (J) (MAKEPROP (CAR J) 'UNMACRO (CADR J))) - '( (AND AND2) (OR OR2))) - -(defun and2 (x y) (and x y)) - -(defun or2 (x y) (or x y)) - -(MAKEPROP 'CONS 'RIGHT-ASSOCIATIVE T) - -(defun REDUCE-1 (OP AXIS BOD) - (let (u op1 tran iden) - (SEQ (SETQ OP1 (cond ((EQ OP '\,) 'CONS) - ((EQCAR OP 'QUOTE) (CADR OP)) - (OP))) - (SETQ IDEN (if (SETQ U (GET OP1 'THETA)) (CAR U) 'NO_THETA_PROPERTY)) - (SETQ TRAN (if (EQCAR BOD 'COLLECT) - (PROG (L BOD1 ITL) - (SETQ L (REVERSE (CDR BOD))) - (SETQ BOD1 (CAR L)) - (SETQ ITL (NREVERSE (CDR L))) - (RETURN (-REDUCE OP1 AXIS IDEN BOD1 ITL)) ) - (progn (SETQ U (-REDUCE-OP OP1 AXIS)) - (LIST 'REDUCE-N (MKQ (OR (GET U 'UNMACRO) U)) - (GET OP1 'RIGHT-ASSOCIATIVE) - BOD IDEN)))) - (if (EQ OP '\,) (LIST 'NREVERSE-N TRAN AXIS) TRAN)))) - -(defun -REDUCE (OP AXIS Y BODY SPL) - (PROG (X G AUX EXIT VALUE PRESET CONSCODE RESETCODE) - (SETQ G (GENSYM)) - ; create preset of accumulate - (SETQ PRESET (COND - ((EQ Y 'NO_THETA_PROPERTY) (LIST 'SPADLET G (MKQ G))) - ((LIST 'SPADLET G Y)) )) - (SETQ EXIT (COND - ((SETQ X (ASSOC 'EXIT SPL))(SETQ SPL (DELASC 'EXIT SPL)) (COND - ((MEMBER OP '(AND OR)) (LIST 'AND G (CADR X))) ((CADR X)) )) - ((EQ Y 'NO_THETA_PROPERTY) (LIST 'THETACHECK G (MKQ G)(MKQ OP))) - (G) )) - (COND ((EQ OP 'CONS) (SETQ EXIT (LIST 'NREVERSE0 EXIT)))) - ; CONSCODE= code which conses a member onto the list - (SETQ VALUE (COND ((EQ Y 'NO_THETA_PROPERTY) (GENSYM)) - (BODY))) - (SETQ CONSCODE (CONS (-REDUCE-OP OP AXIS) (COND - ((FLAGP OP 'RIGHT-ASSOCIATIVE) (LIST VALUE G)) - ((LIST G VALUE) ) ) ) ) - ; next reset code which varies if THETA property is|/is not given - (SETQ RESETCODE (LIST 'SETQ G (COND - ((EQ Y 'NO_THETA_PROPERTY) - (LIST 'COND (LIST (LIST 'EQ G (MKQ G)) VALUE) - (LIST ''T CONSCODE)) ) - (CONSCODE) ))) - ; create body - (SETQ BODY (COND ((EQ VALUE BODY) RESETCODE) - ((LIST 'PROGN (LIST 'SPADLET VALUE BODY) RESETCODE)) )) - (SETQ AUX (CONS (LIST 'EXIT EXIT) (COND - ((EQ OP 'AND) (LIST (LIST 'UNTIL (LIST 'NULL G)))) - ((EQ OP 'OR) (LIST (LIST 'UNTIL G))) - (NIL) ))) - (RETURN (COND - ((AND $NEWSPAD (NULL $BOOT)) (LIST 'PROGN PRESET - (CONS 'REPEAT (APPEND AUX (APPEND SPL (LIST BODY))) ))) - ((LIST 'PROG - (COND ((EQ RESETCODE BODY) (LIST G)) ((LIST G VALUE))) - PRESET (LIST 'RETURN - (CONS 'REPEAT (APPEND AUX (APPEND SPL (LIST BODY))))))))))) - -(defun -REDUCE-OP (OP AXIS) - (COND ((EQL AXIS 0) OP) - ((EQL AXIS 1) - (COND ((EQ OP 'CONS) 'CONS-N) - ((EQ OP 'APPEND) 'APPEND-N) - ((FAIL)))) - ((FAIL)))) - -(defun NREVERSE-N (X AXIS) - (COND ((EQL AXIS 0) (NREVERSE X)) - ((MAPCAR #'(LAMBDA (Y) (NREVERSE-N Y (SUB1 AXIS))) X)))) - -(defun CONS-N (X Y) - (COND ((NULL Y) (CONS-N X (NLIST (LENGTH X) NIL))) - ((MAPCAR #'CONS X Y)))) - -(defun APPEND-N (X Y) - (COND ((NULL X) (APPEND-N (NLIST (LENGTH Y) NIL) Y)) - ((MAPCAR #'APPEND X Y)))) - -(defun REDUCE-N (OP RIGHT L ACC) - (COND (RIGHT (PROG (U L1) - (SETQ L1 (NREVERSE L)) - (SETQ U (REDUCE-N-1 OP 'T L1 ACC)) - (NREVERSE L1) - (RETURN U) )) - ((REDUCE-N-1 OP NIL L ACC)))) - -(defun REDUCE-N-1 (OP RIGHT L ACC) - (COND ((EQ ACC 'NO_THETA_PROPERTY) - (COND ((NULL L) (THETA_ERROR OP)) - ((REDUCE-N-2 OP RIGHT (CDR L) (CAR L))) )) - ((REDUCE-N-2 OP RIGHT L ACC)))) - -(defun REDUCE-N-2 (OP RIGHT L ACC) - (COND ((NULL L) ACC) - (RIGHT (REDUCE-N-2 OP RIGHT (CDR L) (funcall (symbol-function OP) (CAR L) ACC))) - ((REDUCE-N-2 OP RIGHT (CDR L) (funcall (symbol-function OP) ACC (CAR L)))))) - -(defmacro THETA (&rest LL) - (let (U (L (copy-list LL))) - (if (EQ (KAR L) '\,) `(theta CONS . ,(CDR L)) - (progn - (if (EQCAR (CAR L) 'QUOTE) (RPLAC (CAR L) (CADAR L))) - (-REDUCE (CAR L) 0 - (if (SETQ U (GET (CAR L) 'THETA)) (CAR U) - (MOAN "NO THETA PROPERTY")) - (CAR (SETQ L (NREVERSE (CDR L)))) - (NREVERSE (CDR L))))))) - -(defmacro THETA1 (&rest LL) - (let (U (L (copy-list LL))) - (if (EQ (KAR L) '\,) - (LIST 'NREVERSE-N (CONS 'THETA1 (CONS 'CONS (CDR L))) 1) - (-REDUCE (CAR L) 1 - (if (SETQ U (GET (CAR L) 'THETA)) (CAR U) - (MOAN "NO THETA PROPERTY")) - (CAR (SETQ L (NREVERSE (CDR L)))) - (NREVERSE (CDR L)))))) - - -(defun THETACHECK (VAL VAR OP) (if (EQL VAL VAR) (THETA_ERROR OP) val)) - -(defun THETA_ERROR (OP) - (Boot::|userError| - (LIST "Sorry, do not know the identity element for " OP))) - -; 15 LISTS - -; 15.1 Conses - - -(defmacro |SPADfirst| (l) - (let ((tem (gensym))) - `(let ((,tem ,l)) (if ,tem (car ,tem) (first-error))))) - -(defun first-error () (error "Cannot take first of an empty list")) - -; 15.2 Lists - - -(defmacro ELEM (val &rest indices) - (if (null indices) val `(ELEM (nth (1- ,(car indices)) ,val) ,@(cdr indices)))) - -(defun ELEMN (X N DEFAULT) - (COND ((NULL X) DEFAULT) - ((EQL N 1) (CAR X)) - ((ELEMN (CDR X) (SUB1 N) DEFAULT)))) - -(defmacro TAIL (&rest L) - (let ((x (car L)) (n (if (cdr L) (cadr L) 1))) - (COND ((EQL N 0) X) - ((EQL N 1) (LIST 'CDR X)) - ((GT N 1) (APPLYR (PARTCODET N) X)) - ((LIST 'TAILFN X N))))) - -(defun PARTCODET (N) - (COND ((OR (NULL (INTEGERP N)) (LT N 1)) (ERROR 'PARTCODET)) - ((EQL N 1) '(CDR)) - ((EQL N 2) '(CDDR)) - ((EQL N 3) '(CDDDR)) - ((EQL N 4) '(CDDDDR)) - ((APPEND (PARTCODET (PLUS N -4)) '(CDDDDR))))) - -(defmacro TL (&rest L) `(tail . ,L)) - -(defun TAILFN (X N) (if (LT N 1) X (TAILFN (CDR X) (SUB1 N)))) - -(defmacro SPADCONST (&rest L) (cons 'qrefelt L)) - -(defmacro SPADCALL (&rest L) - (let ((args (butlast l)) (fn (car (last l))) (gi (gensym))) - ;; (values t) indicates a single return value - `(let ((,gi ,fn)) (the (values t) (funcall (car ,gi) ,@args (cdr ,gi)))) - )) - -(DEFUN LASTELEM (X) (car (last X))) - -(defun LISTOFATOMS (X) - (COND ((NULL X) NIL) - ((ATOM X) (LIST X)) - ((NCONC (LISTOFATOMS (CAR X)) (LISTOFATOMS (CDR X)))))) - -(DEFUN LASTATOM (L) (if (ATOM L) L (LASTATOM (CDR L)))) - -(define-function 'LASTTAIL #'last) - -(define-function 'LISPELT #'ELT) - -(defun DROP (N X &aux m) - "Return a pointer to the Nth cons of X, counting 0 as the first cons." - (COND ((EQL N 0) X) - ((> N 0) (DROP (1- N) (CDR X))) - ((>= (setq m (+ (length x) N)) 0) (take m x)) - ((CROAK (list "Bad args to DROP" N X))))) - -(DEFUN TAKE (N X &aux m) - "Returns a list of the first N elements of list X." - (COND ((EQL N 0) NIL) - ((> N 0) (CONS (CAR X) (TAKE (1- N) (CDR X)))) - ((>= (setq m (+ (length x) N)) 0) (drop m x)) - ((CROAK (list "Bad args to DROP" N X))))) - -(DEFUN NUMOFNODES (X) (if (ATOM X) 0 (+ 1 (NUMOFNODES (CAR X)) (NUMOFNODES (CDR X))))) - -(DEFUN TRUNCLIST (L TL) "Truncate list L at the point marked by TL." - (let ((U L)) (TRUNCLIST-1 L TL) U)) - -(DEFUN TRUNCLIST-1 (L TL) - (COND ((ATOM L) L) - ((EQL (CDR L) TL) (RPLACD L NIL)) - ((TRUNCLIST-1 (CDR L) TL)))) - -; 15.3 Alteration of List Structure - -(defun RPLACW (x w) (let (y z) (dsetq (Y . Z) w) (RPLACA X Y) (RPLACD X Z) X)) - -; 15.4 Substitution of Expressions - -(DEFUN SUBSTEQ (NEW OLD FORM) - "Version of SUBST that uses EQ rather than EQUAL on the world." - (PROG (NFORM HNFORM ITEM) - (SETQ HNFORM (SETQ NFORM (CONS () ()))) - LP (RPLACD NFORM - (COND ((EQ FORM OLD) (SETQ FORM ()) NEW ) - ((NOT (PAIRP FORM)) FORM ) - ((EQ (SETQ ITEM (CAR FORM)) OLD) (CONS NEW ()) ) - ((PAIRP ITEM) (CONS (SUBSTEQ NEW OLD ITEM) ()) ) - ((CONS ITEM ())))) - (if (NOT (PAIRP FORM)) (RETURN (CDR HNFORM))) - (SETQ NFORM (CDR NFORM)) - (SETQ FORM (CDR FORM)) - (GO LP))) - -(DEFUN SUBLISNQ (KEY E) (declare (special KEY)) (if (NULL KEY) E (SUBANQ E))) - -(DEFUN SUBANQ (E) - (declare (special key)) - (COND ((ATOM E) (SUBB KEY E)) - ((EQCAR E (QUOTE QUOTE)) E) - ((MAPCAR #'(LAMBDA (J) (SUBANQ J)) E)))) - -(DEFUN SUBB (X E) - (COND ((ATOM X) E) - ((EQ (CAAR X) E) (CDAR X)) - ((SUBB (CDR X) E)))) - -(defun SUBLISLIS (newl oldl form) - (sublis (mapcar #'cons oldl newl) form)) - -; 15.5 Using Lists as Sets - -<> -(DEFUN S+ (X Y) - (COND ((ATOM Y) X) - ((ATOM X) Y) - ((MEMBER (CAR X) Y :test #'equal) (S+ (CDR X) Y)) - ((S+ (CDR X) (CONS (CAR X) Y))))) - -(defun S* (l1 l2) (INTERSECTION l1 l2 :test #'equal)) -(defun S- (l1 l2) (set-difference l1 l2 :test #'equal)) - -(DEFUN PREDECESSOR (TL L) - "Returns the sublist of L whose CDR is EQ to TL." - (COND ((ATOM L) NIL) - ((EQ TL (CDR L)) L) - ((PREDECESSOR TL (CDR L))))) - -(defun remdup (l) (remove-duplicates l :test #'equalp)) - -(DEFUN GETTAIL (X L) (member X L :test #'equal)) - -; 15.6 Association Lists - -(defun DelAsc (u v) "Returns a copy of a-list V in which any pair with key U is deleted." - (cond ((atom v) nil) - ((or (atom (car v))(not (equal u (caar v)))) - (cons (car v) (DelAsc u (cdr v)))) - ((cdr v)))) - -(DEFUN ADDASSOC (X Y L) - "Put the association list pair (X . Y) into L, erasing any previous association for X" - (COND ((ATOM L) (CONS (CONS X Y) L)) - ((EQUAL X (CAAR L)) (CONS (CONS X Y) (CDR L))) - ((CONS (CAR L) (ADDASSOC X Y (CDR L)))))) - -(DEFUN DELLASOS (U V) - "Remove any assocation pair (U . X) from list V." - (COND ((ATOM V) NIL) - ((EQUAL U (CAAR V)) (CDR V)) - ((CONS (CAR V) (DELLASOS U (CDR V)))))) - -(DEFUN ASSOCLEFT (X) - "Returns all the keys of association list X." - (if (ATOM X) X (mapcar #'car x))) - -(DEFUN ASSOCRIGHT (X) - "Returns all the datums of association list X." - (if (ATOM X) X (mapcar #'cdr x))) - -(DEFUN LASSOC (X Y) - "Return the datum associated with key X in association list Y." - (PROG NIL - A (COND ((ATOM Y) (RETURN NIL)) - ((EQUAL (CAAR Y) X) (RETURN (CDAR Y))) ) - (SETQ Y (CDR Y)) - (GO A))) - -(DEFUN |rassoc| (X Y) - "Return the datum associated with key X in association list Y." - (PROG NIL - A (COND ((ATOM Y) (RETURN NIL)) - ((EQUAL (CDAR Y) X) (RETURN (CAAR Y))) ) - (SETQ Y (CDR Y)) - (GO A))) - -; (defun QLASSQ (p a-list) (let ((y (assoc p a-list :test #'eq))) (if y (cdr y)))) -(defun QLASSQ (p a-list) (cdr (assq p a-list))) - -(define-function 'LASSQ #'QLASSQ) - -(defun pair (x y) (mapcar #'cons x y)) - -;;; Operations on Association Sets (AS) - -(defun AS-INSERT (A B L) - ;; PF(item) x PF(item) x LIST(of pairs) -> LIST(of pairs with (A . B) added) - ;; destructive on L; if (A . C) appears already, C is replaced by B - (cond ((null l) (list (cons a b))) - ((equal a (caar l)) (rplac (cdar l) b) l) - ((?order a (caar l)) (cons (cons a b) l)) - (t (as-insert1 a b l) l))) - -(defun as-insert1 (a b l) - (cond ((null (cdr l)) (rplac (cdr l) (list (cons a b)))) - ((equal a (caadr l)) (rplac (cdadr l) b)) - ((?order a (caadr l)) (rplac (cdr l) (cons (cons a b) (cdr l)))) - (t (as-insert1 a b (cdr l))))) - - -; 17 ARRAYS - -; 17.6 Changing the Dimensions of an Array - - -<> -<> - -; 22 INPUT/OUTPUT - -; 22.2 Input Functions - -; 22.2.1 Input from Character Streams - -(DEFUN STREAM-EOF (&optional (STRM *terminal-io*)) - "T if input stream STRM is at the end or saw a ~." - (not (peek-char nil STRM nil nil nil)) ) - -(DEFUN CONSOLEINPUTP (STRM) (IS-CONSOLE STRM)) - -(defvar $filelinenumber 0) -(defvar $prompt "--->") -(defvar stream-buffer nil) - -(DEFUN NEXTSTRMLINE (STRM) "Returns the next input line from stream STRM." - (let ((v (read-line strm nil -1 nil))) - (if (equal v -1) (throw 'spad_reader nil) - (progn (setq stream-buffer v) v)))) - -(DEFUN CURSTRMLINE (STRM) - "Returns the current input line from the stream buffer of STRM (VM-specific!)." - (cond (stream-buffer) - ((stream-eof strm) (fail)) - ((nextstrmline strm)))) - -(defvar *EOF* NIL) - -(DEFUN CURMAXINDEX (STRM) -"Something bizarre and VM-specific with respect to streams." - (if *EOF* (FAIL) (ELT (ELT (LASTATOM STRM) 1) 3))) - -(DEFUN ADJCURMAXINDEX (STRM) -"Something unearthly and VM-specific with respect to streams." - (let (v) (if *eof* (fail) - (progn (SETQ V (ELT (LASTATOM STRM) 1)) - (SETELT V 3 (SIZE (ELT V 0))))))) - -(DEFUN STRMBLANKLINE (STRM) -"Something diabolical and VM-specific with respect to streams." - (if *EOF* (FAIL) (AND (EQ '\ (CAR STRM)) (EQL 1 (CURMAXINDEX STRM))))) - -(DEFUN STRMSKIPTOBLANK (STRM) -"Munch away on the stream until you get to a blank line." - (COND (*EOF* (FAIL)) - ((PROGN (NEXTSTRMLINE STRM) (STRMBLANKLINE STRM)) STRM) - ((STRMSKIPTOBLANK STRM)))) - -(DEFUN CURINPUTLINE () (CURSTRMLINE *standard-input*)) - -(DEFUN NEXTINPUTLINE () (NEXTSTRMLINE *standard-input*)) - -; 22.3 Output Functions - -; 22.3.1 Output to Character Streams - -(DEFUN ATOM2STRING (X) - "Give me the string which would be printed out to denote an atom." - (cond ((atom x) (symbol-name x)) - ((stringp x) x) - ((write-to-string x)))) - -(defvar |conOutStream| *terminal-io* "console output stream") - -(defun |sayTeX| (x) (if (null x) nil (sayBrightly1 x |$texOutputStream|))) - -(defun |sayNewLine| () (TERPRI)) - -(defvar |$sayBrightlyStream| nil "if not nil, gives stream for sayBrightly output") - -(defun |sayBrightly| (x &optional (out-stream *standard-output*)) - (COND ((NULL X) NIL) - (|$sayBrightlyStream| (sayBrightly1 X |$sayBrightlyStream|)) - ((IS-CONSOLE out-stream) (sayBrightly1 X out-stream)) - ((sayBrightly1 X out-stream) (sayBrightly1 X *terminal-io*)))) - -(defun |sayBrightlyI| (x &optional (s *terminal-io*)) - "Prints at console or output stream." - (if (NULL X) NIL (sayBrightly1 X S))) - -(defun |sayBrightlyNT| (x &optional (S *standard-output*)) - (COND ((NULL X) NIL) - (|$sayBrightlyStream| (sayBrightlyNT1 X |$sayBrightlyStream|)) - ((IS-CONSOLE S) (sayBrightlyNT1 X S)) - ((sayBrightly1 X S) (sayBrightlyNT1 X *terminal-io*)))) - -(defun sayBrightlyNT1 (X *standard-output*) - (if (ATOM X) (BRIGHTPRINT-0 X) (BRIGHTPRINT X))) - -(defun |saySpadMsg| (X) - (if (NULL X) NIL (sayBrightly1 X |$algebraOutputStream|))) - -(defun |sayALGEBRA| (X) "Prints on Algebra output stream." - (if (NULL X) NIL (sayBrightly1 X |$algebraOutputStream|))) - -(defun |sayMSGNT| (X) - (if (NULL X) NIL (sayBrightlyNT1 X |$algebraOutputStream|))) - -(defun |sayMSG2File| (msg) - (PROG (file str) - (SETQ file (|makePathname| '|spadmsg| '|listing| |$listingDirectory|)) - (SETQ str - (DEFIOSTREAM - (CONS '(MODE . OUTPUT) (CONS (CONS 'FILE file) NIL)) - 255 0)) - (sayBrightly1 msg str) - (SHUT str) ) ) - -(defvar |$fortranOutputStream|) - -(defun |sayFORTRAN| (x) "Prints on Fortran output stream." - (if (NULL X) NIL (sayBrightly1 X |$fortranOutputStream|))) - -(defvar |$formulaOutputStream|) - -(defun |sayFORMULA| (X) "Prints on formula output stream." - (if (NULL X) NIL (sayBrightly1 X |$formulaOutputStream|))) - -(defvar |$highlightAllowed| nil "Used in BRIGHTPRINT and is a )set variable.") - -(defvar |$highlightFontOn| $boldstring "switch to highlight font") -(defvar |$highlightFontOff| $normalstring "return to normal font") - -;; the following are redefined in MSGDB BOOT - -(defun SAY (&rest x) (progn (MESSAGEPRINT X) (TERPRI))) - -(DEFUN BLANKS (N &optional (stream *standard-output*)) "Print N blanks." - (do ((i 1 (the fixnum(1+ i)))) - ((> i N))(declare (fixnum i n)) (princ " " stream))) - -; 23 FILE SYSTEM INTERFACE - -; 23.2 Opening and Closing Files - -(DEFUN DEFSTREAM (file MODE) - (if (member mode '(i input)) - (MAKE-INSTREAM file) - (MAKE-OUTSTREAM file))) - -; 23.3 Renaming, Deleting and Other File Operations - -(DEFUN NOTE (STRM) -"Attempts to return the current record number of a file stream. This is 0 for -terminals and empty or at-end files. In Common Lisp, we must assume record sizes of 1!" - (COND ((STREAM-EOF STRM) 0) - ((IS-CONSOLE STRM) 0) - ((file-position STRM)))) - -(DEFUN IS-CONSOLE-NOT-XEDIT (S) (not (OR (NULL (IS-CONSOLE S))))) - -(DEFUN POINTW (RECNO STRM) -"Does something obscure and VM-specific with respect to streams." - (let (V) - (if (STREAM-EOF STRM) (FAIL)) - (SETQ V (LASTATOM STRM)) - (SETELT V 4 RECNO) - (SETQ *EOF* (STREAM-EOF STRM)) - strm)) - -(DEFUN POINT (RECNO STRM) (file-position strm recno)) - -(DEFUN STRM (RECNO STRM) -"Does something obscure and VM-specific with respect to streams." - (let (V) - (if (STREAM-EOF STRM) (FAIL)) - (SETQ V (LASTATOM STRM)) - (SETELT V 4 RECNO) - (read-char STRM) - (SETQ *EOF* (STREAM-EOF STRM)) - strm)) - -; 24 ERRORS - -; 24.2 Specialized Error-Signalling Forms and Macros - -(defun MOAN (&rest x) (|sayBrightly| `(|%l| "===> " ,@X |%l|))) - -(DEFUN FAIL () (|systemError| '"Antique error (FAIL ENTERED)")) - -(defun CROAK (&rest x) (|systemError| x)) - -; 25 MISCELLANEOUS FEATURES - -;; range tests and assertions - -(defmacro |assert| (x y) `(IF (NULL ,x) (|error| ,y))) - -(defun coerce-failure-msg (val mode) - (STRCONC (MAKE-REASONABLE (STRINGIMAGE val)) - " cannot be coerced to mode " - (STRINGIMAGE (|devaluate| mode)))) - -(defmacro |check-subtype| (pred submode val) - `(|assert| ,pred (coerce-failure-msg ,val ,submode))) - -(defmacro |check-union| (pred branch val) - `(|assert| ,pred (coerce-failure-msg ,val ,branch ))) - -(defun MAKE-REASONABLE (Z) - (if (> (length Z) 30) (CONCAT "expression beginning " (subseq Z 0 20)) Z)) - - -(defmacro |elapsedUserTime| () '(get-internal-run-time)) - -#+IBCL -(defmacro |elapsedGcTime| () '(system:gbc-time-report)) -#+AKCL -(defmacro |elapsedGcTime| () '(system:gbc-time)) -#+:CCL -(defmacro |elapsedGcTime| () '(lisp:gctime)) -#-(OR :CCL IBCL AKCL) -(defmacro |elapsedGcTime| () '0) - -(defmacro |do| (&rest args) (CONS 'PROGN args)) - -(defmacro |char| (arg) - (cond ((stringp arg) (character arg)) - ((integerp arg) (code-char arg)) - ((and (consp arg) (eq (car arg) 'quote)) (character (cadr arg))) - (t `(character ,arg)))) - -(defun DROPTRAILINGBLANKS (LINE) (string-right-trim " " LINE)) - -; # Gives the number of elements of a list, 0 for atoms. -; If we quote it, then an interpreter trip is necessary every time -; we call #, and this costs us - 4% in the RATINT DEMO." - -(define-function '\# #'SIZE) - -(defun print-and-eval-defun (name body) - (eval body) - (print-defun name body) - ;; (set name (symbol-function name)) ;; this should go away - ) - -(defun eval-defun (name body) (eval (macroexpandall body))) - -; This function was modified by Greg Vanuxem on March 31, 2005 -; to handle the special case of #'(lambda ..... which expands -; into (function (lambda ..... -; -; The extra if clause fixes bugs #196 and #114 -; -; an example that used to cause the failure was: -; )set func comp off -; f(xl:LIST FRAC INT): LIST FRAC INT == map(x +-> x, xl) -; f [1,2,3] -; -; which expanded into -; -; (defun |xl;f;1;initial| (|#1| |envArg|) -; (prog (#:G1420) -; (return -; (progn -; (lett #:G1420 'uninitialized_variable |f| |#1;f;1:initial|) -; (spadcall -; (cons (|function| (lambda (#:G1420 |envArg|) #:G1420)) (vector)) -; |#1| -; (qrefelt |*1;f;1;initial;MV| 0)))))) -; -; the (|function| (lambda form used to cause an infinite expansion loop -; -(defun macroexpandall (sexpr) - (cond - ((atom sexpr) sexpr) - ((eq (car sexpr) 'quote) sexpr) - ((eq (car sexpr) 'defun) - (cons (car sexpr) (cons (cadr sexpr) - (mapcar #'macroexpandall (cddr sexpr))))) - ((and (symbolp (car sexpr)) (macro-function (car sexpr))) - (do () - ((not (and (consp sexpr) (symbolp (car sexpr)) - (macro-function (car sexpr))))) - (setq sexpr (macroexpand sexpr))) - (if (consp sexpr) - (let ((a (car sexpr)) (b (caadr sexpr))) - (if (and (eq a 'function) (eq b 'lambda)) - (cons a (list (cons b (mapcar #'macroexpandall (cdadr sexpr))))) - (mapcar #'macroexpandall sexpr))) - sexpr)) - ('else - (mapcar #'macroexpandall sexpr)))) - - -(defun compile-defun (name body) (eval body) (compile name)) - -(defmacro |Record| (&rest x) - `(|Record0| (LIST ,@(COLLECT (IN Y X) - (list 'CONS (MKQ (CADR Y)) (CADDR Y)))))) - -(defmacro |:| (tag expr) `(LIST '|:| ,(MKQ tag) ,expr)) - -(defun |deleteWOC| (item list) (lisp::delete item list :test #'equal)) - -(DEFUN |leftBindingPowerOf| (X IND &AUX (Y (GETL X IND))) - (IF Y (ELEMN Y 3 0) 0)) - -(DEFUN |rightBindingPowerOf| (X IND &AUX (Y (GETL X IND))) - (IF Y (ELEMN Y 4 105) 105)) - -(defmacro make-bf (MT EP) `(CONS |$BFtag| (CONS ,MT ,EP))) - -(defun MAKE-FLOAT (int frac fraclen exp) - (if (AND $SPAD |$useBFasDefault|) - (if (= frac 0) - (MAKE-BF int exp) - (MAKE-BF (+ (* int (expt 10 fraclen)) frac) (- exp fraclen)) ) - (read-from-string - (format nil "~D.~v,'0De~D" int fraclen frac exp))) ) - -;;---- Added by WFS. - -(proclaim '(ftype (function (t t) t) |subWord|)) ;hack for bug in akcl-478 - -(DEFUN |subWord| (|str| N ) - (declare (fixnum n ) (string |str|)) - (PROG (|word| (|n| 0) |inWord|(|l| 0) ) - (declare (fixnum |n| |l|)) - (RETURN - (SEQ (COND - ((> 1 N) NIL) - ('T (SPADLET |l| (SPADDIFFERENCE (|#| |str|) 1)) - (COND - ((EQL |l| 0) NIL) - ('T (SPADLET |n| 0) (SPADLET |word| '||) - (SPADLET |inWord| NIL) - (DO ((|i| 0 (QSADD1 |i|))) ((QSGREATERP |i| |l|) NIL) - (declare (fixnum |i|)) - (SEQ (EXIT (COND - ((eql (aref |str| |i|) #\space) - (COND - ((NULL |inWord|) NIL) - ((eql |n| N) (RETURN |word|)) - ('T (SPADLET |inWord| NIL)))) - ('T - (COND - ((NULL |inWord|) - (SPADLET |inWord| 'T) - (SPADLET |n| (PLUS |n| 1)))) - (COND - ((eql |n| N) - (cond ((eq |word| '||) - (setq |word| - (make-array 10 :adjustable t - :element-type 'standard-char - :fill-pointer 0)))) - (or |word| (error "bad")) - (vector-push-extend (aref |str| |i|) - (the string |word|) - ) - ) - ('T NIL))))))) - (COND ((> N |n|) NIL) ('T |word|)))))))))) - -(defun print-full (expr &optional (stream *standard-output*)) - (let ((*print-circle* t) (*print-array* t) *print-level* *print-length*) - (print expr stream) - (terpri stream) - (finish-output stream))) - -;; moved here from preparse.lisp - -(defun NEXT-TAB-LOC (i) (* (1+ (truncate i 8)) 8)) - -(defun INDENT-POS (STR) - (do ((i 0 (1+ i)) - (pos 0)) - ((>= i (length str)) nil) - (case (char str i) - (#\space (incf pos)) - (#\tab (setq pos (next-tab-loc pos))) - (otherwise (return pos))))) - -;;(defun expand-tabs (str) -;; (let ((bpos (nonblankloc str)) -;; (tpos (indent-pos str))) -;; (if (eql bpos tpos) str -;; (concatenate 'string (make-string tpos :initial-element #\space) -;; (subseq str bpos))))) -(defun expand-tabs (str) - (if (and (stringp str) (> (length str) 0)) - (let ((bpos (nonblankloc str)) - (tpos (indent-pos str))) - (setq str - (if (eql bpos tpos) - str - (concatenate 'string - (make-string tpos :initial-element #\space) - (subseq str bpos)))) - ;; remove dos CR - (let ((lpos (maxindex str))) - (if (eq (char str lpos) #\Return) (subseq str 0 lpos) str))) - str)) - -(defun blankp (char) (or (eq char #\Space) (eq char #\tab))) - -(defun nonblankloc (str) (position-if-not #'blankp str)) - -;; stream handling for paste-in generation - -(defun |applyWithOutputToString| (func args) - ;; returns the cons of applying func to args and a string produced - ;; from standard-output while executing. - (let* ((*standard-output* (make-string-output-stream)) - (curoutstream *standard-output*) - (*terminal-io* *standard-output*) - (|$algebraOutputStream| *standard-output*) - (erroroutstream *standard-output*) - val) - (declare (special *standard-output* curoutstream - *terminal-io* |$algebraOutputStream|)) - (setq val (catch 'spad_reader - (catch 'TOP_LEVEL - (apply (symbol-function func) args)))) - (cons val (get-output-stream-string *standard-output*)))) - -(defun |breakIntoLines| (str) - (let ((bol 0) (eol) (line-list nil)) - (loop - (setq eol (position #\Newline str :start bol)) - (if (null eol) (return)) - (if (> eol bol) - (setq line-list (cons (subseq str bol eol) line-list))) - (setq bol (+ eol 1))) - (nreverse line-list))) - -; part of the old spad to new spad translator -; these are here because they need to be in depsys -; they were in nspadaux.lisp - -(defmacro wi (a b) b) - -(defmacro |try| (X) - `(LET ((|$autoLine|)) - (declare (special |$autoLine|)) - (|tryToFit| (|saveState|) ,X))) - -(defmacro |embrace| (X) `(|wrapBraces| (|saveC|) ,X (|restoreC|))) -(defmacro |indentNB| (X) `(|wrapBraces| (|saveD|) ,X (|restoreD|))) - -(defmacro |tryBreak| (a b c d) -; Try to format by: -; (1) with no line breaking ($autoLine = nil) -; (2) with possible line breaks within a; -; (3) otherwise use a brace - `(LET - ((state)) - (setq state (|saveState| 't)) - (or - (LET ((|$autoLine|)) - (declare (special |$autoLine|)) - (and ,a (|formatRight| '|formatPreferPile| ,b ,c ,d))) - (|restoreState| state) - (and (eqcar ,b (quote seq)) - (|embrace| (and - ,a - (|formatLB|) - (|formatRight| '|formatPreferPile| ,b ,c ,d)))) - (|restoreState| state) - (|embrace| (and ,a - (|formatLB|) - (|formatRight| '|formatPreferPile| ,b ,c ,d)))))) - -(defmacro |tryBreakNB| (a b c d) -; Try to format by: -; (1) with no line breaking ($autoLine = nil) -; (2) with possible line breaks within a; -; (3) otherwise display without a brace - `(LET - ((state)) - (setq state (|saveState| 't)) - (or - (markhash ,b 0) - (LET ((|$autoLine|)) - (declare (special |$autoLine|)) - (and ,a (|formatRight| '|formatPreferPile| ,b ,c ,d))) - (|restoreState| state) - (markhash ,b 1) - (and (eqcar ,b (quote seq)) - (|embrace| (and - ,a - (|formatLB|) - (|formatRight| '|formatPreferPile| ,b ,c ,d)))) - (markhash ,b 2) - (|restoreState| state) - (|indentNB| (and ,a - (|formatRight| '|formatPreferPile| ,b ,c ,d))) - (markhash ,b 3) - -))) - -(defun markhash (key n) (progn (cond - ((equal n 3) (remhash key ht)) - ('t (hput ht key n)) ) nil)) - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/vmlisp.lisp.pamphlet b/src/interp/vmlisp.lisp.pamphlet index 295e2dd..4324b22 100644 --- a/src/interp/vmlisp.lisp.pamphlet +++ b/src/interp/vmlisp.lisp.pamphlet @@ -3222,6 +3222,1601 @@ for primitive domains. Also used by putInLocalDomainReferences and optCal.") (def-boot-val |$inputPromptType| '|step| "checked in MKPROMPT") (def-boot-val |$IOindex| 0 "step counter") +(defvar |$compilingMap| ()) +(defvar |$definingMap| nil) + +(defmacro KAR (ARG) `(ifcar ,arg)) +(defmacro KDR (ARG) `(ifcdr ,arg)) +(defmacro KADR (ARG) `(ifcar (ifcdr ,arg))) +(defmacro KADDR (ARG) `(ifcar (ifcdr (ifcdr ,arg)))) + +; 5 PROGRAM STRUCTURE + +; 5.3 Top-Level Forms + +(defun SETANDFILE (x y) (LAM\,EVALANDFILEACTQ `(setq ,x ',y))) + +; 5.3.2 Declaring Global Variables and Named Constants + +(defmacro |function| (name) `(FUNCTION ,name)) +(defmacro |dispatchFunction| (name) `(FUNCTION ,name)) + +(defun |macrop| (fn) (and (identp fn) (macro-function fn))) + +; 6 PREDICATES + +; 6.2 Data Type Predicates + +; 6.3 Equality Predicates + +;; qeqcar should be used when you know the first arg is a pair +;; the second arg should either be a literal fixnum or a symbol +;; the car of the first arg is always of the same type as the second +;; use eql unless we are sure fixnums are represented canonically + +#-lucid +(defmacro qeqcar (x y) + (if (integerp y) `(eql (the fixnum (qcar ,x)) (the fixnum ,y)) + `(eq (qcar ,x) ,y))) + +#+lucid +(defmacro qeqcar (x y) `(eq (qcar ,x) ,y)) + + +(defun COMPARE (X Y) + "True if X is an atom or X and Y are lists and X and Y are equal up to X." + (COND ((ATOM X) T) + ((ATOM Y) NIL) + ((EQUAL (CAR X) (CAR Y)) (COMPARE (CDR X) (CDR Y))))) + + +(DEFUN ?ORDER (U V) "Multiple-type ordering relation." + (COND ((NULL U)) + ((NULL V) NIL) + ((ATOM U) + (if (ATOM V) + (COND ((NUMBERP U) (if (NUMBERP V) (> V U) T)) + ((NUMBERP V) NIL) + ((IDENTP U) (AND (IDENTP V) (string> (SYMBOL-NAME V) (SYMBOL-NAME U)))) + ((IDENTP V) NIL) + ((STRINGP U) (AND (STRINGP V) (string> V U))) + ((STRINGP V) NIL) + ((AND (VECP U) (VECP V)) + (AND (> (SIZE V) (SIZE U)) + (DO ((I 0 (1+ I))) + ((GT I (MAXINDEX U)) 'T) + (COND ((NOT (EQUAL (ELT U I) (ELT V I))) + (RETURN (?ORDER (ELT U I) (ELT V I)))))))) + ((croak "Do not understand"))) + T)) + ((ATOM V) NIL) + ((EQUAL U V)) + ((NOT (string> (write-to-string U) (write-to-string V)))))) + +(defmacro boot-equal (a b) + (cond ((ident-char-lit a) + `(or (eql ,a ,b) (eql (character ,a) ,b))) + ((ident-char-lit b) + `(or (eql ,a ,b) (eql ,a (character ,b)))) + (t `(eqqual ,a ,b)))) + +(defun ident-char-lit (x) + (and (eqcar x 'quote) (identp (cadr x)) (= (length (pname (cadr x))) 1))) + +(defmacro EQQUAL (a b) + (cond ((OR (EQUABLE a) (EQUABLE b)) `(eq ,a ,b)) + ((OR (numberp a) (numberp b)) `(eql ,a ,b)) + (t `(equal ,a ,b)))) + +(defmacro NEQUAL (a b) `(not (BOOT-EQUAL ,a ,b))) + +(defun EQUABLE (X) + (OR (NULL X) (AND (EQCAR X 'QUOTE) (symbolp (CADR X))))) + +; 7 CONTROL STRUCTURE + +; 7.1 Constants and Variables + +; 7.1.1 Reference + +(DEFUN MKQ (X) + "Evaluates an object and returns it with QUOTE wrapped around it." + (if (NUMBERP X) X (LIST 'QUOTE X))) + +; 7.2 Generalized Variables + +(defmacro IS (x y) `(dcq ,y ,x)) + +(defmacro LETT (var val &rest L) + (COND + (|$QuickLet| `(SETQ ,var ,val)) + (|$compilingMap| + ;; map tracing + `(PROGN + (SETQ ,var ,val) + (COND (|$letAssoc| + (|mapLetPrint| ,(MKQ var) + ,var + (QUOTE ,(KAR L)))) + ('T ,var)))) + ;; used for LETs in SPAD code --- see devious trick in COMP,TRAN,1 + ((ATOM var) + `(PROGN + (SETQ ,var ,val) + (IF |$letAssoc| + ,(cond ((null (cdr l)) + `(|letPrint| ,(MKQ var) ,var (QUOTE ,(KAR L)))) + ((and (eqcar (car l) 'SPADCALL) (= (length (car l)) 3)) + `(|letPrint3| ,(MKQ var) ,var ,(third (car l)) (QUOTE ,(KADR L)))) + (t `(|letPrint2| ,(MKQ var) ,(car l) (QUOTE ,(KADR L)))))) + ,var)) + ('T (ERROR "Cannot compileLET construct")))) + +(defmacro SPADLET (A B) + (if (ATOM A) `(SETQ ,A ,B) + `(OR (IS ,B ,A) (LET_ERROR ,(MK_LEFORM A) ,(MKQ B) )))) + +(defmacro RPLAC (&rest L) + (if (EQCAR (CAR L) 'ELT) + (LIST 'SETELT (CADAR L) (CADDR (CAR L)) (CADR L)) + (let ((A (CARCDREXPAND (CAR L) NIL)) (B (CADR L))) + (COND ((CDDR L) (ERROR 'RPLAC)) + ((EQCAR A 'CAR) (LIST 'RPLACA (CADR A) B)) + ((EQCAR A 'CDR) (LIST 'RPLACD (CADR A) B)) + ((ERROR 'RPLAC)))))) + +(MAPC #'(LAMBDA (J) (MAKEPROP (CAR J) 'SELCODE (CADR J))) + '((CAR 2) (CDR 3) (CAAR 4) (CADR 5) (CDAR 6) (CDDR 7) + (CAAAR 8) (CAADR 9) (CADAR 10) (CADDR 11) (CDAAR 12) + (CDADR 13) (CDDAR 14) (CDDDR 15) (CAAAAR 16) (CAAADR 17) + (CAADAR 18) (CAADDR 19) (CADAAR 20) (CADADR 21) (CADDAR 22) + (CADDDR 23) (CDAAAR 24) (CDAADR 25) (CDADAR 26) (CDADDR 27) + (CDDAAR 28) (CDDADR 29) (CDDDAR 30) (CDDDDR 31))) + +(eval-when (compile eval load) +(defun CARCDREXPAND (X FG) ; FG = TRUE FOR CAR AND CDR + (let (n hx) + (COND ((ATOM X) X) + ((SETQ N (GET (RENAME (SETQ HX (CARCDREXPAND (CAR X) FG))) 'SELCODE)) + (CARCDRX1 (CARCDREXPAND (CADR X) FG) N FG)) + ((CONS HX (MAPCAR #'(LAMBDA (Y) (CARCDREXPAND Y FG)) (CDR X))))))) + +(DEFUN RENAME (U) + (let (x) + (if (AND (IDENTP U) (SETQ X (GET U 'NEWNAM))) X U))) + +(defun CARCDRX1 (X N FG) ; FG = TRUE FOR CAR AND CDR + (COND ((< N 1) (fail)) + ((EQL N 1) X) + ((let ((D (DIVIDE N 2))) + (CARCDRX1 (LIST (if (EQL (CADR D) 0) (if FG 'CAR 'CAR) (if FG 'CDR 'CDR)) X) + (CAR D) + FG)))))) + + +; 7.3 Function Invocation + +(DEFUN APPLYR (L X) (if (not L) X (LIST (CAR L) (APPLYR (CDR L) X)))) + +; 7.8 Iteration + +; 7.8.2 General Iteration + +(defmacro REPEAT (&rest L) + (let ((U (REPEAT-TRAN L NIL))) (-REPEAT (CDR U) (CAR U)))) + +(defun REPEAT-TRAN (L LP) + (COND ((ATOM L) (ERROR "REPEAT FORMAT ERROR")) + ((MEMBER (KAR (KAR L)) + '(EXIT RESET IN ON GSTEP ISTEP STEP GENERAL UNTIL WHILE SUCHTHAT EXIT)) + (REPEAT-TRAN (CDR L) (CONS (CAR L) LP))) + ((CONS (NREVERSE LP) (MKPF L 'PROGN))))) + +(DEFUN MKPF (L OP) + (if (FLAGP OP 'NARY) (SETQ L (MKPFFLATTEN-1 L OP NIL))) + (MKPF1 L OP)) + +(DEFUN MKPFFLATTEN (X OP) + (COND ((ATOM X) X) + ((EQL (CAR X) OP) (CONS OP (MKPFFLATTEN-1 (CDR X) OP NIL))) + ((CONS (MKPFFLATTEN (CAR X) OP) (MKPFFLATTEN (CDR X) OP))))) + +(DEFUN MKPFFLATTEN-1 (L OP R) + (let (X) + (if (NULL L) + R + (MKPFFLATTEN-1 (CDR L) OP + (APPEND R (if (EQCAR (SETQ X + (MKPFFLATTEN (CAR L) OP)) OP) + (CDR X) (LIST X))))))) + +(DEFUN MKPF1 (L OP) + (let (X) (case OP (PLUS (COND ((EQL 0 (SETQ X (LENGTH + (SETQ L (S- L '(0 (ZERO))))))) 0) + ((EQL 1 X) (CAR L)) + ((CONS 'PLUS L)) )) + (TIMES (COND ((S* L '(0 (ZERO))) 0) + ((EQL 0 (SETQ X (LENGTH + (SETQ L (S- L '(1 (ONE))))))) 1) + ((EQL 1 X) (CAR L)) + ((CONS 'TIMES L)) )) + (QUOTIENT (COND ((GREATERP (LENGTH L) 2) (fail)) + ((EQL 0 (CAR L)) 0) + ((EQL (CADR L) 1) (CAR L)) + ((CONS 'QUOTIENT L)) )) + (MINUS (COND ((CDR L) (FAIL)) + ((NUMBERP (SETQ X (CAR L))) (MINUS X)) + ((EQCAR X 'MINUS) (CADR X)) + ((CONS 'MINUS L)) )) + (DIFFERENCE (COND ((GREATERP (LENGTH L) 2) (FAIL)) + ((EQUAL (CAR L) (CADR L)) '(ZERO)) + ((|member| (CAR L) '(0 (ZERO))) (MKPF (CDR L) 'MINUS)) + ((|member| (CADR L) '(0 (ZERO))) (CAR L)) + ((EQCAR (CADR L) 'MINUS) + (MKPF (LIST (CAR L) (CADADR L)) 'PLUS)) + ((CONS 'DIFFERENCE L)) )) + (EXPT (COND ((GREATERP (LENGTH L) 2) (FAIL)) + ((EQL 0 (CADR L)) 1) + ((EQL 1 (CADR L)) (CAR L)) + ((|member| (CAR L) '(0 1 (ZERO) (ONE))) (CAR L)) + ((CONS 'EXPT L)) )) + (OR (COND ((MEMBER 'T L) ''T) + ((EQL 0 (SETQ X (LENGTH (SETQ L (REMOVE NIL L))))) NIL) + ((EQL 1 X) (CAR L)) + ((CONS 'OR L)) )) + (|or| (COND ((MEMBER 'T L) 'T) + ((EQL 0 (SETQ X (LENGTH (SETQ L (REMOVE NIL L))))) NIL) + ((EQL 1 X) (CAR L)) + ((CONS 'or L)) )) + (NULL (COND ((CDR L) (FAIL)) + ((EQCAR (CAR L) 'NULL) (CADAR L)) + ((EQL (CAR L) 'T) NIL) + ((NULL (CAR L)) ''T) + ((CONS 'NULL L)) )) + (|and| (COND ((EQL 0 (SETQ X (LENGTH + (SETQ L (REMOVE T (REMOVE '|true| L)))))) T) + ((EQL 1 X) (CAR L)) + ((CONS '|and| L)) )) + (AND (COND ((EQL 0 (SETQ X (LENGTH + (SETQ L (REMOVE T (REMOVE '|true| L)))))) ''T) + ((EQL 1 X) (CAR L)) + ((CONS 'AND L)) )) + (PROGN (COND ((AND (NOT (ATOM L)) (NULL (LAST L))) + (if (CDR L) `(PROGN . ,L) (CAR L))) + ((NULL (SETQ L (REMOVE NIL L))) NIL) + ((CDR L) (CONS 'PROGN L)) + ((CAR L)))) + (SEQ (COND ((EQCAR (CAR L) 'EXIT) (CADAR L)) + ((CDR L) (CONS 'SEQ L)) + ((CAR L)))) + (LIST (if L (cons 'LIST L))) + (CONS (if (cdr L) (cons 'CONS L) (car L))) + (t (CONS OP L) )))) + +(defvar $TRACELETFLAG NIL "Also referred to in Comp.Lisp") + +(defmacro |Zero| (&rest L) + (declare (ignore l)) + "Needed by spadCompileOrSetq" 0) + +(defmacro |One| (&rest L) + (declare (ignore l)) + "Needed by spadCompileOrSetq" 1) + +(defun -REPEAT (BD SPL) + (let (u g g1 inc final xcl xv il rsl tll funPLUS funGT fun? funIdent + funPLUSform funGTform) + (DO ((X SPL (CDR X))) + ((ATOM X) + (LIST 'spadDO (NREVERSE IL) (LIST (MKPF (NREVERSE XCL) 'OR) XV) + (SEQOPT (CONS 'SEQ (NCONC (NREVERSE RSL) (LIST (LIST 'EXIT BD))))))) + (COND ((ATOM (CAR X)) (FAIL))) + (COND ((AND (EQ (CAAR X) 'STEP) + (|member| (CADDAR X) '(2 1 0 (|One|) (|Zero|))) + (|member| (CADR (CDDAR X)) '(1 (|One|)))) + (SETQ X (CONS (CONS 'ISTEP (CDAR X)) (CDR X))) )) + ; A hack to increase the likelihood of small integers + (SETQ U (CDAR X)) + (case (CAAR X) + (GENERAL (AND (CDDDR U) (PUSH (CADDDR U) XCL)) + (PUSH (LIST (CAR U) (CADR U) (CADDR U)) IL) ) + (GSTEP + (SETQ tll (CDDDDR U)) ;tll is (+fun >fun type? ident) + (SETQ funPLUSform (CAR tll)) + (SETQ funGTform (CAR (SETQ tll (QCDR tll)))) + (PUSH (LIST (SETQ funPLUS (GENSYM)) funPLUSform) IL) + (PUSH (LIST (SETQ funGT (GENSYM)) funGTform) IL) + (COND ((SETQ tll (CDR tll)) + (SETQ fun? (CAR tll)) + (SETQ funIdent (CAR (SETQ tll (QCDR tll)))))) + (IF (NOT (ATOM (SETQ inc (CADDR U)) )) + (PUSH (LIST (SETQ inc (GENSYM)) (CADDR U)) IL)) + (SETQ final (CADDDR U)) + (COND (final + (COND ((ATOM final)) + ((PUSH (LIST (SETQ final (GENSYM)) (CADDDR U)) IL))) + ; If CADDDR U is not an atom, only compute the value once + (PUSH + (if fun? + (if (FUNCALL fun? INC) + (if (FUNCALL (EVAL funGTform) INC funIdent) + (LIST 'FUNCALL funGT (CAR U) FINAL) + (LIST 'FUNCALL funGT FINAL (CAR U))) + (LIST 'IF (LIST 'FUNCALL funGT INC funIdent) + (LIST 'FUNCALL funGT (CAR U) FINAL) + (LIST 'FUNCALL funGT FINAL (CAR U)))) + (LIST 'FUNCALL funGT (CAR U) final)) + XCL))) + (PUSH (LIST (CAR U) (CADR U) (LIST 'FUNCALL funPLUS (CAR U) INC)) IL)) + (STEP + (IF (NOT (ATOM (SETQ inc (CADDR U)) )) + (PUSH (LIST (SETQ inc (GENSYM)) (CADDR U)) IL)) + (COND ((CDDDR U) + (COND ((ATOM (SETQ final (CADDDR U)) )) + ((PUSH (LIST (SETQ final (GENSYM)) (CADDDR U)) IL))) + ; If CADDDR U is not an atom, only compute the value once + (PUSH + (if (INTEGERP INC) + (LIST (if (MINUSP INC) '< '>) (CAR U) FINAL) + `(if (MINUSP ,INC) + (< ,(CAR U) ,FINAL) + (> ,(CAR U) ,FINAL))) + XCL))) + (PUSH (LIST (CAR U) (CADR U) (LIST '+ (CAR U) INC)) IL)) + (ISTEP + (IF (NOT (ATOM (SETQ inc (CADDR U)) )) + (PUSH (LIST (SETQ inc (GENSYM)) (CADDR U)) IL)) + (COND ((CDDDR U) + (COND ((ATOM (SETQ final (CADDDR U)) )) + ((PUSH (LIST (SETQ final (GENSYM)) (CADDDR U)) IL))) + ; If CADDDR U is not an atom, only compute the value once + (PUSH + (if (INTEGERP INC) + (LIST (if (QSMINUSP INC) 'QSLESSP 'QSGREATERP) + (CAR U) FINAL) + `(if (QSMINUSP ,INC) + (QSLESSP ,(CAR U) ,FINAL) + (QSGREATERP ,(CAR U) ,FINAL))) + XCL))) + (PUSH (LIST (CAR U) (CADR U) + (COND ((|member| INC '(1 (|One|))) + (MKQSADD1 (CAR U))) + ((LIST 'QSPLUS (CAR U) INC)) )) + IL)) + (ON (PUSH (LIST 'ATOM (CAR U)) XCL) + (PUSH (LIST (CAR U) (CADR U) (LIST 'CDR (CAR U))) IL)) + (RESET (PUSH (LIST 'PROGN (CAR U) NIL) XCL)) + (IN + (PUSH (LIST 'OR + (LIST 'ATOM (SETQ G (GENSYM))) + (CONS 'PROGN + (CONS + (LIST 'SETQ (CAR U) (LIST 'CAR G)) + (APPEND + (COND ((AND (symbol-package (car U)) $TRACELETFLAG) + (LIST (LIST '/TRACELET-PRINT (CAR U) + (CAR U)))) + (NIL)) + (LIST NIL)))) ) XCL) + (PUSH (LIST G (CADR U) (LIST 'CDR G)) IL) + (PUSH (LIST (CAR U) NIL) IL)) + (INDOM (SETQ G (GENSYM)) + (SETQ G1 (GENSYM)) + (PUSH (LIST 'ATOM G) XCL) + (PUSH (LIST G (LIST 'INDOM-FIRST (CADR U)) + (LIST 'INDOM-NEXT G1)) IL) + (PUSH (LIST (CAR U) NIL) IL) + (PUSH (LIST G1 NIL) IL) + (PUSH (LIST 'SETQ G1 (LIST 'CDR G)) RSL) + (PUSH (LIST 'SETQ (CAR U) (LIST 'CAR G)) RSL)) + (UNTIL (SETQ G (GENSYM)) (PUSH (LIST G NIL (CAR U)) IL) (PUSH G XCL)) + (WHILE (PUSH (LIST 'NULL (CAR U)) XCL)) + (SUCHTHAT (SETQ BD (LIST 'SUCHTHATCLAUSE BD (CAR U)))) + (EXIT (SETQ XV (CAR U))) (FAIL))))) + + +(defun SEQOPT (U) + (if (AND (EQCAR U 'SEQ) (EQCAR (CADR U) 'EXIT) (EQCAR (CADADR U) 'SEQ)) + (CADADR U) + U)) + +(defmacro SUCHTHATCLAUSE (&rest L) (LIST 'COND (LIST (CADR L) (CAR L)))) + +(defvar $NEWSPAD NIL) +(defvar $BOOT NIL) + +(defmacro spadDO (&rest OL) + (PROG (VARS L VL V U INITS U-VARS U-VALS ENDTEST EXITFORMS BODYFORMS) + (if (OR $BOOT (NOT $NEWSPAD)) (return (CONS 'DO OL))) + (SETQ L (copy-list OL)) + (if (OR (ATOM L) (ATOM (CDR L))) (GO BADO)) + (setq vl (POP L)) + (COND ((IDENTP VL) + (SETQ VARS (LIST VL)) + (AND (OR (ATOM L) + (ATOM (progn (setq inits (POP L)) L)) + (ATOM (progn (setq u-vals (pop L)) L))) + (GO BADO)) + (SETQ INITS (LIST INITS) U-VARS (LIST (CAR VARS)) U-VALS (LIST U-VALS)) + (setq endtest (POP L))) + ((prog nil + (COND ((NULL VL) (GO TG5)) ((ATOM VL) (GO BADO))) + G180 (AND (NOT (PAIRP (SETQ V (CAR VL)))) (SETQ V (LIST V))) + (AND (NOT (IDENTP (CAR V))) (GO BADO)) + (PUSH (CAR V) VARS) + (PUSH (COND ((PAIRP (CDR V)) (CADR V))) INITS) + (AND (PAIRP (CDR V)) + (PAIRP (CDDR V)) + (SEQ (PUSH (CAR V) U-VARS) + (PUSH (CADDR V) U-VALS))) + (AND (PAIRP (progn (POP VL) VL)) (GO G180)) + TG5 (setq exitforms (POP L)) + (and (PAIRP EXITFORMS) + (progn (setq endtest (POP EXITFORMS)) exitforms))))) + (AND L + (COND ((CDR L) (SETQ BODYFORMS (CONS 'SEQ L))) + ((NULL (EQCAR (CAR L) 'SEQ)) (SETQ BODYFORMS (CONS 'SEQ L))) + ((SETQ BODYFORMS (CAR L))))) + (SETQ EXITFORMS `(EXIT ,(MKPF EXITFORMS 'PROGN))) + (AND ENDTEST (SETQ ENDTEST (LIST 'COND (LIST ENDTEST '(GO G191))))) + (COND ((NULL U-VARS) (GO XT) ) + ((NULL (CDR U-VARS)) + (SEQ (SETQ U-VARS (LIST 'SETQ (CAR U-VARS) (CAR U-VALS))) + (GO XT)) )) + (SETQ VL (LIST 'SETQ (CAR U-VARS) (CAR U-VALS))) + (SEQ (SETQ V (CDR U-VARS)) (SETQ U (CDR U-VALS))) + TG (SETQ VL (LIST 'SETQ (CAR V) (LIST 'PROG1 (CAR U) VL))) + (POP U) + (AND (progn (POP V) V) (GO TG)) + (SETQ U-VARS VL) + XT (RETURN (COND + ((AND $NEWSPAD (NULL $BOOT)) + (CONS 'SEQ (NCONC (DO_LET VARS INITS) + (LIST 'G190 ENDTEST BODYFORMS U-VARS '(GO G190) + 'G191 EXITFORMS)))) + ((CONS `(LAMBDA ,(NRECONC VARS NIL) + (SEQ G190 ,ENDTEST ,BODYFORMS ,U-VARS (GO G190) G191 ,EXITFORMS)) + (NRECONC INITS NIL))))) + BADO (ERROR (FORMAT NIL "BAD DO FORMAT~%~A" OL)))) + +(defun DO_LET (VARS INITS) + (if (OR (NULL VARS) (NULL INITS)) NIL + (CONS (LIST 'SPADLET (CAR VARS) (CAR INITS)) + (DO_LET (CDR VARS) (CDR INITS))))) + +#-:CCL +(defun NREVERSE0 (X) ; Already built-in to CCL + "Returns LST, reversed. The argument is modified. +This version is needed so that (COLLECT (IN X Y) ... (RETURN 'JUNK))=>JUNK." + (if (ATOM X) X (NREVERSE X))) + +; 7.8.4 Mapping + +(defmacro COLLECT (&rest L) + (let ((U (REPEAT-TRAN L NIL))) + (CONS 'THETA (CONS '\, (NCONC (CAR U) (LIST (CDR U))))))) + +;; The following was changed to a macro for efficiency in CCL. To change +;; it back to a function would require recompilation of a large chunk of +;; the library. +(defmacro PRIMVEC2ARR (x) x) ;redefine to change Array rep + +(defmacro COLLECTVEC (&rest L) + `(PRIMVEC2ARR (COLLECTV ,@L))) + +(defmacro COLLECTV (&rest L) + (PROG (CONDS BODY ANS COUNTER X Y) + ;If we can work out how often we will go round + ;allocate a vector first + (SETQ CONDS NIL) + (SETQ BODY (REVERSE L)) + (SETQ ANS (GENSYM)) + (SETQ COUNTER NIL) + (SETQ X (CDR BODY)) + (SETQ BODY (CAR BODY)) +LP (COND ((NULL X) + (COND ((NULL COUNTER) + (SETQ COUNTER (GENSYM)) + (SETQ L (CONS (LIST 'ISTEP COUNTER 0 1) L)) )) + (RETURN (LIST 'PROGN + (LIST 'SPADLET ANS + (LIST 'GETREFV + (COND ((NULL CONDS) (fail)) + ((NULL (CDR CONDS)) + (CAR CONDS)) + ((CONS 'MIN CONDS)) ) )) + (CONS 'REPEAT (NCONC (CDR (REVERSE L)) + (LIST (LIST 'SETELT ANS COUNTER BODY)))) + ANS)) )) + (SETQ Y (CAR X)) + (SETQ X (CDR X)) + (COND ((MEMQ (CAR Y) '(SUCHTHAT WHILE UNTIL)) + (RETURN (LIST 'LIST2VEC (CONS 'COLLECT L)) )) + ((member (CAR Y) '(IN ON) :test #'eq) + (SETQ CONDS (CONS (LIST 'SIZE (CADDR Y)) CONDS)) + (GO LP)) + ((member (CAR Y) '(STEP ISTEP) :test #'eq) + (if (AND (EQL (CADDR Y) 0) (EQL (CADDDR Y) 1)) + (SETQ COUNTER (CADR Y)) ) + (COND ((CDDDDR Y) ; there may not be a limit + (SETQ CONDS (CONS + (COND ((EQL 1 (CADDDR Y)) + (COND ((EQL 1 (CADDR Y)) (CAR (CDDDDR Y))) + ((EQL 0 (CADDR Y)) (MKQSADD1 (CAR (CDDDDR Y)))) + ((MKQSADD1 `(- ,(CAR (CDDDDR Y)) ,(CADDR Y)))))) + ((EQL 1 (CADDR Y)) `(/ ,(CAR (CDDDDR Y)) ,(CADDR Y))) + ((EQL 0 (CADDR Y)) + `(/ ,(MKQSADD1 (CAR (CDDDDR Y))) ,(CADDR Y))) + (`(/ (- ,(MKQSADD1 (CAR (CDDDDR Y))) ,(CADDR Y)) + ,(CADDR Y)))) + CONDS)))) + (GO LP))) + (ERROR "Cannot handle macro expansion"))) + +(defun MKQSADD1 (X) + (COND ((ATOM X) `(QSADD1 ,X)) + ((AND (member (CAR X) '(-DIFFERENCE QSDIFFERENCE -) :test #'eq) + (EQL 1 (CADDR X))) + (CADR X)) + (`(QSADD1 ,X)))) + +; 7.10 Dynamic Non-local Exits + +(defmacro yield (L) + (let ((g (gensym))) + `(let ((,g (state))) + (if (statep ,g) (throw 'yield (list 'pair ,L) ,g))))) + +; 10.1 The Property List + +(DEFUN FLAG (L KEY) + "Set the KEY property of every item in list L to T." + (mapc #'(lambda (item) (makeprop item KEY T)) L)) + +(FLAG '(* + AND OR PROGN) 'NARY) ; flag for MKPF + +(DEFUN REMFLAG (L KEY) + "Set the KEY property of every item in list L to NIL." + (OR (ATOM L) (SEQ (REMPROP (CAR L) KEY) (REMFLAG (CDR L) KEY)))) + +(DEFUN FLAGP (X KEY) + "If X has a KEY property, then FLAGP is true." + (GET X KEY)) + +(defun PROPERTY (X IND N) + "Returns the Nth element of X's IND property, if it exists." + (let (Y) (if (AND (INTEGERP N) (SETQ Y (GET X IND)) (>= (LENGTH Y) N)) (ELEM Y N)))) + +; 10.3 Creating Symbols + +(defmacro INTERNL (a &rest b) (if (not b) `(intern ,a) `(intern (strconc ,a . ,b)))) + +(defvar $GENNO 0) + +(DEFUN GENVAR () (INTERNL "$" (STRINGIMAGE (SETQ $GENNO (1+ $GENNO))))) + +(DEFUN IS_GENVAR (X) + (AND (IDENTP X) + (let ((y (symbol-name x))) + (and (char= #\$ (elt y 0)) (> (size y) 1) (digitp (elt y 1)))))) + +(DEFUN IS_\#GENVAR (X) + (AND (IDENTP X) + (let ((y (symbol-name x))) + (and (char= #\# (ELT y 0)) (> (SIZE Y) 1) (DIGITP (ELT Y 1)))))) + +; 10.7 CATCH and THROW + +(defmacro SPADCATCH (&rest form) (CONS 'CATCH form)) + +(defmacro SPADTHROW (&rest form) (CONS 'THROW form)) + +; 12 NUMBERS + +; 12.3 Comparisons on Numbers + +(defmacro IEQUAL (&rest L) `(eql . ,L)) +(defmacro GE (&rest L) `(>= . ,L)) +(defmacro GT (&rest L) `(> . ,L)) +(defmacro LE (&rest L) `(<= . ,L)) +(defmacro LT (&rest L) `(< . ,L)) + +; 12.4 Arithmetic Operations + +(defmacro SPADDIFFERENCE (&rest x) `(- . ,x)) + +; 12.5 Irrational and Transcendental Functions + +; 12.5.1 Exponential and Logarithmic Functions + +(define-function 'QSEXPT #'expt) + +; 12.6 Small Finite Field ops with vector trimming + +;; following macros assume 0 <= x,y < z + +(defmacro qsaddmod (x y z) + `(let* ((sum (qsplus ,x ,y)) + (rsum (qsdifference sum ,z))) + (if (qsminusp rsum) sum rsum))) + +(defmacro qsdifmod (x y z) + `(let ((dif (qsdifference ,x ,y))) + (if (qsminusp dif) (qsplus dif ,z) dif))) + +(defmacro qsmultmod (x y z) + `(rem (* ,x ,y) ,z)) + +(defun TRIMLZ (vec) + (declare (simple-vector vec)) + (let ((n (position 0 vec :from-end t :test-not #'eql))) + (cond ((null n) (vector)) + ((eql n (qvmaxindex vec)) vec) + (t (subseq vec 0 (+ n 1)))))) + +;; In CCL ASH assumes a 2's complement machine. We use ASH in Integer and +;; assume we have a sign and magnitude setup. +#+:CCL (defmacro ash (u v) `(lisp::ash1 ,u ,v)) + +; 14 SEQUENCES + +; 14.1 Simple Sequence Functions + +(DEFUN NLIST (N FN) + "Returns a list of N items, each initialized to the value of an + invocation of FN" + (if (LT N 1) NIL (CONS (EVAL FN) (NLIST (SUB1 N) FN)))) + +(define-function 'getchar #'elt) + +(defun GETCHARN (A M) "Return the code of the Mth character of A" + (let ((a (if (identp a) (symbol-name a) a))) (char-code (elt A M)))) + +; 14.2 Concatenating, Mapping, and Reducing Sequences + +(DEFUN STRINGPAD (STR N) + (let ((M (length STR))) + (if (>= M N) + STR + (concatenate 'string str (make-string (- N M) :initial-element #\Space))))) + +(DEFUN STRINGSUFFIX (TARGET SOURCE) "Suffix source to target if enough room else nil." + (concatenate 'string target source)) + +(defun NSTRCONC (s1 s2) (concatenate 'string (string s1) (string s2))) + +(defmacro spadREDUCE (OP AXIS BOD) (REDUCE-1 OP AXIS BOD)) + +(MAPC #'(LAMBDA (X) (MAKEPROP (CAR X) 'THETA (CDR X))) + '((PLUS 0) (+ (|Zero|)) (|lcm| (|One|)) (STRCONC "") (|strconc| "") + (MAX -999999) (MIN 999999) (TIMES 1) (* (|One|)) (CONS NIL) + (APPEND NIL) (|append| NIL) (UNION NIL) (UNIONQ NIL) (|gcd| (|Zero|)) + (|union| NIL) (NCONC NIL) (|and| |true|) (|or| |false|) (AND 'T) + (OR NIL))) + +(define-function '|append| #'APPEND) + +;;(defun |delete| (item list) ; renaming from DELETE is done in DEF +;; (cond ((atom list) list) +;; ((equalp item (qcar list)) (|delete| item (qcdr list))) +;; ('t (cons (qcar list) (|delete| item (qcdr list)))))) + +(defun |delete| (item sequence) + (cond ((symbolp item) (remove item sequence :test #'eq)) + ((and (atom item) (not (arrayp item))) (remove item sequence)) + (T (remove item sequence :test #'equalp)))) + +(MAPC #'(LAMBDA (J) (MAKEPROP (CAR J) 'UNMACRO (CADR J))) + '( (AND AND2) (OR OR2))) + +(defun and2 (x y) (and x y)) + +(defun or2 (x y) (or x y)) + +(MAKEPROP 'CONS 'RIGHT-ASSOCIATIVE T) + +(defun REDUCE-1 (OP AXIS BOD) + (let (u op1 tran iden) + (SEQ (SETQ OP1 (cond ((EQ OP '\,) 'CONS) + ((EQCAR OP 'QUOTE) (CADR OP)) + (OP))) + (SETQ IDEN (if (SETQ U (GET OP1 'THETA)) (CAR U) 'NO_THETA_PROPERTY)) + (SETQ TRAN (if (EQCAR BOD 'COLLECT) + (PROG (L BOD1 ITL) + (SETQ L (REVERSE (CDR BOD))) + (SETQ BOD1 (CAR L)) + (SETQ ITL (NREVERSE (CDR L))) + (RETURN (-REDUCE OP1 AXIS IDEN BOD1 ITL)) ) + (progn (SETQ U (-REDUCE-OP OP1 AXIS)) + (LIST 'REDUCE-N (MKQ (OR (GET U 'UNMACRO) U)) + (GET OP1 'RIGHT-ASSOCIATIVE) + BOD IDEN)))) + (if (EQ OP '\,) (LIST 'NREVERSE-N TRAN AXIS) TRAN)))) + +(defun -REDUCE (OP AXIS Y BODY SPL) + (PROG (X G AUX EXIT VALUE PRESET CONSCODE RESETCODE) + (SETQ G (GENSYM)) + ; create preset of accumulate + (SETQ PRESET (COND + ((EQ Y 'NO_THETA_PROPERTY) (LIST 'SPADLET G (MKQ G))) + ((LIST 'SPADLET G Y)) )) + (SETQ EXIT (COND + ((SETQ X (ASSOC 'EXIT SPL))(SETQ SPL (DELASC 'EXIT SPL)) (COND + ((MEMBER OP '(AND OR)) (LIST 'AND G (CADR X))) ((CADR X)) )) + ((EQ Y 'NO_THETA_PROPERTY) (LIST 'THETACHECK G (MKQ G)(MKQ OP))) + (G) )) + (COND ((EQ OP 'CONS) (SETQ EXIT (LIST 'NREVERSE0 EXIT)))) + ; CONSCODE= code which conses a member onto the list + (SETQ VALUE (COND ((EQ Y 'NO_THETA_PROPERTY) (GENSYM)) + (BODY))) + (SETQ CONSCODE (CONS (-REDUCE-OP OP AXIS) (COND + ((FLAGP OP 'RIGHT-ASSOCIATIVE) (LIST VALUE G)) + ((LIST G VALUE) ) ) ) ) + ; next reset code which varies if THETA property is|/is not given + (SETQ RESETCODE (LIST 'SETQ G (COND + ((EQ Y 'NO_THETA_PROPERTY) + (LIST 'COND (LIST (LIST 'EQ G (MKQ G)) VALUE) + (LIST ''T CONSCODE)) ) + (CONSCODE) ))) + ; create body + (SETQ BODY (COND ((EQ VALUE BODY) RESETCODE) + ((LIST 'PROGN (LIST 'SPADLET VALUE BODY) RESETCODE)) )) + (SETQ AUX (CONS (LIST 'EXIT EXIT) (COND + ((EQ OP 'AND) (LIST (LIST 'UNTIL (LIST 'NULL G)))) + ((EQ OP 'OR) (LIST (LIST 'UNTIL G))) + (NIL) ))) + (RETURN (COND + ((AND $NEWSPAD (NULL $BOOT)) (LIST 'PROGN PRESET + (CONS 'REPEAT (APPEND AUX (APPEND SPL (LIST BODY))) ))) + ((LIST 'PROG + (COND ((EQ RESETCODE BODY) (LIST G)) ((LIST G VALUE))) + PRESET (LIST 'RETURN + (CONS 'REPEAT (APPEND AUX (APPEND SPL (LIST BODY))))))))))) + +(defun -REDUCE-OP (OP AXIS) + (COND ((EQL AXIS 0) OP) + ((EQL AXIS 1) + (COND ((EQ OP 'CONS) 'CONS-N) + ((EQ OP 'APPEND) 'APPEND-N) + ((FAIL)))) + ((FAIL)))) + +(defun NREVERSE-N (X AXIS) + (COND ((EQL AXIS 0) (NREVERSE X)) + ((MAPCAR #'(LAMBDA (Y) (NREVERSE-N Y (SUB1 AXIS))) X)))) + +(defun CONS-N (X Y) + (COND ((NULL Y) (CONS-N X (NLIST (LENGTH X) NIL))) + ((MAPCAR #'CONS X Y)))) + +(defun APPEND-N (X Y) + (COND ((NULL X) (APPEND-N (NLIST (LENGTH Y) NIL) Y)) + ((MAPCAR #'APPEND X Y)))) + +(defun REDUCE-N (OP RIGHT L ACC) + (COND (RIGHT (PROG (U L1) + (SETQ L1 (NREVERSE L)) + (SETQ U (REDUCE-N-1 OP 'T L1 ACC)) + (NREVERSE L1) + (RETURN U) )) + ((REDUCE-N-1 OP NIL L ACC)))) + +(defun REDUCE-N-1 (OP RIGHT L ACC) + (COND ((EQ ACC 'NO_THETA_PROPERTY) + (COND ((NULL L) (THETA_ERROR OP)) + ((REDUCE-N-2 OP RIGHT (CDR L) (CAR L))) )) + ((REDUCE-N-2 OP RIGHT L ACC)))) + +(defun REDUCE-N-2 (OP RIGHT L ACC) + (COND ((NULL L) ACC) + (RIGHT (REDUCE-N-2 OP RIGHT (CDR L) (funcall (symbol-function OP) (CAR L) ACC))) + ((REDUCE-N-2 OP RIGHT (CDR L) (funcall (symbol-function OP) ACC (CAR L)))))) + +(defmacro THETA (&rest LL) + (let (U (L (copy-list LL))) + (if (EQ (KAR L) '\,) `(theta CONS . ,(CDR L)) + (progn + (if (EQCAR (CAR L) 'QUOTE) (RPLAC (CAR L) (CADAR L))) + (-REDUCE (CAR L) 0 + (if (SETQ U (GET (CAR L) 'THETA)) (CAR U) + (MOAN "NO THETA PROPERTY")) + (CAR (SETQ L (NREVERSE (CDR L)))) + (NREVERSE (CDR L))))))) + +(defmacro THETA1 (&rest LL) + (let (U (L (copy-list LL))) + (if (EQ (KAR L) '\,) + (LIST 'NREVERSE-N (CONS 'THETA1 (CONS 'CONS (CDR L))) 1) + (-REDUCE (CAR L) 1 + (if (SETQ U (GET (CAR L) 'THETA)) (CAR U) + (MOAN "NO THETA PROPERTY")) + (CAR (SETQ L (NREVERSE (CDR L)))) + (NREVERSE (CDR L)))))) + + +(defun THETACHECK (VAL VAR OP) (if (EQL VAL VAR) (THETA_ERROR OP) val)) + +(defun THETA_ERROR (OP) + (Boot::|userError| + (LIST "Sorry, do not know the identity element for " OP))) + +; 15 LISTS + +; 15.1 Conses + + +(defmacro |SPADfirst| (l) + (let ((tem (gensym))) + `(let ((,tem ,l)) (if ,tem (car ,tem) (first-error))))) + +(defun first-error () (error "Cannot take first of an empty list")) + +; 15.2 Lists + + +(defmacro ELEM (val &rest indices) + (if (null indices) val `(ELEM (nth (1- ,(car indices)) ,val) ,@(cdr indices)))) + +(defun ELEMN (X N DEFAULT) + (COND ((NULL X) DEFAULT) + ((EQL N 1) (CAR X)) + ((ELEMN (CDR X) (SUB1 N) DEFAULT)))) + +(defmacro TAIL (&rest L) + (let ((x (car L)) (n (if (cdr L) (cadr L) 1))) + (COND ((EQL N 0) X) + ((EQL N 1) (LIST 'CDR X)) + ((GT N 1) (APPLYR (PARTCODET N) X)) + ((LIST 'TAILFN X N))))) + +(defun PARTCODET (N) + (COND ((OR (NULL (INTEGERP N)) (LT N 1)) (ERROR 'PARTCODET)) + ((EQL N 1) '(CDR)) + ((EQL N 2) '(CDDR)) + ((EQL N 3) '(CDDDR)) + ((EQL N 4) '(CDDDDR)) + ((APPEND (PARTCODET (PLUS N -4)) '(CDDDDR))))) + +(defmacro TL (&rest L) `(tail . ,L)) + +(defun TAILFN (X N) (if (LT N 1) X (TAILFN (CDR X) (SUB1 N)))) + +(defmacro SPADCONST (&rest L) (cons 'qrefelt L)) + +(defmacro SPADCALL (&rest L) + (let ((args (butlast l)) (fn (car (last l))) (gi (gensym))) + ;; (values t) indicates a single return value + `(let ((,gi ,fn)) (the (values t) (funcall (car ,gi) ,@args (cdr ,gi)))) + )) + +(DEFUN LASTELEM (X) (car (last X))) + +(defun LISTOFATOMS (X) + (COND ((NULL X) NIL) + ((ATOM X) (LIST X)) + ((NCONC (LISTOFATOMS (CAR X)) (LISTOFATOMS (CDR X)))))) + +(DEFUN LASTATOM (L) (if (ATOM L) L (LASTATOM (CDR L)))) + +(define-function 'LASTTAIL #'last) + +(define-function 'LISPELT #'ELT) + +(defun DROP (N X &aux m) + "Return a pointer to the Nth cons of X, counting 0 as the first cons." + (COND ((EQL N 0) X) + ((> N 0) (DROP (1- N) (CDR X))) + ((>= (setq m (+ (length x) N)) 0) (take m x)) + ((CROAK (list "Bad args to DROP" N X))))) + +(DEFUN TAKE (N X &aux m) + "Returns a list of the first N elements of list X." + (COND ((EQL N 0) NIL) + ((> N 0) (CONS (CAR X) (TAKE (1- N) (CDR X)))) + ((>= (setq m (+ (length x) N)) 0) (drop m x)) + ((CROAK (list "Bad args to DROP" N X))))) + +(DEFUN NUMOFNODES (X) (if (ATOM X) 0 (+ 1 (NUMOFNODES (CAR X)) (NUMOFNODES (CDR X))))) + +(DEFUN TRUNCLIST (L TL) "Truncate list L at the point marked by TL." + (let ((U L)) (TRUNCLIST-1 L TL) U)) + +(DEFUN TRUNCLIST-1 (L TL) + (COND ((ATOM L) L) + ((EQL (CDR L) TL) (RPLACD L NIL)) + ((TRUNCLIST-1 (CDR L) TL)))) + +; 15.3 Alteration of List Structure + +(defun RPLACW (x w) (let (y z) (dsetq (Y . Z) w) (RPLACA X Y) (RPLACD X Z) X)) + +; 15.4 Substitution of Expressions + +(DEFUN SUBSTEQ (NEW OLD FORM) + "Version of SUBST that uses EQ rather than EQUAL on the world." + (PROG (NFORM HNFORM ITEM) + (SETQ HNFORM (SETQ NFORM (CONS () ()))) + LP (RPLACD NFORM + (COND ((EQ FORM OLD) (SETQ FORM ()) NEW ) + ((NOT (PAIRP FORM)) FORM ) + ((EQ (SETQ ITEM (CAR FORM)) OLD) (CONS NEW ()) ) + ((PAIRP ITEM) (CONS (SUBSTEQ NEW OLD ITEM) ()) ) + ((CONS ITEM ())))) + (if (NOT (PAIRP FORM)) (RETURN (CDR HNFORM))) + (SETQ NFORM (CDR NFORM)) + (SETQ FORM (CDR FORM)) + (GO LP))) + +(DEFUN SUBLISNQ (KEY E) (declare (special KEY)) (if (NULL KEY) E (SUBANQ E))) + +(DEFUN SUBANQ (E) + (declare (special key)) + (COND ((ATOM E) (SUBB KEY E)) + ((EQCAR E (QUOTE QUOTE)) E) + ((MAPCAR #'(LAMBDA (J) (SUBANQ J)) E)))) + +(DEFUN SUBB (X E) + (COND ((ATOM X) E) + ((EQ (CAAR X) E) (CDAR X)) + ((SUBB (CDR X) E)))) + +(defun SUBLISLIS (newl oldl form) + (sublis (mapcar #'cons oldl newl) form)) + +; 15.5 Using Lists as Sets + +@ +\section{DEFUN CONTAINED} +The CONTAINED predicate is used to walk internal structures +such as modemaps to see if the $X$ object occurs within $Y$. One +particular use is in a function called isPartialMode (see +i-funsel.boot) to decide +if a modemap is only partially complete. If this is true then the +modemap will contain the constant \verb|$EmptyMode|. So the call +ends up being CONTAINED \verb|$EmptyMode| Y. +<<*>>= +#-:CCL +(DEFUN CONTAINED (X Y) + (if (symbolp x) + (contained\,eq X Y) + (contained\,equal X Y))) + +(defun contained\,eq (x y) + (if (atom y) (eq x y) + (or (contained\,eq x (car y)) (contained\,eq x (cdr y))))) + +(defun contained\,equal (x y) + (cond ((atom y) (equal x y)) + ((equal x y) 't) + ('t (or (contained\,equal x (car y)) (contained\,equal x (cdr y)))))) + +(DEFUN S+ (X Y) + (COND ((ATOM Y) X) + ((ATOM X) Y) + ((MEMBER (CAR X) Y :test #'equal) (S+ (CDR X) Y)) + ((S+ (CDR X) (CONS (CAR X) Y))))) + +(defun S* (l1 l2) (INTERSECTION l1 l2 :test #'equal)) +(defun S- (l1 l2) (set-difference l1 l2 :test #'equal)) + +(DEFUN PREDECESSOR (TL L) + "Returns the sublist of L whose CDR is EQ to TL." + (COND ((ATOM L) NIL) + ((EQ TL (CDR L)) L) + ((PREDECESSOR TL (CDR L))))) + +(defun remdup (l) (remove-duplicates l :test #'equalp)) + +(DEFUN GETTAIL (X L) (member X L :test #'equal)) + +; 15.6 Association Lists + +(defun DelAsc (u v) "Returns a copy of a-list V in which any pair with key U is deleted." + (cond ((atom v) nil) + ((or (atom (car v))(not (equal u (caar v)))) + (cons (car v) (DelAsc u (cdr v)))) + ((cdr v)))) + +(DEFUN ADDASSOC (X Y L) + "Put the association list pair (X . Y) into L, erasing any previous association for X" + (COND ((ATOM L) (CONS (CONS X Y) L)) + ((EQUAL X (CAAR L)) (CONS (CONS X Y) (CDR L))) + ((CONS (CAR L) (ADDASSOC X Y (CDR L)))))) + +(DEFUN DELLASOS (U V) + "Remove any assocation pair (U . X) from list V." + (COND ((ATOM V) NIL) + ((EQUAL U (CAAR V)) (CDR V)) + ((CONS (CAR V) (DELLASOS U (CDR V)))))) + +(DEFUN ASSOCLEFT (X) + "Returns all the keys of association list X." + (if (ATOM X) X (mapcar #'car x))) + +(DEFUN ASSOCRIGHT (X) + "Returns all the datums of association list X." + (if (ATOM X) X (mapcar #'cdr x))) + +(DEFUN LASSOC (X Y) + "Return the datum associated with key X in association list Y." + (PROG NIL + A (COND ((ATOM Y) (RETURN NIL)) + ((EQUAL (CAAR Y) X) (RETURN (CDAR Y))) ) + (SETQ Y (CDR Y)) + (GO A))) + +(DEFUN |rassoc| (X Y) + "Return the datum associated with key X in association list Y." + (PROG NIL + A (COND ((ATOM Y) (RETURN NIL)) + ((EQUAL (CDAR Y) X) (RETURN (CAAR Y))) ) + (SETQ Y (CDR Y)) + (GO A))) + +; (defun QLASSQ (p a-list) (let ((y (assoc p a-list :test #'eq))) (if y (cdr y)))) +(defun QLASSQ (p a-list) (cdr (assq p a-list))) + +(define-function 'LASSQ #'QLASSQ) + +(defun pair (x y) (mapcar #'cons x y)) + +;;; Operations on Association Sets (AS) + +(defun AS-INSERT (A B L) + ;; PF(item) x PF(item) x LIST(of pairs) -> LIST(of pairs with (A . B) added) + ;; destructive on L; if (A . C) appears already, C is replaced by B + (cond ((null l) (list (cons a b))) + ((equal a (caar l)) (rplac (cdar l) b) l) + ((?order a (caar l)) (cons (cons a b) l)) + (t (as-insert1 a b l) l))) + +(defun as-insert1 (a b l) + (cond ((null (cdr l)) (rplac (cdr l) (list (cons a b)))) + ((equal a (caadr l)) (rplac (cdadr l) b)) + ((?order a (caadr l)) (rplac (cdr l) (cons (cons a b) (cdr l)))) + (t (as-insert1 a b (cdr l))))) + + +; 17 ARRAYS + +; 17.6 Changing the Dimensions of an Array + +@ +\section{Performance change} +Camm has identified a performace problem during compiles. There is +a loop that continually adds one element to a vector. This causes +the vector to get extended by 1 and copied. These patches fix the +problem since vectors with fill pointers don't need to be copied. + +These cut out the lion's share of the gc problem +on this compile. 30min {\tt ->} 7 min on my box. There is still some gc +churning in cons pages due to many calls to 'list' with small n. One +can likely improve things further with an appropriate (declare +(:dynamic-extent ...)) in the right place -- gcl will allocate such +lists on the C stack (very fast). + +\subsection{lengthenvec} +The original code was: +\begin{verbatim} +(defun lengthenvec (v n) + (if (adjustable-array-p v) (adjust-array v n) + (replace (make-array n) v))) +\end{verbatim} + +@ +<<*>>= +(defun lengthenvec (v n) + (if + (and (array-has-fill-pointer-p v) (adjustable-array-p v)) + (if + (>= n (array-total-size v)) + (adjust-array v (* n 2) :fill-pointer n) + (progn + (setf (fill-pointer v) n) + v)) + (replace (make-array n :fill-pointer t) v))) + +(defun make-init-vector (n val) + (make-array n :initial-element val :fill-pointer t)) + +; 22 INPUT/OUTPUT + +; 22.2 Input Functions + +; 22.2.1 Input from Character Streams + +(DEFUN STREAM-EOF (&optional (STRM *terminal-io*)) + "T if input stream STRM is at the end or saw a ~." + (not (peek-char nil STRM nil nil nil)) ) + +(DEFUN CONSOLEINPUTP (STRM) (IS-CONSOLE STRM)) + +(defvar $filelinenumber 0) +(defvar $prompt "--->") +(defvar stream-buffer nil) + +(DEFUN NEXTSTRMLINE (STRM) "Returns the next input line from stream STRM." + (let ((v (read-line strm nil -1 nil))) + (if (equal v -1) (throw 'spad_reader nil) + (progn (setq stream-buffer v) v)))) + +(DEFUN CURSTRMLINE (STRM) + "Returns the current input line from the stream buffer of STRM (VM-specific!)." + (cond (stream-buffer) + ((stream-eof strm) (fail)) + ((nextstrmline strm)))) + +(defvar *EOF* NIL) + +(DEFUN CURMAXINDEX (STRM) +"Something bizarre and VM-specific with respect to streams." + (if *EOF* (FAIL) (ELT (ELT (LASTATOM STRM) 1) 3))) + +(DEFUN ADJCURMAXINDEX (STRM) +"Something unearthly and VM-specific with respect to streams." + (let (v) (if *eof* (fail) + (progn (SETQ V (ELT (LASTATOM STRM) 1)) + (SETELT V 3 (SIZE (ELT V 0))))))) + +(DEFUN STRMBLANKLINE (STRM) +"Something diabolical and VM-specific with respect to streams." + (if *EOF* (FAIL) (AND (EQ '\ (CAR STRM)) (EQL 1 (CURMAXINDEX STRM))))) + +(DEFUN STRMSKIPTOBLANK (STRM) +"Munch away on the stream until you get to a blank line." + (COND (*EOF* (FAIL)) + ((PROGN (NEXTSTRMLINE STRM) (STRMBLANKLINE STRM)) STRM) + ((STRMSKIPTOBLANK STRM)))) + +(DEFUN CURINPUTLINE () (CURSTRMLINE *standard-input*)) + +(DEFUN NEXTINPUTLINE () (NEXTSTRMLINE *standard-input*)) + +; 22.3 Output Functions + +; 22.3.1 Output to Character Streams + +(DEFUN ATOM2STRING (X) + "Give me the string which would be printed out to denote an atom." + (cond ((atom x) (symbol-name x)) + ((stringp x) x) + ((write-to-string x)))) + +(defvar |conOutStream| *terminal-io* "console output stream") + +(defun |sayTeX| (x) (if (null x) nil (sayBrightly1 x |$texOutputStream|))) + +(defun |sayNewLine| () (TERPRI)) + +(defvar |$sayBrightlyStream| nil "if not nil, gives stream for sayBrightly output") + +(defun |sayBrightly| (x &optional (out-stream *standard-output*)) + (COND ((NULL X) NIL) + (|$sayBrightlyStream| (sayBrightly1 X |$sayBrightlyStream|)) + ((IS-CONSOLE out-stream) (sayBrightly1 X out-stream)) + ((sayBrightly1 X out-stream) (sayBrightly1 X *terminal-io*)))) + +(defun |sayBrightlyI| (x &optional (s *terminal-io*)) + "Prints at console or output stream." + (if (NULL X) NIL (sayBrightly1 X S))) + +(defun |sayBrightlyNT| (x &optional (S *standard-output*)) + (COND ((NULL X) NIL) + (|$sayBrightlyStream| (sayBrightlyNT1 X |$sayBrightlyStream|)) + ((IS-CONSOLE S) (sayBrightlyNT1 X S)) + ((sayBrightly1 X S) (sayBrightlyNT1 X *terminal-io*)))) + +(defun sayBrightlyNT1 (X *standard-output*) + (if (ATOM X) (BRIGHTPRINT-0 X) (BRIGHTPRINT X))) + +(defun |saySpadMsg| (X) + (if (NULL X) NIL (sayBrightly1 X |$algebraOutputStream|))) + +(defun |sayALGEBRA| (X) "Prints on Algebra output stream." + (if (NULL X) NIL (sayBrightly1 X |$algebraOutputStream|))) + +(defun |sayMSGNT| (X) + (if (NULL X) NIL (sayBrightlyNT1 X |$algebraOutputStream|))) + +(defun |sayMSG2File| (msg) + (PROG (file str) + (SETQ file (|makePathname| '|spadmsg| '|listing| |$listingDirectory|)) + (SETQ str + (DEFIOSTREAM + (CONS '(MODE . OUTPUT) (CONS (CONS 'FILE file) NIL)) + 255 0)) + (sayBrightly1 msg str) + (SHUT str) ) ) + +(defvar |$fortranOutputStream|) + +(defun |sayFORTRAN| (x) "Prints on Fortran output stream." + (if (NULL X) NIL (sayBrightly1 X |$fortranOutputStream|))) + +(defvar |$formulaOutputStream|) + +(defun |sayFORMULA| (X) "Prints on formula output stream." + (if (NULL X) NIL (sayBrightly1 X |$formulaOutputStream|))) + +(defvar |$highlightAllowed| nil "Used in BRIGHTPRINT and is a )set variable.") + +(defvar |$highlightFontOn| $boldstring "switch to highlight font") +(defvar |$highlightFontOff| $normalstring "return to normal font") + +;; the following are redefined in MSGDB BOOT + +(defun SAY (&rest x) (progn (MESSAGEPRINT X) (TERPRI))) + +(DEFUN BLANKS (N &optional (stream *standard-output*)) "Print N blanks." + (do ((i 1 (the fixnum(1+ i)))) + ((> i N))(declare (fixnum i n)) (princ " " stream))) + +; 23 FILE SYSTEM INTERFACE + +; 23.2 Opening and Closing Files + +(DEFUN DEFSTREAM (file MODE) + (if (member mode '(i input)) + (MAKE-INSTREAM file) + (MAKE-OUTSTREAM file))) + +; 23.3 Renaming, Deleting and Other File Operations + +(DEFUN NOTE (STRM) +"Attempts to return the current record number of a file stream. This is 0 for +terminals and empty or at-end files. In Common Lisp, we must assume record sizes of 1!" + (COND ((STREAM-EOF STRM) 0) + ((IS-CONSOLE STRM) 0) + ((file-position STRM)))) + +(DEFUN IS-CONSOLE-NOT-XEDIT (S) (not (OR (NULL (IS-CONSOLE S))))) + +(DEFUN POINTW (RECNO STRM) +"Does something obscure and VM-specific with respect to streams." + (let (V) + (if (STREAM-EOF STRM) (FAIL)) + (SETQ V (LASTATOM STRM)) + (SETELT V 4 RECNO) + (SETQ *EOF* (STREAM-EOF STRM)) + strm)) + +(DEFUN POINT (RECNO STRM) (file-position strm recno)) + +(DEFUN STRM (RECNO STRM) +"Does something obscure and VM-specific with respect to streams." + (let (V) + (if (STREAM-EOF STRM) (FAIL)) + (SETQ V (LASTATOM STRM)) + (SETELT V 4 RECNO) + (read-char STRM) + (SETQ *EOF* (STREAM-EOF STRM)) + strm)) + +; 24 ERRORS + +; 24.2 Specialized Error-Signalling Forms and Macros + +(defun MOAN (&rest x) (|sayBrightly| `(|%l| "===> " ,@X |%l|))) + +(DEFUN FAIL () (|systemError| '"Antique error (FAIL ENTERED)")) + +(defun CROAK (&rest x) (|systemError| x)) + +; 25 MISCELLANEOUS FEATURES + +;; range tests and assertions + +(defmacro |assert| (x y) `(IF (NULL ,x) (|error| ,y))) + +(defun coerce-failure-msg (val mode) + (STRCONC (MAKE-REASONABLE (STRINGIMAGE val)) + " cannot be coerced to mode " + (STRINGIMAGE (|devaluate| mode)))) + +(defmacro |check-subtype| (pred submode val) + `(|assert| ,pred (coerce-failure-msg ,val ,submode))) + +(defmacro |check-union| (pred branch val) + `(|assert| ,pred (coerce-failure-msg ,val ,branch ))) + +(defun MAKE-REASONABLE (Z) + (if (> (length Z) 30) (CONCAT "expression beginning " (subseq Z 0 20)) Z)) + + +(defmacro |elapsedUserTime| () '(get-internal-run-time)) + +#+IBCL +(defmacro |elapsedGcTime| () '(system:gbc-time-report)) +#+AKCL +(defmacro |elapsedGcTime| () '(system:gbc-time)) +#+:CCL +(defmacro |elapsedGcTime| () '(lisp:gctime)) +#-(OR :CCL IBCL AKCL) +(defmacro |elapsedGcTime| () '0) + +(defmacro |do| (&rest args) (CONS 'PROGN args)) + +(defmacro |char| (arg) + (cond ((stringp arg) (character arg)) + ((integerp arg) (code-char arg)) + ((and (consp arg) (eq (car arg) 'quote)) (character (cadr arg))) + (t `(character ,arg)))) + +(defun DROPTRAILINGBLANKS (LINE) (string-right-trim " " LINE)) + +; # Gives the number of elements of a list, 0 for atoms. +; If we quote it, then an interpreter trip is necessary every time +; we call #, and this costs us - 4% in the RATINT DEMO." + +(define-function '\# #'SIZE) + +(defun print-and-eval-defun (name body) + (eval body) + (print-defun name body) + ;; (set name (symbol-function name)) ;; this should go away + ) + +(defun eval-defun (name body) (eval (macroexpandall body))) + +; This function was modified by Greg Vanuxem on March 31, 2005 +; to handle the special case of #'(lambda ..... which expands +; into (function (lambda ..... +; +; The extra if clause fixes bugs #196 and #114 +; +; an example that used to cause the failure was: +; )set func comp off +; f(xl:LIST FRAC INT): LIST FRAC INT == map(x +-> x, xl) +; f [1,2,3] +; +; which expanded into +; +; (defun |xl;f;1;initial| (|#1| |envArg|) +; (prog (#:G1420) +; (return +; (progn +; (lett #:G1420 'uninitialized_variable |f| |#1;f;1:initial|) +; (spadcall +; (cons (|function| (lambda (#:G1420 |envArg|) #:G1420)) (vector)) +; |#1| +; (qrefelt |*1;f;1;initial;MV| 0)))))) +; +; the (|function| (lambda form used to cause an infinite expansion loop +; +(defun macroexpandall (sexpr) + (cond + ((atom sexpr) sexpr) + ((eq (car sexpr) 'quote) sexpr) + ((eq (car sexpr) 'defun) + (cons (car sexpr) (cons (cadr sexpr) + (mapcar #'macroexpandall (cddr sexpr))))) + ((and (symbolp (car sexpr)) (macro-function (car sexpr))) + (do () + ((not (and (consp sexpr) (symbolp (car sexpr)) + (macro-function (car sexpr))))) + (setq sexpr (macroexpand sexpr))) + (if (consp sexpr) + (let ((a (car sexpr)) (b (caadr sexpr))) + (if (and (eq a 'function) (eq b 'lambda)) + (cons a (list (cons b (mapcar #'macroexpandall (cdadr sexpr))))) + (mapcar #'macroexpandall sexpr))) + sexpr)) + ('else + (mapcar #'macroexpandall sexpr)))) + + +(defun compile-defun (name body) (eval body) (compile name)) + +(defmacro |Record| (&rest x) + `(|Record0| (LIST ,@(COLLECT (IN Y X) + (list 'CONS (MKQ (CADR Y)) (CADDR Y)))))) + +(defmacro |:| (tag expr) `(LIST '|:| ,(MKQ tag) ,expr)) + +(defun |deleteWOC| (item list) (lisp::delete item list :test #'equal)) + +(DEFUN |leftBindingPowerOf| (X IND &AUX (Y (GETL X IND))) + (IF Y (ELEMN Y 3 0) 0)) + +(DEFUN |rightBindingPowerOf| (X IND &AUX (Y (GETL X IND))) + (IF Y (ELEMN Y 4 105) 105)) + +(defmacro make-bf (MT EP) `(CONS |$BFtag| (CONS ,MT ,EP))) + +(defun MAKE-FLOAT (int frac fraclen exp) + (if (AND $SPAD |$useBFasDefault|) + (if (= frac 0) + (MAKE-BF int exp) + (MAKE-BF (+ (* int (expt 10 fraclen)) frac) (- exp fraclen)) ) + (read-from-string + (format nil "~D.~v,'0De~D" int fraclen frac exp))) ) + +;;---- Added by WFS. + +(proclaim '(ftype (function (t t) t) |subWord|)) ;hack for bug in akcl-478 + +(DEFUN |subWord| (|str| N ) + (declare (fixnum n ) (string |str|)) + (PROG (|word| (|n| 0) |inWord|(|l| 0) ) + (declare (fixnum |n| |l|)) + (RETURN + (SEQ (COND + ((> 1 N) NIL) + ('T (SPADLET |l| (SPADDIFFERENCE (|#| |str|) 1)) + (COND + ((EQL |l| 0) NIL) + ('T (SPADLET |n| 0) (SPADLET |word| '||) + (SPADLET |inWord| NIL) + (DO ((|i| 0 (QSADD1 |i|))) ((QSGREATERP |i| |l|) NIL) + (declare (fixnum |i|)) + (SEQ (EXIT (COND + ((eql (aref |str| |i|) #\space) + (COND + ((NULL |inWord|) NIL) + ((eql |n| N) (RETURN |word|)) + ('T (SPADLET |inWord| NIL)))) + ('T + (COND + ((NULL |inWord|) + (SPADLET |inWord| 'T) + (SPADLET |n| (PLUS |n| 1)))) + (COND + ((eql |n| N) + (cond ((eq |word| '||) + (setq |word| + (make-array 10 :adjustable t + :element-type 'standard-char + :fill-pointer 0)))) + (or |word| (error "bad")) + (vector-push-extend (aref |str| |i|) + (the string |word|) + ) + ) + ('T NIL))))))) + (COND ((> N |n|) NIL) ('T |word|)))))))))) + +(defun print-full (expr &optional (stream *standard-output*)) + (let ((*print-circle* t) (*print-array* t) *print-level* *print-length*) + (print expr stream) + (terpri stream) + (finish-output stream))) + +;; moved here from preparse.lisp + +(defun NEXT-TAB-LOC (i) (* (1+ (truncate i 8)) 8)) + +(defun INDENT-POS (STR) + (do ((i 0 (1+ i)) + (pos 0)) + ((>= i (length str)) nil) + (case (char str i) + (#\space (incf pos)) + (#\tab (setq pos (next-tab-loc pos))) + (otherwise (return pos))))) + +;;(defun expand-tabs (str) +;; (let ((bpos (nonblankloc str)) +;; (tpos (indent-pos str))) +;; (if (eql bpos tpos) str +;; (concatenate 'string (make-string tpos :initial-element #\space) +;; (subseq str bpos))))) +(defun expand-tabs (str) + (if (and (stringp str) (> (length str) 0)) + (let ((bpos (nonblankloc str)) + (tpos (indent-pos str))) + (setq str + (if (eql bpos tpos) + str + (concatenate 'string + (make-string tpos :initial-element #\space) + (subseq str bpos)))) + ;; remove dos CR + (let ((lpos (maxindex str))) + (if (eq (char str lpos) #\Return) (subseq str 0 lpos) str))) + str)) + +(defun blankp (char) (or (eq char #\Space) (eq char #\tab))) + +(defun nonblankloc (str) (position-if-not #'blankp str)) + +;; stream handling for paste-in generation + +(defun |applyWithOutputToString| (func args) + ;; returns the cons of applying func to args and a string produced + ;; from standard-output while executing. + (let* ((*standard-output* (make-string-output-stream)) + (curoutstream *standard-output*) + (*terminal-io* *standard-output*) + (|$algebraOutputStream| *standard-output*) + (erroroutstream *standard-output*) + val) + (declare (special *standard-output* curoutstream + *terminal-io* |$algebraOutputStream|)) + (setq val (catch 'spad_reader + (catch 'TOP_LEVEL + (apply (symbol-function func) args)))) + (cons val (get-output-stream-string *standard-output*)))) + +(defun |breakIntoLines| (str) + (let ((bol 0) (eol) (line-list nil)) + (loop + (setq eol (position #\Newline str :start bol)) + (if (null eol) (return)) + (if (> eol bol) + (setq line-list (cons (subseq str bol eol) line-list))) + (setq bol (+ eol 1))) + (nreverse line-list))) + +; part of the old spad to new spad translator +; these are here because they need to be in depsys +; they were in nspadaux.lisp + +(defmacro wi (a b) b) + +(defmacro |try| (X) + `(LET ((|$autoLine|)) + (declare (special |$autoLine|)) + (|tryToFit| (|saveState|) ,X))) + +(defmacro |embrace| (X) `(|wrapBraces| (|saveC|) ,X (|restoreC|))) +(defmacro |indentNB| (X) `(|wrapBraces| (|saveD|) ,X (|restoreD|))) + +(defmacro |tryBreak| (a b c d) +; Try to format by: +; (1) with no line breaking ($autoLine = nil) +; (2) with possible line breaks within a; +; (3) otherwise use a brace + `(LET + ((state)) + (setq state (|saveState| 't)) + (or + (LET ((|$autoLine|)) + (declare (special |$autoLine|)) + (and ,a (|formatRight| '|formatPreferPile| ,b ,c ,d))) + (|restoreState| state) + (and (eqcar ,b (quote seq)) + (|embrace| (and + ,a + (|formatLB|) + (|formatRight| '|formatPreferPile| ,b ,c ,d)))) + (|restoreState| state) + (|embrace| (and ,a + (|formatLB|) + (|formatRight| '|formatPreferPile| ,b ,c ,d)))))) + +(defmacro |tryBreakNB| (a b c d) +; Try to format by: +; (1) with no line breaking ($autoLine = nil) +; (2) with possible line breaks within a; +; (3) otherwise display without a brace + `(LET + ((state)) + (setq state (|saveState| 't)) + (or + (markhash ,b 0) + (LET ((|$autoLine|)) + (declare (special |$autoLine|)) + (and ,a (|formatRight| '|formatPreferPile| ,b ,c ,d))) + (|restoreState| state) + (markhash ,b 1) + (and (eqcar ,b (quote seq)) + (|embrace| (and + ,a + (|formatLB|) + (|formatRight| '|formatPreferPile| ,b ,c ,d)))) + (markhash ,b 2) + (|restoreState| state) + (|indentNB| (and ,a + (|formatRight| '|formatPreferPile| ,b ,c ,d))) + (markhash ,b 3) + +))) + +(defun markhash (key n) (progn (cond + ((equal n 3) (remhash key ht)) + ('t (hput ht key n)) ) nil)) + + @ \eject \begin{thebibliography}{99}