diff --git a/changelog b/changelog index 3540daf..8be8e99 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,8 @@ +20090808 tpd src/axiom-website/patches.html 20090808.02.tpd.patch +20090808 tpd src/interp/Makefile remove spad.lisp +20090808 tpd src/interp/debugsys.lisp remove spad reference +20090808 tpd src/interp/vmlisp.lisp merge spad.lisp +20090808 tpd src/interp/spad.lisp removed, merged with vmlisp.lisp 20090808 tpd src/axiom-website/patches.html 20090808.01.tpd.patch 20090808 tpd src/interp/Makefile remove debug.lisp 20090808 tpd src/interp/debugsys.lisp remove debug reference diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 2cc3d29..ce6b71a 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -1756,6 +1756,8 @@ vmlisp.lisp and comp.lisp merged
vmlisp.lisp and spaderror.lisp merged
20090808.01.tpd.patch vmlisp.lisp and debug.lisp merged
+20090808.02.tpd.patch +vmlisp.lisp and spad.lisp merged
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index 4c96fc5..ef5cfd5 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}/spad.lisp ${MID}/bits.lisp \ + ${MID}/bits.lisp \ ${MID}/setq.lisp ${MID}/property.lisp \ ${MID}/unlisp.lisp ${MID}/foam_l.lisp \ ${MID}/axext_l.lisp @@ -219,7 +219,7 @@ OBJS= ${OUT}/vmlisp.${O} \ ${OUT}/server.${O} \ ${OUT}/sfsfun-l.${O} ${OUT}/sfsfun.${O} \ ${OUT}/simpbool.${O} ${OUT}/slam.${O} \ - ${OUT}/sockio.${O} ${OUT}/spad.${O} \ + ${OUT}/sockio.${O} \ ${OUT}/template.${O} ${OUT}/termrw.${O} \ ${OUT}/daase.${O} \ ${OUT}/fortcall.${O} \ @@ -491,7 +491,6 @@ DOCFILES=${DOC}/alql.boot.dvi \ ${DOC}/sfsfun-l.lisp.dvi \ ${DOC}/simpbool.boot.dvi \ ${DOC}/slam.boot.dvi ${DOC}/sockio.lisp.dvi \ - ${DOC}/spad.lisp.dvi \ ${DOC}/sys-pkg.lisp.dvi ${DOC}/template.boot.dvi \ ${DOC}/termrw.boot.dvi ${DOC}/topics.boot.dvi \ ${DOC}/unlisp.lisp.dvi \ @@ -1599,40 +1598,6 @@ ${DOC}/sockio.lisp.dvi: ${IN}/sockio.lisp.pamphlet @ -\subsection{spad.lisp \cite{34}} -<>= -${OUT}/spad.${O}: ${MID}/spad.lisp - @ echo 120 making ${OUT}/spad.${O} from ${MID}/spad.lisp - @ ( cd ${MID} ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/spad.lisp"' \ - ':output-file "${OUT}/spad.${O}") (${BYE}))' | ${DEPSYS} ; \ - else \ - echo '(progn (compile-file "${MID}/spad.lisp"' \ - ':output-file "${OUT}/spad.${O}") (${BYE}))' | ${DEPSYS} \ - >${TMP}/trace ; \ - fi ) - -@ -<>= -${MID}/spad.lisp: ${IN}/spad.lisp.pamphlet - @ echo 121 making ${MID}/spad.lisp from ${IN}/spad.lisp.pamphlet - @ (cd ${MID} ; \ - ${TANGLE} ${IN}/spad.lisp.pamphlet >spad.lisp ) - -@ -<>= -${DOC}/spad.lisp.dvi: ${IN}/spad.lisp.pamphlet - @echo 122 making ${DOC}/spad.lisp.dvi from ${IN}/spad.lisp.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/spad.lisp.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} spad.lisp ; \ - rm -f ${DOC}/spad.lisp.pamphlet ; \ - rm -f ${DOC}/spad.lisp.tex ; \ - rm -f ${DOC}/spad.lisp ) - -@ - \subsection{sys-pkg.lisp \cite{36}} <>= ${OUT}/sys-pkg.${LISP}: ${MID}/sys-pkg.lisp @@ -7635,10 +7600,6 @@ clean: <> <> -<> -<> -<> - <> <> <> @@ -7708,7 +7669,6 @@ pp \bibitem{30} {\bf \$SPAD/src/interp/postprop.lisp.pamphlet} \bibitem{32} {\bf \$SPAD/src/interp/property.lisp.pamphlet} \bibitem{33} {\bf \$SPAD/src/interp/sockio.lisp.pamphlet} -\bibitem{34} {\bf \$SPAD/src/interp/spad.lisp.pamphlet} \bibitem{36} {\bf \$SPAD/src/interp/sys-pkg.lisp.pamphlet} \bibitem{38} {\bf \$SPAD/src/interp/util.lisp.pamphlet} \bibitem{39} {\bf \$SPAD/src/interp/vmlisp.lisp.pamphlet} diff --git a/src/interp/debugsys.lisp.pamphlet b/src/interp/debugsys.lisp.pamphlet index a66f060..66d5daf 100644 --- a/src/interp/debugsys.lisp.pamphlet +++ b/src/interp/debugsys.lisp.pamphlet @@ -161,7 +161,6 @@ loaded by hand we need to establish a value. (thesymb "/int/interp/simpbool.clisp") (thesymb "/int/interp/slam.clisp") (thesymb (concatenate 'string "/obj/" *sys* "/interp/sockio.o")) - (thesymb "/int/interp/spad.lisp") (thesymb "/int/interp/template.clisp") (thesymb "/int/interp/termrw.clisp") (thesymb "/int/interp/daase.lisp") diff --git a/src/interp/spad.lisp.pamphlet b/src/interp/spad.lisp.pamphlet deleted file mode 100644 index 717a70a..0000000 --- a/src/interp/spad.lisp.pamphlet +++ /dev/null @@ -1,801 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp spad.lisp} -\author{Timothy Daly} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{License} -<>= -;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are -;; met: -;; -;; - Redistributions of source code must retain the above copyright -;; notice, this list of conditions and the following disclaimer. -;; -;; - Redistributions in binary form must reproduce the above copyright -;; notice, this list of conditions and the following disclaimer in -;; the documentation and/or other materials provided with the -;; distribution. -;; -;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the -;; names of its contributors may be used to endorse or promote products -;; derived from this software without specific prior written permission. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS -;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A -;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER -;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - -; NAME: Scratchpad Package -; PURPOSE: This is an initialization and system-building file for Scratchpad. - -(in-package "BOOT") - -;;; Common Block - -(defvar |$UserLevel| '|development|) -(defvar |$preserveSystemLisplib| t "if nil finalizeLisplib does MA REP") -(defvar |$incrementalLisplibFlag| nil "checked in compDefineLisplib") -(defvar |$reportInstantiations| nil) -(defvar |$reportEachInstantiation| nil) -(defvar |$reportCounts| nil) -(defvar |$CategoryDefaults| nil) -(defvar |$compForModeIfTrue| nil "checked in compSymbol") -(defvar |$functorForm| nil "checked in addModemap0") -(defvar |$formalArgList| nil "checked in compSymbol") -(defvar |$newComp| nil "use new compiler") -(defvar |$newCompCompare| nil "compare new compiler with old") -(defvar |$compileOnlyCertainItems| nil "list of functions to compile") -(defvar |$newCompAtTopLevel| nil "if t uses new compiler") -(defvar |$doNotCompileJustPrint| nil "switch for compile") -(defvar |$PrintCompilerMessageIfTrue| t) -(defvar |$Rep| '|$Rep| "should be bound to gensym? checked in coerce") -;; the following initialization of $ must not be a defvar -;; since that make $ special -(setq $ '$) ;; used in def of Ring which is Algebra($) -(defvar |$scanIfTrue| nil "if t continue compiling after errors") -(defvar |$Representation| nil "checked in compNoStacking") -(defvar |$definition| nil "checked in DomainSubstitutionFunction") -(defvar |$Attributes| nil "global attribute list used in JoinInner") -(defvar |$env| nil "checked in isDomainValuedVariable") -(defvar |$e| nil "checked in isDomainValuedVariable") -(defvar |$getPutTrace| nil) -(defvar |$specialCaseKeyList| nil "checked in optCall") -(defvar |$formulaFormat| nil "if true produce script formula output") -(defvar |$texFormat| nil "if true produce tex output") -(defvar |$fortranFormat| nil "if true produce fortran output") -(defvar |$algebraFormat| t "produce 2-d algebra output") -(defvar |$kernelWarn| NIL "") -(defvar |$kernelProtect| NIL "") -(defvar |$HiFiAccess| nil "if true maintain history file") -(defvar |$mapReturnTypes| nil) -(defvar /TRACENAMES NIL) - -(defvar INPUTSTREAM t "bogus initialization for now") - -(defvar |boot-NewKEY| NIL) -(setq /WSNAME 'NOBOOT) -(DEFVAR _ '&) -(setq $linestack 'begin_unit) -(setq $maxlinenumber 0) -(defvar /EDIT-FM 'A1) -(defvar /EDIT-FT 'SPAD) -(defvar /RELEASE '"UNKNOWN") -(defvar /rp '/RP) -(defvar APLMODE NIL) -(defvar error-print) -(defvar ind) -(defvar INITCOLUMN 0) -(defvar JUNKTOKLIST '(FOR IN AS INTO OF TO)) -(defvar LCTRUE '|true|) -(defvar m-chrbuffer) -(defvar m-chrindex) -(defvar MARG 0 "Margin for testing by ?OP") -(defvar NewFlag) -(defvar ParseMode) -(defvar RLGENSYMFG NIL) -(defvar RLGENSYMLST NIL) -(defvar S-SPADTOK 'SPADSYSTOK) -(defvar sortpred) -(defvar SPADSYSKEY '(EOI EOL)) -(defvar STAKCOLUMN -1) -(setq XTOKENREADER 'SPADTOK) -(defvar xtrans '|boot-new|) -(defvar |$IOAlist| '((|%i| . (|gauss| 0 1)))) -(setq |$useBFasDefault| T) -(defvar |New-LEXPR|) -(defvar |NewFLAG| t) -(defvar |uc| 'UC) -(setq |$lisp2lispRenameAssoc| '((RETURN . |return|) - (EXIT . |exit|) - (AND . |and|) - (OR . |or|) - (NOT . |not|) - (IS . |is|) - (CAR . |first|) - (CDR . |rest|) - (EQUAL . =) - (NEQUAL . ^=) - (PLUS . +) - (TIMES . *) - (QUOTIENT . /) - (EXPT . **) - (SUBST . |substitute|) - (NULL . ^) - (ATOM . |atom|) - (NULL . |null|) - )) - -(setq |$spadOpList| - '(\.\. - = * / ** + - \< \> \<= \>= ^= \# \' ^ - \: \:\: \. =\> == ==\> \| \:=)) - -(DEFUN INTEGER-BIT (N I) (LOGBITP I N)) - -(DEFUN /TRANSPAD (X) - (PROG (proplist) - (setq proplist (LIST '(FLUID . |true|) - (CONS '|special| - (COPY-TREE |$InitialDomainsInScope|)))) - (SETQ |$tripleCache| NIL) - (SETQ |$InteractiveFrame| - (|addBinding| '|$DomainsInScope| proplist - (|addBinding| '|$Information| NIL - (COPY-TREE |$InitialModemapFrame|)))) - (RETURN (PROGN (S-PROCESS X) NIL)))) - -(DEFUN /TRANSBOOT (X) (S-PROCESS X) NIL) - -(DEFUN /TRANSNBOOT (X) (S-PROCESS X) NIL) - - ;; NIL needed below since END\_UNIT is not generated by current parser -(defun |isTokenDelimiter| () (MEMBER (CURRENT-SYMBOL) '(\) END\_UNIT NIL))) - -(defun |traceComp| () - (SETQ |$compCount| 0) - (EMBED '|comp| - '(LAMBDA (X Y Z) - (PROG (U) - (SETQ |$compCount| (1+ |$compCount|)) - (SETQ |yesOrNo| (if (SETQ U (|comp| X Y Z)) - (if (EQUAL (SECOND U) Y) '|yes| (SECOND U)) - ('T '|no|))) - (|sayBrightly| (CONS (MAKE-FULL-CVEC |$compCount| " ") - (LIST X " --> " Y '|%b| |yesOrNo| '|%d|))) - (SETQ |$compCount| (1- |$compCount|)) - (RETURN U) ))) - (|comp| $x $m $f) - (UNEMBED '|comp|)) - -(defun READ-SPAD (FN FM TO) - (LET ((proplist - (LIST '(FLUID . |true|) - (CONS '|special| (COPY-TREE |$InitialDomainsInScope|))))) - (SETQ |$InteractiveFrame| - (|addBinding| '|$DomainsInScope| proplist - (|addBinding| '|$Information| NIL - (|makeInitialModemapFrame|)))) - (READ-SPAD0 FN 'SPAD FM TO))) - -(defun READ-INPUT (FN FM TO) (READ-SPAD0 FN 'INPUT FM TO)) - -(defun READ-SPAD0 (FN FT FM TO) - (let (($newspad t)) (READ-SPAD1 FN FT FM TO))) - -(defun READ-SPAD-1 () (|New,ENTRY,1|)) - -(defun BOOT-LEXPR () (SETQ $BOOT 'T) (SPAD-LEXPR1)) - -(defun NBOOT-LEXPR () (SETQ $NBOOT 'T) (SPAD-LEXPR1)) - -(defun UNCONS (X) - (COND ((ATOM X) X) - ((EQCAR X 'CONS) (CONS (SECOND X) (UNCONS (THIRD X)))) - (T (ERROR "UNCONS")))) - -(defun OPTIMIZE\&PRINT (X) (PRETTYPRINT (/MDEF X))) - -(defun SPAD-PRINTTIME (A B) - (let (c msg) - (setq C (+ A B)) - (setq MSG (STRCONC "(" (STRINGIMAGE A) " + " (STRINGIMAGE B) - " = " (STRINGIMAGE C) " MS.)")) - (PRINT (STRCONC (STRINGPAD "" (DIFFERENCE 80 (SIZE MSG))) MSG)))) - -(defun SPAD-MODETRAN (X) (D-TRAN X)) - -(defun SPAD-MDTR-1 (X) - (COND - ((ATOM X) (LIST (LIST X))) - ((EQCAR X 'LIST) (SPAD-MDTR-2 (CDR X))) - (T (CROAK "MODE TRANSFORM ERROR")))) - -(defun SPAD-MDTR-2 (L) - (COND - ((NOT L) L) - ((ATOM (FIRST L)) - (COND - ((MEMBER (FIRST L) $DOMVAR) (FIRST L)) - (T (CONS (LIST (LIST (FIRST L))) (SPAD-MDTR-2 (CDR L)))) )) - (T (CONS (FIRST L) (SPAD-MDTR-2 (CDR L)))))) - -(defun SPAD-EVAL (X) - (COND ((ATOM X) (EVAL X)) - ((CONS (FIRST X) (MAPCAR #'SPAD-EVAL (CDR X)))))) - -;************************************************************************ -; SYSTEM COMMANDS -;************************************************************************ - -(defun CLEARDATABASE () (OBEY "ERASE MODEMAP DATABASE")) - -(defun erase (FN FT) - (OBEY (STRCONC "ERASE " (STRINGIMAGE FN) " " (STRINGIMAGE FT)))) - -(defun READLISP (UPPER_CASE_FG) - (let (v expr val ) - (setq EXPR (READ-FROM-STRING - (IF UPPER_CASE_FG (string-upcase (line-buffer CURRENT-LINE)) - (line-buffer CURRENT-LINE)) - t nil :start (Line-CURRENT-INDEX CURRENT-LINE))) - (VMPRINT EXPR) - (setq VAL ((LAMBDA (|$InteractiveMode|) (EVAL EXPR)) NIL)) - (FORMAT t "~&VALUE = ~S" VAL) - (TERSYSCOMMAND))) - -(defun TERSYSCOMMAND () - (FRESH-LINE) - (SETQ CHR 'ENDOFLINECHR) - (SETQ TOK 'END_UNIT) - (|spadThrow|)) - -(defun /READ (L Q) -; (SETQ /EDIT-FN (OR (KAR L) /EDIT-FN)) -; (SETQ /EDIT-FT (OR (KAR (KDR L)) 'INPUT)) -; (SETQ /EDIT-FM (OR (KAR (KDR (KDR L))) '*)) -; (SETQ /EDITFILE (LIST /EDIT-FN /EDIT-FT /EDIT-FM)) - (SETQ /EDITFILE L) - (COND - (Q (/RQ)) - ('T (/RF)) ) - (FLAG |boot-NewKEY| 'KEY) - (|terminateSystemCommand|) - (|spadPrompt|)) - -(defun /EDIT (L) - (SETQ /EDITFILE L) - (/EF) - (|terminateSystemCommand|) - (|spadPrompt|)) - -(defun /COMPINTERP (L OPTS) - (SETQ /EDITFILE (/MKINFILENAM L)) - (COND ((EQUAL OPTS "rf") (/RF)) - ((EQUAL OPTS "rq") (/RQ)) - ('T (/RQ-LIB))) - (|terminateSystemCommand|) - (|spadPrompt|)) - -(defun CPSAY (X) (let (n) (if (EQ 0 (setq N (OBEY X))) NIL (PRINT N)))) - -(defun /FLAG (L) - (MAKEPROP (FIRST L) 'FLAGS (LET ((X (UNION (CDR L)))) (GET (FIRST L) 'FLAGS))) - (SAY (FIRST L) " has flags: " X) - (TERSYSCOMMAND)) - -(defun |fin| () - (SETQ *EOF* 'T) - (THROW 'SPAD_READER NIL)) - - -(defun STRINGREST (X) (if (EQ (SIZE X) 1) (make-string 0) (SUBSTRING X 1 NIL))) - -(defun STREAM2UC (STRM) - (LET ((X (ELT (LASTATOM STRM) 1))) (SETELT X 0 (LC2UC (ELT X 0))))) - -(defun NEWNAMTRANS (X) - (COND - ((IDENTP X) (COND ( (GET X 'NEWNAM) (GET X 'NEWNAM)) ('T X))) - ((STRINGP X) X) - ((*VECP X) (MAPVWOC X (FUNCTION NEWNAMTRANS))) - ((ATOM X) X) - ((EQCAR X 'QUOTE)) - (T (CONS (NEWNAMTRANS (FIRST X)) (NEWNAMTRANS (CDR X)))))) - -(defun GP2COND (L) - (COND ((NOT L) (ERROR "GP2COND")) - ((NOT (CDR L)) - (COND ((EQCAR (FIRST L) 'COLON) - (CONS (SECOND L) (LIST (LIST T 'FAIL)))) - (T (LIST (LIST T (FIRST L)))) )) - ((EQCAR (FIRST L) 'COLON) (CONS (CDAR L) (GP2COND (CDR L)))) - (T (ERROR "GP2COND")))) - -(FLAG JUNKTOKLIST 'KEY) - -(defmacro |report| (L) - (SUBST (SECOND L) 'x - '(COND ($reportFlag (sayBrightly x)) ((QUOTE T) NIL)))) - -(defmacro |DomainSubstitutionMacro| (&rest L) - (|DomainSubstitutionFunction| (first L) (second L))) - -(defun |sort| (seq spadfn) - (sort (copy-seq seq) (function (lambda (x y) (SPADCALL X Y SPADFN))))) - -#-Lucid -(defun QUOTIENT2 (X Y) (values (TRUNCATE X Y))) - -#+Lucid -(defun QUOTIENT2 (X Y) ; following to force error check in division by zero - (values (if (zerop y) (truncate 1 Y) (TRUNCATE X Y)))) - -#-Lucid -(define-function 'REMAINDER2 #'REM) - -#+Lucid -(defun REMAINDER2 (X Y) - (if (zerop y) (REM 1 Y) (REM X Y))) - -#-Lucid -(defun DIVIDE2 (X Y) (multiple-value-call #'cons (TRUNCATE X Y))) - -#+Lucid -(defun DIVIDE2 (X Y) - (if (zerop y) (truncate 1 Y) - (multiple-value-call #'cons (TRUNCATE X Y)))) - -(defmacro APPEND2 (x y) `(append ,x ,y)) - -(defmacro |float| (x &optional (y 0.0d0)) `(float ,x ,y)) - -(defun |makeSF| (mantissa exponent) - (|float| (/ mantissa (expt 2 (- exponent))))) - -(define-function 'list1 #'list) -(define-function '|not| #'NOT) - -(defun |random| () (random (expt 2 26))) -(defun \,plus (x y) (+ x y)) -(defun \,times (x y) (* x y)) -(defun \,difference (x y) (- x y)) -(defun \,max (x y) (max x y)) -(defun \,min (x y) (min x y)) -;; This is used in the domain Boolean (BOOLEAN.nrlib/code.lsp) -(defun |BooleanEquality| (x y) (if x y (null y))) - -(defun S-PROCESS (X) - (let ((|$Index| 0) - ($MACROASSOC ()) - ($NEWSPAD T) - (|$PolyMode| |$EmptyMode|) - (|$compUniquelyIfTrue| nil) - |$currentFunction| - (|$postStack| nil) - |$topOp| - (|$semanticErrorStack| ()) - (|$warningStack| ()) - (|$exitMode| |$EmptyMode|) - (|$exitModeStack| ()) - (|$returnMode| |$EmptyMode|) - (|$leaveMode| |$EmptyMode|) - (|$leaveLevelStack| ()) - $TOP_LEVEL |$insideFunctorIfTrue| |$insideExpressionIfTrue| - |$insideCoerceInteractiveHardIfTrue| |$insideWhereIfTrue| - |$insideCategoryIfTrue| |$insideCapsuleFunctionIfTrue| |$form| - (|$DomainFrame| '((NIL))) - (|$e| |$EmptyEnvironment|) - (|$genFVar| 0) - (|$genSDVar| 0) - (|$VariableCount| 0) - (|$previousTime| (TEMPUS-FUGIT)) - (|$LocalFrame| '((NIL)))) - (prog ((CURSTRM CUROUTSTREAM) |$s| |$x| |$m| u) - (declare (special CURSTRM |$s| |$x| |$m| CUROUTSTREAM)) - (SETQ $TRACEFLAG T) - (if (NOT X) (RETURN NIL)) - (setq X (if $BOOT (DEF-RENAME (|new2OldLisp| X)) - (|parseTransform| (|postTransform| X)))) - (if |$TranslateOnly| (RETURN (SETQ |$Translation| X))) - (when |$postStack| (|displayPreCompilationErrors|) (RETURN NIL)) - (COND (|$PrintOnly| - (format t "~S =====>~%" |$currentLine|) - (RETURN (PRETTYPRINT X)))) - (if (NOT $BOOT) - (if |$InteractiveMode| - (|processInteractive| X NIL) - (if (setq U (|compTopLevel| X |$EmptyMode| - |$InteractiveFrame|)) - (SETQ |$InteractiveFrame| (third U)))) - (DEF-PROCESS X)) - (if |$semanticErrorStack| (|displaySemanticErrors|)) - (TERPRI)))) - -(MAKEPROP 'END_UNIT 'KEY T) - -(defun |process| (x) - (COND ((NOT (EQ TOK 'END_UNIT)) - (SETQ DEBUGMODE 'NO) - (SPAD_SYNTAX_ERROR) - (if |$InteractiveMode| (|spadThrow|)) - (S-PROCESS x)))) - - -@ -The evalSharpOne function needs to declare the second argument -special to reduce warning messages about variables being assumed -special. -<<*>>= -(defun |evalSharpOne| (x |#1|) (declare (special |#1|)) - (EVAL `(let() (declare (special |#1|)) ,x))) - -(defun new () (|New,ENTRY|)) - -(defun newpo () (let ((|$PrintOnly| t)) (new))) - -(defun |New,ENTRY| () - (let ((|$InteractiveMode| t)(inputstream in-stream) ) - (declare (special inputstream)) - (spad))) - -(defun |New,ENTRY,SYS| () - (let (|$InteractiveMode|) - (|New,ENTRY1|))) - -(defun |New,ENTRY1| () - (let ((spaderrorstream curoutstream) $boot (curinstream curinstream) - (strm curinstream)) - (SETQ CURINSTREAM *terminal-io*) - (|New,ENTRY,1|) - (SETQ CURINSTREAM STRM) - 'END_OF_New)) - -(setq *PROMPT* 'LISP) - -(defun |New,ENTRY,1| () - (let (ZZ str N RLGENSYMFG RLGENSYMLST |NewFLAG| XCAPE *PROMPT* - SINGLELINEMODE OK ISID NBLNK COUNT CHR ULCASEFG ($LINESTACK 'BEGIN_UNIT) - $NEWLINSTACK $TOKSTACK COMMENTCHR TOK LINE BACK INPUTSTREAM XTRANS - XTOKENREADER STACK STACKX) - (SETQ XTRANS '|boot-New| - XTOKENREADER 'NewSYSTOK - SYNTAX_ERROR 'SPAD_SYNTAX_ERROR) - (FLAG |boot-NewKEY| 'KEY) - (SETQ *PROMPT* 'Scratchpad-II) - (PROMPT) - (SETQ XCAPE '_) - (SETQ COMMENTCHR 'IGNORE) - (SETQ COLUMN 0) - (SETQ SINGLINEMODE T) ; SEE NewSYSTOK - (SETQ NewFLAG T) - (SETQ ULCASEFG T) - (setq STR (|New,ENTRY,2| '|PARSE-NewEXPR| '|process| curinstream)) - (if (/= 0 (setq N (NOTE STR))) - (progn (SETQ CURINSTREAM (POINTW N CURINSTREAM))) - ) - '|END_OF_New|)) - -(defun |New,ENTRY,2| (RULE FN INPUTSTREAM) (declare (special INPUTSTREAM)) - (let (zz) - (INITIALIZE) - (SETQ $previousTime (TEMPUS-FUGIT)) - (setq ZZ (CONVERSATION '|PARSE-NewExpr| '|process|)) - (REMFLAG |boot-NewKEY| 'KEY) - INPUTSTREAM)) - -(defun INITIALIZE () (init-boot/spad-reader) (initialize-preparse INPUTSTREAM)) - -(defun New-LEXPR () (New-LEXPR1)) - -(defun New-LEXPR-Interactive () (setq |$InteractiveMode| t) (New-LEXPR1)) - -(setq *prompt* 'new) - -(defun New-LEXPR1 () - (FLAG |boot-NewKEY| 'KEY) - (SETLINE (SUB1 (file-position INPUTSTREAM)) INPUTSTREAM) - (SETQ CHR 'ENDOFLINECHR) - (NXTTOK) - (|boot-Statement|) - (CAR STACK)) - -(defun parserState () - (PRINT (LIST 'CHR= CHR 'NBLNK= NBLNK 'TOK= TOK 'ISID= ISID - 'COUNT= COUNT 'COLUMN= COLUMN)) - (PRINT (LIST 'STACK= STACK 'STACKX= STACKX)) - (PRINT (LIST '$TOKSTACK= $TOKSTACK 'INPUTSTREAM= INPUTSTREAM))) - -(defmacro try (X) - `(LET ((|$autoLine|)) - (declare (special |$autoLine|)) - (|tryToFit| (|saveState|) ,X))) - -(mapcar #'(lambda (X) (MAKEPROP (CAR X) 'format (CADR X))) - '((COMMENT |formatCOMMENT|) - (SEQ |formatSEQ|) - (DEF |formatDEF|) - (LET |formatLET|) - (\: |formatColon|) - (ELT |formatELT|) - (SEGMENT |formatSEGMENT|) - (COND |formatCOND|) - (SCOND |formatSCOND|) - (QUOTE |formatQUOTE|) - (CONS |formatCONS|) - (|where| |formatWHERE|) - (APPEND |formatAPPEND|) - (REPEAT |formatREPEAT|) - (COLLECT |formatCOLLECT|) - (REDUCE |formatREDUCE|))) - -(defun |boot2Lisp| (LINESET) - (let* (($TOP_STACK T) (*PROMPT* 'New) ($MAXLINENUMBER 0) - (NewFLAG T) (XTRANS '|boot-New|) (XCAPE '!) - (COMMENTCHR 'NOTHING) (XTOKENREADER 'NewSYSTOK) - ($NBOOT T) (ERRCOL 0) (COUNT 0) (COLUMN 0) - (OK T) (SPADERRORSTREAM CUROUTSTREAM) - ($LINESTACK 'BEGIN_UNIT) - (INPUTSTREAM LINESET) - (CHR 'ENDOFLINECHR)) - (REMFLAG S-SPADKEY 'KEY) - (FLAG |boot-NewKEY| 'KEY) - (NXTTOK) ; causes PREPARSE to be called - (|boot-Statement|) - (REMFLAG |boot-NewKEY| 'KEY) - (FLAG S-SPADKEY 'KEY) - (if (NULL OK) (|boot2LispError|)) - (|new2OldLisp| (CAR STACK)))) - -(defun /cx (L) - "CAUTION: will not work if function in L has DEFLOC with ft=NBOOT" - (if (not L) (SETQ L |$LastCxArg|)) - (SETQ |$LastCxArg| L) - (/D-1 L '|lisp2BootAndCompare| NIL NIL)) - -(defun /foobar (L) - (let (($xCount 0)) - (if (not L) (SETQ L $LastCxArg)) - (SETQ $LastCxArg L) - (/D-1 L 'foobar NIL NIL))) - -(defun foobar (X) |$xCount|) - -(defun |/cxd| (L) - (if (NULL L) (SETQ L $|LastCxArg|)) - (SETQ |$LastCxArg| L) - (/D-1 L '|lispOfBoot2NBootAndCompare| NIL NIL)) - -(defun |/rx| (L) - (let ((DEF-RENAME 'IDENTITY) - (DEF-PROCESS '|lispOfBoot2NBootAndCompare|) ) - (declare (SPECIAL DEF-RENAME DEF-PROCESS)) - (if (OR (NULL L) (NULL (ATOM (CAR L)))) - (EVAL (APPEND (CONS '/RF /EDITFILE) L)) - (CATCH 'FILENAM (/RF-1 L))))) - -(defun |/ry| (L) - (let ((DEF-RENAME 'IDENTITY) - (DEF-PROCESS '|pp|) ) - (declare (SPECIAL DEF-RENAME DEF-PROCESS)) - (if (OR (NULL L) (NULL (ATOM (CAR L)))) - (EVAL (APPEND (CONS '/RF /EDITFILE) L)) - (CATCH 'FILENAM (/RF-1 L))))) - -(defun |/tb| (L) - (let ((DEF-RENAME 'IDENTITY) (DEF-PROCESS 'lispOfBoot2NBAC1)) - (declare (special DEF-RENAME DEF-PROCESS)) - (if (NULL L) - (EVAL (CONS '/RQ /EDITFILE)) - (CATCH 'FILENAM - (PROG (OUTFILE ($PRETTYPRINT T)) - (SETQ /EDITFILE (LIST (CAR L) 'BOOT '*)) - (OBEY (STRCONC "ERASE " (PNAME (CAR /EDITFILE)) " NBOOT E1")) - (SETQ OUTFILE (LIST (CAR /EDITFILE) 'NBOOT 'E1)) - (RETURN (/RF-1 (APPEND /EDITFILE - (LIST (CONS 'TO= OUTFILE)))))))))) - -(defun |boot2LispError| () - "Print syntax error indication, underline character, scrub line." - (COND ((OR (EQ DEBUGMODE 'YES) (NULL (CONSOLEINPUTP INPUTSTREAM))) - (SPAD_LONG_ERROR)) - (T (SPAD_SHORT_ERROR))) - (SETQ OK T)) - -(defun |getTranslation| (|function| |fn| |ft| |rdr|) - (let ((|New-LEXPR| |rdr|) (|$TranslateOnly| T)) - (declare (special |New-LEXPR| |$TranslateOnly|)) - (/D-1 (LIST |function| (LIST 'FROM= |fn| |ft|)) 'IDENTITY NIL NIL) - |$Translation|)) - -(defmacro |incTimeSum| (a b) - (if (not |$InteractiveTimingStatsIfTrue|) a - (let ((key b) (oldkey (gensym)) (val (gensym))) - `(prog (,oldkey ,val) - (setq ,oldkey (|incrementTimeSum| ,key)) - (setq ,val ,a) - (|incrementTimeSum| ,oldkey) - (return ,val))))) - -(defun GLESSEQP (X Y) (NOT (GGREATERP X Y))) - -(defun LEXLESSEQP (X Y) (NOT (LEXGREATERP X Y))) - -(defun SETELTFIRST (A B C) (declare (ignore b)) (RPLACA A C)) - -(defun SETELTREST (A B C) (declare (ignore b)) (RPLACD A C)) - -(defmacro |rplac| (&rest L) - (let (a b s) - (cond - ((EQCAR (SETQ A (CAR L)) 'ELT) - (COND ((AND (INTEGERP (SETQ B (CADDR A))) (>= B 0)) - (SETQ S "CA") - (do ((i 1 (1+ i))) ((> i b)) (SETQ S (STRCONC S "D"))) - (LIST 'RPLAC (LIST (INTERN (STRCONC S "R")) (CADR A)) (CADR L))) - ((ERROR "rplac")))) - ((PROGN - (SETQ A (CARCDREXPAND (CAR L) NIL)) - (SETQ 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)))))))) - -(DEFUN ASSOCIATER (FN LST) - (COND ((NULL LST) NIL) - ((NULL (CDR LST)) (CAR LST)) - ((LIST FN (CAR LST) (ASSOCIATER FN (CDR LST)))))) - -(defun ISLOCALOP-1 (IND) - "Curindex points at character after '.'" - (prog (selector buf termtok (NEWCHR (NEXTCHARACTER))) - (if (TERMINATOR NEWCHR) (RETURN NIL)) - (setq SELECTOR - (do ((x nil)) - (nil) - (if (terminator newchr) - (reverse x) - (push (setq newchr (nextcharacter)) x)))) - (if (EQUAL NEWCHR '\.) (RETURN (ISLOCALOP-1 IND))) - (setq BUF (GETSTR (LENGTH SELECTOR))) - (mapc #'(lambda (x) (suffix x buf)) selector) - (setq buf (copy-seq selector)) - (setq TERMTOK (INTERN BUF)) - (if (NOT (GET TERMTOK 'GENERIC)) (RETURN NIL)) - (if (OR (GET TERMTOK '|Led|) (GET TERMTOK '|Nud|)) - (GET TERMTOK IND)) - (return TERMTOK))) -; **** X. Random tables - -(defvar MATBORCH "*") -(defvar $MARGIN 3) -(defvar $LINELENGTH 71) -(defvar TEMPGENSYMLIST '(|s| |r| |q| |p|)) -(defvar ALPHLIST '(|a| |b| |c| |d| |e| |f| |g|)) -(defvar LITTLEIN " in ") -(defvar INITALPHLIST ALPHLIST) -(defvar INITXPARLST '(|i| |j| |k| |l| |m| |n| |p| |q|)) -(defvar PORDLST (COPY-tree INITXPARLST)) -(defvar INITPARLST '(|x| |y| |z| |u| |v| |w| |r| |s| |t|)) -(defvar LITTLEA '|a|) -(defvar LITTLEI '|i|) -(defvar *TALLPAR NIL) -(defvar ALLSTAR NIL) -(defvar BLANK " ") -(defvar PLUSS "+") -(defvar PERIOD ".") -(defvar SLASH "/") -(defvar COMMA ",") -(defvar LPAR "(") -(defvar RPAR ")") -(defvar EQSIGN "=") -(defvar DASH "-") -(defvar STAR "*") -(defvar DOLLAR "$") -(defvar COLON ":") - -; (SETQ |boot-NewKEY| (S- |boot-NewKEY| '(|cp| |cms| |lisp| |boot|))) - -(FLAG TEMPGENSYMLIST 'IS-GENSYM) - -(MAKEPROP 'COND '|Nud| '(|if| |if| 130 0)) -(MAKEPROP 'CONS '|Led| '(CONS CONS 1000 1000)) -(MAKEPROP 'APPEND '|Led| '(APPEND APPEND 1000 1000)) -(MAKEPROP 'TAG '|Led| '(TAG TAG 122 121)) -(MAKEPROP 'EQUATNUM '|Nud| '(|dummy| |dummy| 0 0)) -(MAKEPROP 'EQUATNUM '|Led| '(|dummy| |dummy| 10000 0)) -(MAKEPROP 'LET '|Led| '(:= LET 125 124)) -(MAKEPROP 'RARROW '|Led| '(== DEF 122 121)) -(MAKEPROP 'SEGMENT '|Led| '(\.\. SEGMENT 401 699 (|boot-Seg|))) - -;; NAME: DECIMAL-LENGTH -;; PURPOSE: Computes number of decimal digits in print representation of x -;; This should made as efficient as possible. - -(DEFUN DECIMAL-LENGTH (X) - (LET* ((K (FIX (* #.(LOG 2.0 10.) (INTEGER-LENGTH X)))) - (X (TRUNCATE (ABS X) (EXPT 10 (1- K))))) - (IF (LESSP X 10) K (1+ K)))) - -;(DEFUN DECIMAL-LENGTH2 (X) -; (LET ((K (FIX (* #.(LOG 2.0 10.) (INTEGER-LENGTH X))))) -; (IF (< (ABS X) (EXPT 10 K)) K (1+ K)))) - - -;; function to create byte and half-word vectors in new runtime system 8/90 - -#-:CCL -(defun |makeByteWordVec| (initialvalue) - (let ((n (cond ((null initialvalue) 7) ('t (reduce #'max initialvalue))))) - (make-array (length initialvalue) - :element-type (list 'mod (1+ n)) - :initial-contents initialvalue))) - -#+:CCL -(defun |makeByteWordVec| (initialvalue) - (list-to-vector initialvalue)) - -#-:CCL -(defun |makeByteWordVec2| (maxelement initialvalue) - (let ((n (cond ((null initialvalue) 7) ('t maxelement)))) - (make-array (length initialvalue) - :element-type (list 'mod (1+ n)) - :initial-contents initialvalue))) - -#+:CCL -(defun |makeByteWordVec2| (maxelement initialvalue) - (list-to-vector initialvalue)) - -(defun |knownEqualPred| (dom) - (let ((fun (|compiledLookup| '= '((|Boolean|) $ $) dom))) - (if fun (get (bpiname (car fun)) '|SPADreplace|) - nil))) - -(defun |hashable| (dom) - (memq (|knownEqualPred| dom) - #-Lucid '(EQ EQL EQUAL) - #+Lucid '(EQ EQL EQUAL EQUALP) - )) - -;; simpler interpface to RDEFIOSTREAM -(defun RDEFINSTREAM (&rest fn) - ;; following line prevents rdefiostream from adding a default filetype - (if (null (rest fn)) (setq fn (list (pathname (car fn))))) - (rdefiostream (list (cons 'FILE fn) '(mode . INPUT)))) - -(defun RDEFOUTSTREAM (&rest fn) - ;; following line prevents rdefiostream from adding a default filetype - (if (null (rest fn)) (setq fn (list (pathname (car fn))))) - (rdefiostream (list (cons 'FILE fn) '(mode . OUTPUT)))) - -(defmacro |spadConstant| (dollar n) - `(spadcall (svref ,dollar (the fixnum ,n)))) - - -@ -\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 515c288..7e6ec14 100644 --- a/src/interp/vmlisp.lisp.pamphlet +++ b/src/interp/vmlisp.lisp.pamphlet @@ -6374,6 +6374,751 @@ exit (rds ifile) (setpchar prompt) (lisp::unwind))) +; NAME: Scratchpad Package +; PURPOSE: This is an initialization and system-building file for Scratchpad. + +;;; Common Block + +(defvar |$UserLevel| '|development|) +(defvar |$preserveSystemLisplib| t "if nil finalizeLisplib does MA REP") +(defvar |$incrementalLisplibFlag| nil "checked in compDefineLisplib") +(defvar |$reportInstantiations| nil) +(defvar |$reportEachInstantiation| nil) +(defvar |$reportCounts| nil) +(defvar |$CategoryDefaults| nil) +(defvar |$compForModeIfTrue| nil "checked in compSymbol") +(defvar |$functorForm| nil "checked in addModemap0") +(defvar |$formalArgList| nil "checked in compSymbol") +(defvar |$newComp| nil "use new compiler") +(defvar |$newCompCompare| nil "compare new compiler with old") +(defvar |$compileOnlyCertainItems| nil "list of functions to compile") +(defvar |$newCompAtTopLevel| nil "if t uses new compiler") +(defvar |$doNotCompileJustPrint| nil "switch for compile") +(defvar |$PrintCompilerMessageIfTrue| t) +(defvar |$Rep| '|$Rep| "should be bound to gensym? checked in coerce") +;; the following initialization of $ must not be a defvar +;; since that make $ special +(setq $ '$) ;; used in def of Ring which is Algebra($) +(defvar |$scanIfTrue| nil "if t continue compiling after errors") +(defvar |$Representation| nil "checked in compNoStacking") +(defvar |$definition| nil "checked in DomainSubstitutionFunction") +(defvar |$Attributes| nil "global attribute list used in JoinInner") +(defvar |$env| nil "checked in isDomainValuedVariable") +(defvar |$e| nil "checked in isDomainValuedVariable") +(defvar |$getPutTrace| nil) +(defvar |$specialCaseKeyList| nil "checked in optCall") +(defvar |$formulaFormat| nil "if true produce script formula output") +(defvar |$texFormat| nil "if true produce tex output") +(defvar |$fortranFormat| nil "if true produce fortran output") +(defvar |$algebraFormat| t "produce 2-d algebra output") +(defvar |$kernelWarn| NIL "") +(defvar |$kernelProtect| NIL "") +(defvar |$HiFiAccess| nil "if true maintain history file") +(defvar |$mapReturnTypes| nil) +(defvar /TRACENAMES NIL) + +(defvar INPUTSTREAM t "bogus initialization for now") + +(defvar |boot-NewKEY| NIL) +(setq /WSNAME 'NOBOOT) +(DEFVAR _ '&) +(setq $linestack 'begin_unit) +(setq $maxlinenumber 0) +(defvar /EDIT-FM 'A1) +(defvar /EDIT-FT 'SPAD) +(defvar /RELEASE '"UNKNOWN") +(defvar /rp '/RP) +(defvar APLMODE NIL) +(defvar error-print) +(defvar ind) +(defvar INITCOLUMN 0) +(defvar JUNKTOKLIST '(FOR IN AS INTO OF TO)) +(defvar LCTRUE '|true|) +(defvar m-chrbuffer) +(defvar m-chrindex) +(defvar MARG 0 "Margin for testing by ?OP") +(defvar NewFlag) +(defvar ParseMode) +(defvar RLGENSYMFG NIL) +(defvar RLGENSYMLST NIL) +(defvar S-SPADTOK 'SPADSYSTOK) +(defvar sortpred) +(defvar SPADSYSKEY '(EOI EOL)) +(defvar STAKCOLUMN -1) +(setq XTOKENREADER 'SPADTOK) +(defvar xtrans '|boot-new|) +(defvar |$IOAlist| '((|%i| . (|gauss| 0 1)))) +(setq |$useBFasDefault| T) +(defvar |New-LEXPR|) +(defvar |NewFLAG| t) +(defvar |uc| 'UC) +(setq |$lisp2lispRenameAssoc| '((RETURN . |return|) + (EXIT . |exit|) + (AND . |and|) + (OR . |or|) + (NOT . |not|) + (IS . |is|) + (CAR . |first|) + (CDR . |rest|) + (EQUAL . =) + (NEQUAL . ^=) + (PLUS . +) + (TIMES . *) + (QUOTIENT . /) + (EXPT . **) + (SUBST . |substitute|) + (NULL . ^) + (ATOM . |atom|) + (NULL . |null|) + )) + +(setq |$spadOpList| + '(\.\. - = * / ** + - \< \> \<= \>= ^= \# \' ^ + \: \:\: \. =\> == ==\> \| \:=)) + +(DEFUN INTEGER-BIT (N I) (LOGBITP I N)) + +(DEFUN /TRANSPAD (X) + (PROG (proplist) + (setq proplist (LIST '(FLUID . |true|) + (CONS '|special| + (COPY-TREE |$InitialDomainsInScope|)))) + (SETQ |$tripleCache| NIL) + (SETQ |$InteractiveFrame| + (|addBinding| '|$DomainsInScope| proplist + (|addBinding| '|$Information| NIL + (COPY-TREE |$InitialModemapFrame|)))) + (RETURN (PROGN (S-PROCESS X) NIL)))) + +(DEFUN /TRANSBOOT (X) (S-PROCESS X) NIL) + +(DEFUN /TRANSNBOOT (X) (S-PROCESS X) NIL) + + ;; NIL needed below since END\_UNIT is not generated by current parser +(defun |isTokenDelimiter| () (MEMBER (CURRENT-SYMBOL) '(\) END\_UNIT NIL))) + +(defun |traceComp| () + (SETQ |$compCount| 0) + (EMBED '|comp| + '(LAMBDA (X Y Z) + (PROG (U) + (SETQ |$compCount| (1+ |$compCount|)) + (SETQ |yesOrNo| (if (SETQ U (|comp| X Y Z)) + (if (EQUAL (SECOND U) Y) '|yes| (SECOND U)) + ('T '|no|))) + (|sayBrightly| (CONS (MAKE-FULL-CVEC |$compCount| " ") + (LIST X " --> " Y '|%b| |yesOrNo| '|%d|))) + (SETQ |$compCount| (1- |$compCount|)) + (RETURN U) ))) + (|comp| $x $m $f) + (UNEMBED '|comp|)) + +(defun READ-SPAD (FN FM TO) + (LET ((proplist + (LIST '(FLUID . |true|) + (CONS '|special| (COPY-TREE |$InitialDomainsInScope|))))) + (SETQ |$InteractiveFrame| + (|addBinding| '|$DomainsInScope| proplist + (|addBinding| '|$Information| NIL + (|makeInitialModemapFrame|)))) + (READ-SPAD0 FN 'SPAD FM TO))) + +(defun READ-INPUT (FN FM TO) (READ-SPAD0 FN 'INPUT FM TO)) + +(defun READ-SPAD0 (FN FT FM TO) + (let (($newspad t)) (READ-SPAD1 FN FT FM TO))) + +(defun READ-SPAD-1 () (|New,ENTRY,1|)) + +(defun BOOT-LEXPR () (SETQ $BOOT 'T) (SPAD-LEXPR1)) + +(defun NBOOT-LEXPR () (SETQ $NBOOT 'T) (SPAD-LEXPR1)) + +(defun UNCONS (X) + (COND ((ATOM X) X) + ((EQCAR X 'CONS) (CONS (SECOND X) (UNCONS (THIRD X)))) + (T (ERROR "UNCONS")))) + +(defun OPTIMIZE\&PRINT (X) (PRETTYPRINT (/MDEF X))) + +(defun SPAD-PRINTTIME (A B) + (let (c msg) + (setq C (+ A B)) + (setq MSG (STRCONC "(" (STRINGIMAGE A) " + " (STRINGIMAGE B) + " = " (STRINGIMAGE C) " MS.)")) + (PRINT (STRCONC (STRINGPAD "" (DIFFERENCE 80 (SIZE MSG))) MSG)))) + +(defun SPAD-MODETRAN (X) (D-TRAN X)) + +(defun SPAD-MDTR-1 (X) + (COND + ((ATOM X) (LIST (LIST X))) + ((EQCAR X 'LIST) (SPAD-MDTR-2 (CDR X))) + (T (CROAK "MODE TRANSFORM ERROR")))) + +(defun SPAD-MDTR-2 (L) + (COND + ((NOT L) L) + ((ATOM (FIRST L)) + (COND + ((MEMBER (FIRST L) $DOMVAR) (FIRST L)) + (T (CONS (LIST (LIST (FIRST L))) (SPAD-MDTR-2 (CDR L)))) )) + (T (CONS (FIRST L) (SPAD-MDTR-2 (CDR L)))))) + +(defun SPAD-EVAL (X) + (COND ((ATOM X) (EVAL X)) + ((CONS (FIRST X) (MAPCAR #'SPAD-EVAL (CDR X)))))) + +;************************************************************************ +; SYSTEM COMMANDS +;************************************************************************ + +(defun CLEARDATABASE () (OBEY "ERASE MODEMAP DATABASE")) + +(defun erase (FN FT) + (OBEY (STRCONC "ERASE " (STRINGIMAGE FN) " " (STRINGIMAGE FT)))) + +(defun READLISP (UPPER_CASE_FG) + (let (v expr val ) + (setq EXPR (READ-FROM-STRING + (IF UPPER_CASE_FG (string-upcase (line-buffer CURRENT-LINE)) + (line-buffer CURRENT-LINE)) + t nil :start (Line-CURRENT-INDEX CURRENT-LINE))) + (VMPRINT EXPR) + (setq VAL ((LAMBDA (|$InteractiveMode|) (EVAL EXPR)) NIL)) + (FORMAT t "~&VALUE = ~S" VAL) + (TERSYSCOMMAND))) + +(defun TERSYSCOMMAND () + (FRESH-LINE) + (SETQ CHR 'ENDOFLINECHR) + (SETQ TOK 'END_UNIT) + (|spadThrow|)) + +(defun /READ (L Q) +; (SETQ /EDIT-FN (OR (KAR L) /EDIT-FN)) +; (SETQ /EDIT-FT (OR (KAR (KDR L)) 'INPUT)) +; (SETQ /EDIT-FM (OR (KAR (KDR (KDR L))) '*)) +; (SETQ /EDITFILE (LIST /EDIT-FN /EDIT-FT /EDIT-FM)) + (SETQ /EDITFILE L) + (COND + (Q (/RQ)) + ('T (/RF)) ) + (FLAG |boot-NewKEY| 'KEY) + (|terminateSystemCommand|) + (|spadPrompt|)) + +(defun /EDIT (L) + (SETQ /EDITFILE L) + (/EF) + (|terminateSystemCommand|) + (|spadPrompt|)) + +(defun /COMPINTERP (L OPTS) + (SETQ /EDITFILE (/MKINFILENAM L)) + (COND ((EQUAL OPTS "rf") (/RF)) + ((EQUAL OPTS "rq") (/RQ)) + ('T (/RQ-LIB))) + (|terminateSystemCommand|) + (|spadPrompt|)) + +(defun CPSAY (X) (let (n) (if (EQ 0 (setq N (OBEY X))) NIL (PRINT N)))) + +(defun /FLAG (L) + (MAKEPROP (FIRST L) 'FLAGS (LET ((X (UNION (CDR L)))) (GET (FIRST L) 'FLAGS))) + (SAY (FIRST L) " has flags: " X) + (TERSYSCOMMAND)) + +(defun |fin| () + (SETQ *EOF* 'T) + (THROW 'SPAD_READER NIL)) + + +(defun STRINGREST (X) (if (EQ (SIZE X) 1) (make-string 0) (SUBSTRING X 1 NIL))) + +(defun STREAM2UC (STRM) + (LET ((X (ELT (LASTATOM STRM) 1))) (SETELT X 0 (LC2UC (ELT X 0))))) + +(defun NEWNAMTRANS (X) + (COND + ((IDENTP X) (COND ( (GET X 'NEWNAM) (GET X 'NEWNAM)) ('T X))) + ((STRINGP X) X) + ((*VECP X) (MAPVWOC X (FUNCTION NEWNAMTRANS))) + ((ATOM X) X) + ((EQCAR X 'QUOTE)) + (T (CONS (NEWNAMTRANS (FIRST X)) (NEWNAMTRANS (CDR X)))))) + +(defun GP2COND (L) + (COND ((NOT L) (ERROR "GP2COND")) + ((NOT (CDR L)) + (COND ((EQCAR (FIRST L) 'COLON) + (CONS (SECOND L) (LIST (LIST T 'FAIL)))) + (T (LIST (LIST T (FIRST L)))) )) + ((EQCAR (FIRST L) 'COLON) (CONS (CDAR L) (GP2COND (CDR L)))) + (T (ERROR "GP2COND")))) + +(FLAG JUNKTOKLIST 'KEY) + +(defmacro |report| (L) + (SUBST (SECOND L) 'x + '(COND ($reportFlag (sayBrightly x)) ((QUOTE T) NIL)))) + +(defmacro |DomainSubstitutionMacro| (&rest L) + (|DomainSubstitutionFunction| (first L) (second L))) + +(defun |sort| (seq spadfn) + (sort (copy-seq seq) (function (lambda (x y) (SPADCALL X Y SPADFN))))) + +#-Lucid +(defun QUOTIENT2 (X Y) (values (TRUNCATE X Y))) + +#+Lucid +(defun QUOTIENT2 (X Y) ; following to force error check in division by zero + (values (if (zerop y) (truncate 1 Y) (TRUNCATE X Y)))) + +#-Lucid +(define-function 'REMAINDER2 #'REM) + +#+Lucid +(defun REMAINDER2 (X Y) + (if (zerop y) (REM 1 Y) (REM X Y))) + +#-Lucid +(defun DIVIDE2 (X Y) (multiple-value-call #'cons (TRUNCATE X Y))) + +#+Lucid +(defun DIVIDE2 (X Y) + (if (zerop y) (truncate 1 Y) + (multiple-value-call #'cons (TRUNCATE X Y)))) + +(defmacro APPEND2 (x y) `(append ,x ,y)) + +(defmacro |float| (x &optional (y 0.0d0)) `(float ,x ,y)) + +(defun |makeSF| (mantissa exponent) + (|float| (/ mantissa (expt 2 (- exponent))))) + +(define-function 'list1 #'list) +(define-function '|not| #'NOT) + +(defun |random| () (random (expt 2 26))) +(defun \,plus (x y) (+ x y)) +(defun \,times (x y) (* x y)) +(defun \,difference (x y) (- x y)) +(defun \,max (x y) (max x y)) +(defun \,min (x y) (min x y)) +;; This is used in the domain Boolean (BOOLEAN.nrlib/code.lsp) +(defun |BooleanEquality| (x y) (if x y (null y))) + +(defun S-PROCESS (X) + (let ((|$Index| 0) + ($MACROASSOC ()) + ($NEWSPAD T) + (|$PolyMode| |$EmptyMode|) + (|$compUniquelyIfTrue| nil) + |$currentFunction| + (|$postStack| nil) + |$topOp| + (|$semanticErrorStack| ()) + (|$warningStack| ()) + (|$exitMode| |$EmptyMode|) + (|$exitModeStack| ()) + (|$returnMode| |$EmptyMode|) + (|$leaveMode| |$EmptyMode|) + (|$leaveLevelStack| ()) + $TOP_LEVEL |$insideFunctorIfTrue| |$insideExpressionIfTrue| + |$insideCoerceInteractiveHardIfTrue| |$insideWhereIfTrue| + |$insideCategoryIfTrue| |$insideCapsuleFunctionIfTrue| |$form| + (|$DomainFrame| '((NIL))) + (|$e| |$EmptyEnvironment|) + (|$genFVar| 0) + (|$genSDVar| 0) + (|$VariableCount| 0) + (|$previousTime| (TEMPUS-FUGIT)) + (|$LocalFrame| '((NIL)))) + (prog ((CURSTRM CUROUTSTREAM) |$s| |$x| |$m| u) + (declare (special CURSTRM |$s| |$x| |$m| CUROUTSTREAM)) + (SETQ $TRACEFLAG T) + (if (NOT X) (RETURN NIL)) + (setq X (if $BOOT (DEF-RENAME (|new2OldLisp| X)) + (|parseTransform| (|postTransform| X)))) + (if |$TranslateOnly| (RETURN (SETQ |$Translation| X))) + (when |$postStack| (|displayPreCompilationErrors|) (RETURN NIL)) + (COND (|$PrintOnly| + (format t "~S =====>~%" |$currentLine|) + (RETURN (PRETTYPRINT X)))) + (if (NOT $BOOT) + (if |$InteractiveMode| + (|processInteractive| X NIL) + (if (setq U (|compTopLevel| X |$EmptyMode| + |$InteractiveFrame|)) + (SETQ |$InteractiveFrame| (third U)))) + (DEF-PROCESS X)) + (if |$semanticErrorStack| (|displaySemanticErrors|)) + (TERPRI)))) + +(MAKEPROP 'END_UNIT 'KEY T) + +(defun |process| (x) + (COND ((NOT (EQ TOK 'END_UNIT)) + (SETQ DEBUGMODE 'NO) + (SPAD_SYNTAX_ERROR) + (if |$InteractiveMode| (|spadThrow|)) + (S-PROCESS x)))) + + +@ +The evalSharpOne function needs to declare the second argument +special to reduce warning messages about variables being assumed +special. +<<*>>= +(defun |evalSharpOne| (x |#1|) (declare (special |#1|)) + (EVAL `(let() (declare (special |#1|)) ,x))) + +(defun new () (|New,ENTRY|)) + +(defun newpo () (let ((|$PrintOnly| t)) (new))) + +(defun |New,ENTRY| () + (let ((|$InteractiveMode| t)(inputstream in-stream) ) + (declare (special inputstream)) + (spad))) + +(defun |New,ENTRY,SYS| () + (let (|$InteractiveMode|) + (|New,ENTRY1|))) + +(defun |New,ENTRY1| () + (let ((spaderrorstream curoutstream) $boot (curinstream curinstream) + (strm curinstream)) + (SETQ CURINSTREAM *terminal-io*) + (|New,ENTRY,1|) + (SETQ CURINSTREAM STRM) + 'END_OF_New)) + +(setq *PROMPT* 'LISP) + +(defun |New,ENTRY,1| () + (let (ZZ str N RLGENSYMFG RLGENSYMLST |NewFLAG| XCAPE *PROMPT* + SINGLELINEMODE OK ISID NBLNK COUNT CHR ULCASEFG ($LINESTACK 'BEGIN_UNIT) + $NEWLINSTACK $TOKSTACK COMMENTCHR TOK LINE BACK INPUTSTREAM XTRANS + XTOKENREADER STACK STACKX) + (SETQ XTRANS '|boot-New| + XTOKENREADER 'NewSYSTOK + SYNTAX_ERROR 'SPAD_SYNTAX_ERROR) + (FLAG |boot-NewKEY| 'KEY) + (SETQ *PROMPT* 'Scratchpad-II) + (PROMPT) + (SETQ XCAPE '_) + (SETQ COMMENTCHR 'IGNORE) + (SETQ COLUMN 0) + (SETQ SINGLINEMODE T) ; SEE NewSYSTOK + (SETQ NewFLAG T) + (SETQ ULCASEFG T) + (setq STR (|New,ENTRY,2| '|PARSE-NewEXPR| '|process| curinstream)) + (if (/= 0 (setq N (NOTE STR))) + (progn (SETQ CURINSTREAM (POINTW N CURINSTREAM))) + ) + '|END_OF_New|)) + +(defun |New,ENTRY,2| (RULE FN INPUTSTREAM) (declare (special INPUTSTREAM)) + (let (zz) + (INITIALIZE) + (SETQ $previousTime (TEMPUS-FUGIT)) + (setq ZZ (CONVERSATION '|PARSE-NewExpr| '|process|)) + (REMFLAG |boot-NewKEY| 'KEY) + INPUTSTREAM)) + +(defun INITIALIZE () (init-boot/spad-reader) (initialize-preparse INPUTSTREAM)) + +(defun New-LEXPR () (New-LEXPR1)) + +(defun New-LEXPR-Interactive () (setq |$InteractiveMode| t) (New-LEXPR1)) + +(setq *prompt* 'new) + +(defun New-LEXPR1 () + (FLAG |boot-NewKEY| 'KEY) + (SETLINE (SUB1 (file-position INPUTSTREAM)) INPUTSTREAM) + (SETQ CHR 'ENDOFLINECHR) + (NXTTOK) + (|boot-Statement|) + (CAR STACK)) + +(defun parserState () + (PRINT (LIST 'CHR= CHR 'NBLNK= NBLNK 'TOK= TOK 'ISID= ISID + 'COUNT= COUNT 'COLUMN= COLUMN)) + (PRINT (LIST 'STACK= STACK 'STACKX= STACKX)) + (PRINT (LIST '$TOKSTACK= $TOKSTACK 'INPUTSTREAM= INPUTSTREAM))) + +(defmacro try (X) + `(LET ((|$autoLine|)) + (declare (special |$autoLine|)) + (|tryToFit| (|saveState|) ,X))) + +(mapcar #'(lambda (X) (MAKEPROP (CAR X) 'format (CADR X))) + '((COMMENT |formatCOMMENT|) + (SEQ |formatSEQ|) + (DEF |formatDEF|) + (LET |formatLET|) + (\: |formatColon|) + (ELT |formatELT|) + (SEGMENT |formatSEGMENT|) + (COND |formatCOND|) + (SCOND |formatSCOND|) + (QUOTE |formatQUOTE|) + (CONS |formatCONS|) + (|where| |formatWHERE|) + (APPEND |formatAPPEND|) + (REPEAT |formatREPEAT|) + (COLLECT |formatCOLLECT|) + (REDUCE |formatREDUCE|))) + +(defun |boot2Lisp| (LINESET) + (let* (($TOP_STACK T) (*PROMPT* 'New) ($MAXLINENUMBER 0) + (NewFLAG T) (XTRANS '|boot-New|) (XCAPE '!) + (COMMENTCHR 'NOTHING) (XTOKENREADER 'NewSYSTOK) + ($NBOOT T) (ERRCOL 0) (COUNT 0) (COLUMN 0) + (OK T) (SPADERRORSTREAM CUROUTSTREAM) + ($LINESTACK 'BEGIN_UNIT) + (INPUTSTREAM LINESET) + (CHR 'ENDOFLINECHR)) + (REMFLAG S-SPADKEY 'KEY) + (FLAG |boot-NewKEY| 'KEY) + (NXTTOK) ; causes PREPARSE to be called + (|boot-Statement|) + (REMFLAG |boot-NewKEY| 'KEY) + (FLAG S-SPADKEY 'KEY) + (if (NULL OK) (|boot2LispError|)) + (|new2OldLisp| (CAR STACK)))) + +(defun /cx (L) + "CAUTION: will not work if function in L has DEFLOC with ft=NBOOT" + (if (not L) (SETQ L |$LastCxArg|)) + (SETQ |$LastCxArg| L) + (/D-1 L '|lisp2BootAndCompare| NIL NIL)) + +(defun /foobar (L) + (let (($xCount 0)) + (if (not L) (SETQ L $LastCxArg)) + (SETQ $LastCxArg L) + (/D-1 L 'foobar NIL NIL))) + +(defun foobar (X) |$xCount|) + +(defun |/cxd| (L) + (if (NULL L) (SETQ L $|LastCxArg|)) + (SETQ |$LastCxArg| L) + (/D-1 L '|lispOfBoot2NBootAndCompare| NIL NIL)) + +(defun |/rx| (L) + (let ((DEF-RENAME 'IDENTITY) + (DEF-PROCESS '|lispOfBoot2NBootAndCompare|) ) + (declare (SPECIAL DEF-RENAME DEF-PROCESS)) + (if (OR (NULL L) (NULL (ATOM (CAR L)))) + (EVAL (APPEND (CONS '/RF /EDITFILE) L)) + (CATCH 'FILENAM (/RF-1 L))))) + +(defun |/ry| (L) + (let ((DEF-RENAME 'IDENTITY) + (DEF-PROCESS '|pp|) ) + (declare (SPECIAL DEF-RENAME DEF-PROCESS)) + (if (OR (NULL L) (NULL (ATOM (CAR L)))) + (EVAL (APPEND (CONS '/RF /EDITFILE) L)) + (CATCH 'FILENAM (/RF-1 L))))) + +(defun |/tb| (L) + (let ((DEF-RENAME 'IDENTITY) (DEF-PROCESS 'lispOfBoot2NBAC1)) + (declare (special DEF-RENAME DEF-PROCESS)) + (if (NULL L) + (EVAL (CONS '/RQ /EDITFILE)) + (CATCH 'FILENAM + (PROG (OUTFILE ($PRETTYPRINT T)) + (SETQ /EDITFILE (LIST (CAR L) 'BOOT '*)) + (OBEY (STRCONC "ERASE " (PNAME (CAR /EDITFILE)) " NBOOT E1")) + (SETQ OUTFILE (LIST (CAR /EDITFILE) 'NBOOT 'E1)) + (RETURN (/RF-1 (APPEND /EDITFILE + (LIST (CONS 'TO= OUTFILE)))))))))) + +(defun |boot2LispError| () + "Print syntax error indication, underline character, scrub line." + (COND ((OR (EQ DEBUGMODE 'YES) (NULL (CONSOLEINPUTP INPUTSTREAM))) + (SPAD_LONG_ERROR)) + (T (SPAD_SHORT_ERROR))) + (SETQ OK T)) + +(defun |getTranslation| (|function| |fn| |ft| |rdr|) + (let ((|New-LEXPR| |rdr|) (|$TranslateOnly| T)) + (declare (special |New-LEXPR| |$TranslateOnly|)) + (/D-1 (LIST |function| (LIST 'FROM= |fn| |ft|)) 'IDENTITY NIL NIL) + |$Translation|)) + +(defmacro |incTimeSum| (a b) + (if (not |$InteractiveTimingStatsIfTrue|) a + (let ((key b) (oldkey (gensym)) (val (gensym))) + `(prog (,oldkey ,val) + (setq ,oldkey (|incrementTimeSum| ,key)) + (setq ,val ,a) + (|incrementTimeSum| ,oldkey) + (return ,val))))) + +(defun GLESSEQP (X Y) (NOT (GGREATERP X Y))) + +(defun LEXLESSEQP (X Y) (NOT (LEXGREATERP X Y))) + +(defun SETELTFIRST (A B C) (declare (ignore b)) (RPLACA A C)) + +(defun SETELTREST (A B C) (declare (ignore b)) (RPLACD A C)) + +(defmacro |rplac| (&rest L) + (let (a b s) + (cond + ((EQCAR (SETQ A (CAR L)) 'ELT) + (COND ((AND (INTEGERP (SETQ B (CADDR A))) (>= B 0)) + (SETQ S "CA") + (do ((i 1 (1+ i))) ((> i b)) (SETQ S (STRCONC S "D"))) + (LIST 'RPLAC (LIST (INTERN (STRCONC S "R")) (CADR A)) (CADR L))) + ((ERROR "rplac")))) + ((PROGN + (SETQ A (CARCDREXPAND (CAR L) NIL)) + (SETQ 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)))))))) + +(DEFUN ASSOCIATER (FN LST) + (COND ((NULL LST) NIL) + ((NULL (CDR LST)) (CAR LST)) + ((LIST FN (CAR LST) (ASSOCIATER FN (CDR LST)))))) + +(defun ISLOCALOP-1 (IND) + "Curindex points at character after '.'" + (prog (selector buf termtok (NEWCHR (NEXTCHARACTER))) + (if (TERMINATOR NEWCHR) (RETURN NIL)) + (setq SELECTOR + (do ((x nil)) + (nil) + (if (terminator newchr) + (reverse x) + (push (setq newchr (nextcharacter)) x)))) + (if (EQUAL NEWCHR '\.) (RETURN (ISLOCALOP-1 IND))) + (setq BUF (GETSTR (LENGTH SELECTOR))) + (mapc #'(lambda (x) (suffix x buf)) selector) + (setq buf (copy-seq selector)) + (setq TERMTOK (INTERN BUF)) + (if (NOT (GET TERMTOK 'GENERIC)) (RETURN NIL)) + (if (OR (GET TERMTOK '|Led|) (GET TERMTOK '|Nud|)) + (GET TERMTOK IND)) + (return TERMTOK))) +; **** X. Random tables + +(defvar MATBORCH "*") +(defvar $MARGIN 3) +(defvar $LINELENGTH 71) +(defvar TEMPGENSYMLIST '(|s| |r| |q| |p|)) +(defvar ALPHLIST '(|a| |b| |c| |d| |e| |f| |g|)) +(defvar LITTLEIN " in ") +(defvar INITALPHLIST ALPHLIST) +(defvar INITXPARLST '(|i| |j| |k| |l| |m| |n| |p| |q|)) +(defvar PORDLST (COPY-tree INITXPARLST)) +(defvar INITPARLST '(|x| |y| |z| |u| |v| |w| |r| |s| |t|)) +(defvar LITTLEA '|a|) +(defvar LITTLEI '|i|) +(defvar *TALLPAR NIL) +(defvar ALLSTAR NIL) +(defvar BLANK " ") +(defvar PLUSS "+") +(defvar PERIOD ".") +(defvar SLASH "/") +(defvar COMMA ",") +(defvar LPAR "(") +(defvar RPAR ")") +(defvar EQSIGN "=") +(defvar DASH "-") +(defvar STAR "*") +(defvar DOLLAR "$") +(defvar COLON ":") + +; (SETQ |boot-NewKEY| (S- |boot-NewKEY| '(|cp| |cms| |lisp| |boot|))) + +(FLAG TEMPGENSYMLIST 'IS-GENSYM) + +(MAKEPROP 'COND '|Nud| '(|if| |if| 130 0)) +(MAKEPROP 'CONS '|Led| '(CONS CONS 1000 1000)) +(MAKEPROP 'APPEND '|Led| '(APPEND APPEND 1000 1000)) +(MAKEPROP 'TAG '|Led| '(TAG TAG 122 121)) +(MAKEPROP 'EQUATNUM '|Nud| '(|dummy| |dummy| 0 0)) +(MAKEPROP 'EQUATNUM '|Led| '(|dummy| |dummy| 10000 0)) +(MAKEPROP 'LET '|Led| '(:= LET 125 124)) +(MAKEPROP 'RARROW '|Led| '(== DEF 122 121)) +(MAKEPROP 'SEGMENT '|Led| '(\.\. SEGMENT 401 699 (|boot-Seg|))) + +;; NAME: DECIMAL-LENGTH +;; PURPOSE: Computes number of decimal digits in print representation of x +;; This should made as efficient as possible. + +(DEFUN DECIMAL-LENGTH (X) + (LET* ((K (FIX (* #.(LOG 2.0 10.) (INTEGER-LENGTH X)))) + (X (TRUNCATE (ABS X) (EXPT 10 (1- K))))) + (IF (LESSP X 10) K (1+ K)))) + +;(DEFUN DECIMAL-LENGTH2 (X) +; (LET ((K (FIX (* #.(LOG 2.0 10.) (INTEGER-LENGTH X))))) +; (IF (< (ABS X) (EXPT 10 K)) K (1+ K)))) + + +;; function to create byte and half-word vectors in new runtime system 8/90 + +#-:CCL +(defun |makeByteWordVec| (initialvalue) + (let ((n (cond ((null initialvalue) 7) ('t (reduce #'max initialvalue))))) + (make-array (length initialvalue) + :element-type (list 'mod (1+ n)) + :initial-contents initialvalue))) + +#+:CCL +(defun |makeByteWordVec| (initialvalue) + (list-to-vector initialvalue)) + +#-:CCL +(defun |makeByteWordVec2| (maxelement initialvalue) + (let ((n (cond ((null initialvalue) 7) ('t maxelement)))) + (make-array (length initialvalue) + :element-type (list 'mod (1+ n)) + :initial-contents initialvalue))) + +#+:CCL +(defun |makeByteWordVec2| (maxelement initialvalue) + (list-to-vector initialvalue)) + +(defun |knownEqualPred| (dom) + (let ((fun (|compiledLookup| '= '((|Boolean|) $ $) dom))) + (if fun (get (bpiname (car fun)) '|SPADreplace|) + nil))) + +(defun |hashable| (dom) + (memq (|knownEqualPred| dom) + #-Lucid '(EQ EQL EQUAL) + #+Lucid '(EQ EQL EQUAL EQUALP) + )) + +;; simpler interpface to RDEFIOSTREAM +(defun RDEFINSTREAM (&rest fn) + ;; following line prevents rdefiostream from adding a default filetype + (if (null (rest fn)) (setq fn (list (pathname (car fn))))) + (rdefiostream (list (cons 'FILE fn) '(mode . INPUT)))) + +(defun RDEFOUTSTREAM (&rest fn) + ;; following line prevents rdefiostream from adding a default filetype + (if (null (rest fn)) (setq fn (list (pathname (car fn))))) + (rdefiostream (list (cons 'FILE fn) '(mode . OUTPUT)))) + +(defmacro |spadConstant| (dollar n) + `(spadcall (svref ,dollar (the fixnum ,n)))) + + @ \eject \begin{thebibliography}{99}