aboutsummaryrefslogtreecommitdiff
path: root/src/interp/spad.lisp.pamphlet
diff options
context:
space:
mode:
authordos-reis <gdr@axiomatics.org>2007-08-14 05:14:52 +0000
committerdos-reis <gdr@axiomatics.org>2007-08-14 05:14:52 +0000
commitab8cc85adde879fb963c94d15675783f2cf4b183 (patch)
treec202482327f474583b750b2c45dedfc4e4312b1d /src/interp/spad.lisp.pamphlet
downloadopen-axiom-ab8cc85adde879fb963c94d15675783f2cf4b183.tar.gz
Initial population.
Diffstat (limited to 'src/interp/spad.lisp.pamphlet')
-rw-r--r--src/interp/spad.lisp.pamphlet813
1 files changed, 813 insertions, 0 deletions
diff --git a/src/interp/spad.lisp.pamphlet b/src/interp/spad.lisp.pamphlet
new file mode 100644
index 00000000..382ffc6a
--- /dev/null
+++ b/src/interp/spad.lisp.pamphlet
@@ -0,0 +1,813 @@
+%% Oh Emacs, this is a -*- Lisp -*- file despite apperance.
+
+\documentclass{article}
+\usepackage{axiom}
+
+\title{\File{src/interp/spad.lisp} Pamphlet}
+\author{Timothy Daly}
+
+\begin{document}
+\maketitle
+
+\begin{abstract}
+\end{abstract}
+
+\tableofcontents
+\eject
+
+\section{License}
+
+<<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.
+
+@
+
+<<*>>=
+<<license>>
+
+; 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 |InteractiveMode|)
+(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)
+
+(DEFUN /TRANSMETA (X)
+ (PROG (KEYNAM ROOTFN U)
+ (SETQ ROOTFN (/MFINDROOT (CAR /SOURCEFILES)))
+ (SETQ $LASTPREFIX (GET ROOTFN 'METAPFX))
+ (SETQ KEYNAM (INTERNL $LASTPREFIX (PNAME ROOTFN) "KEY"))
+ (SET KEYNAM (REMDUP (APPEND METAKEYLST (EVAL KEYNAM))))
+ (SETQ U (GETRULEFUNLISTS ROOTFN (LIST X)))
+ (SUBLISNQ (PAIR (CADR U) (CAR U)) X)))
+
+ ;; 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)
+ (*print-pretty* t)
+ ($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))))
+
+(defun |evalSharpOne| (x \#1) (declare (special \#1)) (EVAL 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 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))
+
+(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)
+ (TRAPFLAG NIL) (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}