remove pamphlets - part 7

1 files changed, 596 insertions, 0 deletions

diff --git a/src/interp/spad.lisp b/src/interp/spad.lisp
new file mode 100644
index 00000000..dedfa3e0
--- /dev/null
+++ b/src/interp/spad.lisp
@@ -0,0 +1,596 @@
+;; 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.
+
+(IMPORT-MODULE "bootlex")
+(in-package "BOOT")
+
+;;; Common  Block
+
+(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 _ '&)
+(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))))
+(defvar |InteractiveMode|)
+(defvar |NewFLAG| t)
+(defvar |uc| 'UC)
+
+(DEFUN INTEGER-BIT (N I) (LOGBITP I N))
+
+(DEFUN /TRANSPAD (X)
+  (PROG (proplist)
+        (setq proplist (LIST '(FLUID . |true|)
+                             (CONS '|special|
+                                   (COPY-TREE |$InitialDomainsInScope|))))
+        (SETQ |$InteractiveFrame|
+              (|addBinding| '|$DomainsInScope| proplist
+                          (|addBinding| '|$Information| NIL
+                                      (COPY-TREE |$InitialModemapFrame|))))
+        (RETURN (PROGN (S-PROCESS X) NIL))))
+
+ ;; NIL needed below since END\_UNIT is not generated by current parser
+
+(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 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-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)
+        (*print-pretty* t)
+        ($MACROASSOC ())
+        ($NEWSPAD T)
+        (|$compUniquelyIfTrue| nil)
+        |$currentFunction|
+        |$topOp|
+        (|$semanticErrorStack| ())
+        (|$warningStack| ())
+        (|$returnMode| |$EmptyMode|)
+        (|$leaveLevelStack| ())
+        $TOP_LEVEL |$insideFunctorIfTrue| |$insideExpressionIfTrue|
+        |$insideCoerceInteractiveHardIfTrue| |$insideWhereIfTrue|
+        |$insideCategoryIfTrue| |$insideCapsuleFunctionIfTrue| |$form|
+        (|$e| |$EmptyEnvironment|)
+        (|$genSDVar| 0)
+        (|$VariableCount| 0)
+        (|$previousTime| (TEMPUS-FUGIT)))
+    (prog ((CURSTRM CUROUTSTREAM) |$s| |$x| |$m| u)
+          (declare (special CURSTRM |$s| |$x| |$m| CUROUTSTREAM))
+          (SETQ |$exitModeStack| ())
+          (SETQ |$postStack| nil)
+          (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))))
+
+(defun |evalSharpOne| (x \#1) (declare (special \#1)) (EVAL x))
+
+(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)
+          $TOKSTACK COMMENTCHR TOK LINE BACK INPUTSTREAM XTRANS
+          XTOKENREADER STACK STACKX TRAPFLAG)
+      (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))
+
+(setq *prompt* 'new)
+
+(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|)))
+
+(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 ":")
+
+(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))))
+
+