diff --git a/books/bookvol5.pamphlet b/books/bookvol5.pamphlet index d422284..ecf9478 100644 --- a/books/bookvol5.pamphlet +++ b/books/bookvol5.pamphlet @@ -1380,16 +1380,19 @@ this is what the current code does so I won't change it. (defvar |$currentFrameNum| 0) @ + \defdollar{EndServerSession} <>= (defvar |$EndServerSession| nil) @ + \defdollar{NeedToSignalSessionManager} <>= (defvar |$NeedToSignalSessionManager| nil) @ + \defdollar{sockBufferLength} <>= (defvar |$sockBufferLength| 9217) @@ -1510,6 +1513,499 @@ this is what the current code does so I won't change it. @ +\defun{protectedEVAL}{protectedEVAL} +\calls{protectedEVAL}{resetStackLimits} +\calls{protectedEVAL}{sendHTErrorSignal} +<>= +(defun |protectedEVAL| (x) + (let (val (error t)) + (unwind-protect + (progn + (setq val (eval x)) + (setq error nil)) + (when error + (|resetStackLimits|) + (|sendHTErrorSignal|))) + (unless error val))) + +@ + +\defdollar{QuietCommand} +<>= +(defvar |$QuietCommand| nil "If true, produce no top level output") + +@ + +\defun{executeQuietCommand}{executeQuietCommand} +When \verb|$QuiteCommand| is true Spad will not produce any output from +a top level command +\catches{executeQuietCommand}{coerceFailure} +\catches{executeQuietCommand}{top\_level} +\catches{executeQuietCommand}{spad\_reader} +\calls{executeQuietCommand}{make-string} +\calls{executeQuietCommand}{sockGetString} +\calls{executeQuietCommand}{parseAndInterpret} +\usesdollar{executeQuietCommand}{MenuServer} +\usesdollar{executeQuietCommand}{QuietCommand} +<>= +(defun |executeQuietCommand| () + (let (|$QuietCommand| stringBuf) + (declare (special |$QuietCommand| |$MenuServer|)) + (setq |$QuietCommand| t) + (setq stringBuf (make-string 512)) + (|sockGetString| |$MenuServer| stringBuf 512) + (catch '|coerceFailure| + (catch '|top_level| + (catch 'spad_reader (|parseAndInterpret| stringBuf)))))) + +@ + +\defun{parseAndInterpret}{parseAndInterpret} +\calls{parseAndInterpret}{ncParseAndInterpretString} +\calls{parseAndInterpret}{oldParseAndInterpret} +\usesdollar{parseAndInterpret}{InteractiveMode} +\usesdollar{parseAndInterpret}{boot} +\usesdollar{parseAndInterpret}{spad} +\usesdollar{parseAndInterpret}{e} +\usesdollar{parseAndInterpret}{useNewParser} +\usesdollar{parseAndInterpret}{InteractiveFrame} +<>= +(defun |parseAndInterpret| (str) + (let (|$InteractiveMode| $boot $spad |$e|) + (declare (special |$InteractiveMode| $boot $spad |$e| |$useNewParser| + |$InteractiveFrame|)) + (setq |$InteractiveMode| t) + (setq $boot nil) + (setq $spad t) + (setq |$e| |$InteractiveFrame|) + (if |$useNewParser| + (|ncParseAndInterpretString| str)) + (|oldParseAndInterpret| str))) + + +@ + +\defun{oldParseAndInterpret}{oldParseAndInterpret} +\calls{oldParseAndInterpret}{string2SpadTree} +\calls{oldParseAndInterpret}{processInteractive} +\calls{oldParseAndInterpret}{parseTransform} +\calls{oldParseAndInterpret}{postTransform} +<>= +(defun |oldParseAndInterpret| (str) + (let ((tree (|string2SpadTree| str))) + (when tree + (|processInteractive| (|parseTransform| (|postTransform| tree)) nil)))) + +@ + +\defun{processInteractive}{processInteractive} +Parser Output {\tt -->} Interpreter + +Top-level dispatcher for the interpreter. It sets local variables +and then calls processInteractive1 to do most of the work. +This function receives the output from the parser. +\calls{processInteractive}{initializeTimedNames} +\calls{processInteractive}{pairp} +\calls{processInteractive}{qcar} +\calls{processInteractive}{processInteractive1} +\calls{processInteractive}{reportInstantiations} +\calls{processInteractive}{clrhash} +\calls{processInteractive}{writeHistModesAndValues} +\calls{processInteractive}{updateHist} +\usesdollar{processInteractive}{op} +\usesdollar{processInteractive}{Coerce} +\usesdollar{processInteractive}{compErrorMessageStack} +\usesdollar{processInteractive}{freeVars} +\usesdollar{processInteractive}{mapList} +\usesdollar{processInteractive}{compilingMap} +\usesdollar{processInteractive}{compilingLoop} +\usesdollar{processInteractive}{interpOnly} +\usesdollar{processInteractive}{whereCacheList} +\usesdollar{processInteractive}{timeGlobalName} +\usesdollar{processInteractive}{StreamFrame} +\usesdollar{processInteractive}{declaredMode} +\usesdollar{processInteractive}{localVars} +\usesdollar{processInteractive}{analyzingMapList} +\usesdollar{processInteractive}{lastLineInSEQ} +\usesdollar{processInteractive}{instantCoerceCount} +\usesdollar{processInteractive}{instantCanCoerceCount} +\usesdollar{processInteractive}{instantMmCondCount} +\usesdollar{processInteractive}{fortVar} +\usesdollar{processInteractive}{minivector} +\usesdollar{processInteractive}{minivectorCode} +\usesdollar{processInteractive}{minivectorNames} +\usesdollar{processInteractive}{domPvar} +\usesdollar{processInteractive}{inRetract} +\usesdollar{processInteractive}{instantRecord} +\usesdollar{processInteractive}{reportInstantiations} +\usesdollar{processInteractive}{ProcessInteractiveValue} +\usesdollar{processInteractive}{defaultFortVar} +\usesdollar{processInteractive}{interpreterTimedNames} +\usesdollar{processInteractive}{interpreterTimedClasses} +<>= +(defun |processInteractive| (form posnForm) + (let (|$op| |$Coerce| |$compErrorMessageStack| |$freeVars| + |$mapList| |$compilingMap| |$compilingLoop| + |$interpOnly| |$whereCacheList| |$timeGlobalName| + |$StreamFrame| |$declaredMode| |$localVars| + |$analyzingMapList| |$lastLineInSEQ| + |$instantCoerceCount| |$instantCanCoerceCount| + |$instantMmCondCount| |$fortVar| |$minivector| + |$minivectorCode| |$minivectorNames| |$domPvar| + |$inRetract| object) + (declare (special |$op| |$Coerce| |$compErrorMessageStack| + |$freeVars| |$mapList| |$compilingMap| + |$compilingLoop| |$interpOnly| |$whereCacheList| + |$timeGlobalName| |$StreamFrame| |$declaredMode| + |$localVars| |$analyzingMapList| |$lastLineInSEQ| + |$instantCoerceCount| |$instantCanCoerceCount| + |$instantMmCondCount| |$fortVar| |$minivector| + |$minivectorCode| |$minivectorNames| |$domPvar| + |$inRetract| |$instantRecord| |$reportInstantiations| + |$ProcessInteractiveValue| |$defaultFortVar| + |$interpreterTimedNames| |$interpreterTimedClasses|)) + (|initializeTimedNames| |$interpreterTimedNames| |$interpreterTimedClasses|) + (if (pairp form) ; compute name of operator + (setq |$op| (qcar form)) + (setq |$op| form)) + (setq |$Coerce| nil) + (setq |$compErrorMessageStack| nil) + (setq |$freeVars| nil) + (setq |$mapList| nil) ; list of maps being type analyzed + (setq |$compilingMap| nil) ; true when compiling a map + (setq |$compilingLoop| nil) ; true when compiling a loop body + (setq |$interpOnly| nil) ; true when in interp only mode + (setq |$whereCacheList| nil) ; maps compiled because of where + (setq |$timeGlobalName| '|$compTimeSum|); see incrementTimeSum + (setq |$StreamFrame| nil) ; used in printing streams + (setq |$declaredMode| nil) ; weak type propagation for symbols + (setq |$localVars| nil) ; list of local variables in function + (setq |$analyzingMapList| nil) ; names of maps currently being analyzed + (setq |$lastLineInSEQ| t) ; see evalIF and friends + (setq |$instantCoerceCount| 0) + (setq |$instantCanCoerceCount| 0) + (setq |$instantMmCondCount| 0) + (setq |$defaultFortVar| 'x) ; default FORTRAN variable name + (setq |$fortVar| |$defaultFortVar|) ; variable name for FORTRAN output + (setq |$minivector| nil) + (setq |$minivectorCode| nil) + (setq |$minivectorNames| nil) + (setq |$domPvar| nil) + (setq |$inRetract| nil) + (setq object (|processInteractive1| form posnForm)) + (unless |$ProcessInteractiveValue| + (when |$reportInstantiations| + (|reportInstantiations|) + (clrhash |$instantRecord|)) + (|writeHistModesAndValues|) + (|updateHist|)) + object)) + +@ + +\defun{processInteractive1}{processInteractive1} +This calls the analysis and output printing routines +\calls{processInteractive1}{recordFrame} +\calls{processInteractive1}{startTimingProcess} +\calls{processInteractive1}{interpretTopLevel} +\calls{processInteractive1}{stopTimingProcess} +\calls{processInteractive1}{recordAndPrint} +\calls{processInteractive1}{objValUnwrap} +\calls{processInteractive1}{objMode} +\usesdollar{processInteractive1}{e} +\usesdollar{processInteractive1}{ProcessInteractiveValue} +\usesdollar{processInteractive1}{InteractiveFrame} +<>= +(defun |processInteractive1| (form posnForm) + (let (|$e| object) + (declare (special |$e| |$ProcessInteractiveValue| |$InteractiveFrame|)) + (setq |$e| |$InteractiveFrame|) + (|recordFrame| '|system|) + (|startTimingProcess| '|analysis|) + (setq object (|interpretTopLevel| form posnForm)) + (|stopTimingProcess| '|analysis|) + (|startTimingProcess| '|print|) + (unless |$ProcessInteractiveValue| + (|recordAndPrint| (|objValUnwrap| object) (|objMode| object))) + (|recordFrame| '|normal|) + (|stopTimingProcess| '|print|) + object)) + +@ + +\defun{recordAndPrint}{} +Result Output Printing. +Prints out the value x which is of type m, and records the changes +in environment \verb|$e| into \verb|$InteractiveFrame| +\verb|$printAnyIfTrue| is documented in setvart.boot. +It is controlled with the {\tt )se me any} command. +\calls{recordAndPrint}{nequal} +\calls{recordAndPrint}{output} +\calls{recordAndPrint}{putHist} +\calls{recordAndPrint}{objNewWrap} +\calls{recordAndPrint}{printTypeAndTime} +\calls{recordAndPrint}{printStorage} +\calls{recordAndPrint}{printStatisticsSummary} +\calls{recordAndPrint}{fixp} +\calls{recordAndPrint}{mkCompanionPage} +\calls{recordAndPrint}{recordAndPrintTest} +\usesdollar{recordAndPrint}{outputMode} +\usesdollar{recordAndPrint}{mkTestOutputType} +\usesdollar{recordAndPrint}{runTestFlag} +\usesdollar{recordAndPrint}{e} +\usesdollar{recordAndPrint}{mkTestFlag} +\usesdollar{recordAndPrint}{HTCompanionWindowID} +\usesdollar{recordAndPrint}{QuietCommand} +\usesdollar{recordAndPrint}{printStatisticsSummaryIfTrue} +\usesdollar{recordAndPrint}{printTypeIfTrue} +\usesdollar{recordAndPrint}{printStorageIfTrue} +\usesdollar{recordAndPrint}{printTimeIfTrue} +\usesdollar{recordAndPrint}{Void} +\usesdollar{recordAndPrint}{algebraOutputStream} +\usesdollar{recordAndPrint}{collectOutput} +\usesdollar{recordAndPrint}{EmptyMode} +\usesdollar{recordAndPrint}{printVoidIfTrue} +\usesdollar{recordAndPrint}{outputMode} +\usesdollar{recordAndPrint}{printAnyIfTrue} +<>= +(defun |recordAndPrint| (x md) + (let (|$outputMode| xp mdp mode) + (declare (special |$outputMode| |$mkTestOutputType| |$runTestFlag| |$e| + |$mkTestFlag| |$HTCompanionWindowID| |$QuietCommand| + |$printStatisticsSummaryIfTrue| |$printTypeIfTrue| + |$printStorageIfTrue| |$printTimeIfTrue| |$Void| + |$algebraOutputStream| |$collectOutput| |$EmptyMode| + |$printVoidIfTrue| |$outputMode| |$printAnyIfTrue|)) + (cond + ((and (equal md '(|Any|)) |$printAnyIfTrue|) + (setq mdp (car x)) + (setq xp (cdr x))) + (t + (setq mdp md) + (setq xp x))) + (setq |$outputMode| md) + (if (equal md |$EmptyMode|) + (setq mode (|quadSch|)) + (setq mode md)) + (when (or (nequal md |$Void|) |$printVoidIfTrue|) + (unless |$collectOutput| (terpri |$algebraOutputStream|)) + (unless |$QuietCommand| (|output| xp mdp))) + (|putHist| '% '|value| (|objNewWrap| x md) |$e|) + (when (or |$printTimeIfTrue| |$printTypeIfTrue|) + (|printTypeAndTime| xp mdp)) + (when |$printStorageIfTrue| (|printStorage|)) + (when |$printStatisticsSummaryIfTrue| (|printStatisticsSummary|)) + (when (fixp |$HTCompanionWindowID|) (|mkCompanionPage| md)) + (cond + (|$mkTestFlag| (|recordAndPrintTest| md)) + (|$runTestFlag| + (setq |$mkTestOutputType| md) + '|done|) + (t '|done|)))) + +@ + +\defun{printStatisticsSummary}{printStatisticsSummary} +\calls{printStatisticsSummary}{sayKeyedMsg} +\calls{printStatisticsSummary}{statisticsSummary} +\usesdollar{printStatisticsSummary}{collectOutput} +<>= +(defun |printStatisticsSummary| () + (declare (special |$collectOutput|)) + (unless |$collectOutput| + (|sayKeyedMsg| 'S2GL0017 (list (|statisticsSummary|))))) + +@ + +\defun{printStorage}{printStorage} +\calls{printStorage}{makeLongSpaceString} +\usesdollar{printStorage}{interpreterTimedClasses} +\usesdollar{printStorage}{collectOutput} +\usesdollar{printStorage}{interpreterTimedNames} +<>= +(defun |printStorage| () + (declare (special |$interpreterTimedClasses| |$collectOutput| + |$interpreterTimedNames|)) + (unless |$collectOutput| + (|sayKeyedMsg| 'S2GL0016 + (list + (|makeLongSpaceString| + |$interpreterTimedNames| + |$interpreterTimedClasses|))))) + +@ + +\defun{printTypeAndTime}{printTypeAndTime} +\calls{printTypeAndTime}{printTypeAndTimeSaturn} +\calls{printTypeAndTime}{printTypeAndTimeNormal} +\usesdollar{printTypeAndTime}{saturn} +<>= +(defun |printTypeAndTime| (x m) + (declare (special |$saturn|)) + (if |$saturn| + (|printTypeAndTimeSaturn| x m) + (|printTypeAndTimeNormal| x m))) + +@ + +\defun{printTypeAndTimeNormal}{printTypeAndTimeNormal} +\calls{printTypeAndTimeNormal}{qcar} +\calls{printTypeAndTimeNormal}{pairp} +\calls{printTypeAndTimeNormal}{retract} +\calls{printTypeAndTimeNormal}{objNewWrap} +\calls{printTypeAndTimeNormal}{objMode} +\calls{printTypeAndTimeNormal}{sameUnionBranch} +\calls{printTypeAndTimeNormal}{makeLongTimeString} +\calls{printTypeAndTimeNormal}{msgText} +\calls{printTypeAndTimeNormal}{sayKeyedMsg} +\calls{printTypeAndTimeNormal}{justifyMyType} +\usesdollar{printTypeAndTimeNormal}{outputLines} +\usesdollar{printTypeAndTimeNormal}{collectOutput} +\usesdollar{printTypeAndTimeNormal}{printTypeIfTrue} +\usesdollar{printTypeAndTimeNormal}{printTimeIfTrue} +\usesdollar{printTypeAndTimeNormal}{outputLines} +\usesdollar{printTypeAndTimeNormal}{interpreterTimedNames} +\usesdollar{printTypeAndTimeNormal}{interpreterTimedClasses} +<>= +(defun |printTypeAndTimeNormal| (x m) + (let (xp mp timeString result) + (declare (special |$outputLines| |$collectOutput| |$printTypeIfTrue| + |$printTimeIfTrue| |$outputLines| + |$interpreterTimedNames| |$interpreterTimedClasses|)) + (cond + ((and (pairp m) (eq (qcar m) '|Union|)) + (setq xp (|retract| (|objNewWrap| x m))) + (setq mp (|objMode| xp)) + (setq m + (cons '|Union| + (append + (dolist (arg (qcdr m) (nreverse result)) + (when (|sameUnionBranch| arg mp) (push arg result))) + (list "...")))))) + (when |$printTimeIfTrue| + (setq timeString + (|makeLongTimeString| + |$interpreterTimedNames| + |$interpreterTimedClasses|))) + (cond + ((and |$printTimeIfTrue| |$printTypeIfTrue|) + (if |$collectOutput| + (push (|msgText| 'S2GL0012 (list m)) |$outputLines|) + (|sayKeyedMsg| 'S2GL0014 (list m timeString )))) + (|$printTimeIfTrue| + (unless |$collectOutput| (|sayKeyedMsg| 'S2GL0013 (list timeString)))) + (|$printTypeIfTrue| + (if |$collectOutput| + (push (|justifyMyType| (|msgText| 'S2GL0012 (list m))) |$outputLines|) + (|sayKeyedMsg| 'S2GL0012 (list m))))))) + +@ + +\defun{printTypeAndTimeSaturn}{printTypeAndTimeSaturn} +\calls{printTypeAndTimeSaturn}{makeLongTimeString} +\calls{printTypeAndTimeSaturn}{form2StringAsTeX} +\calls{printTypeAndTimeSaturn}{devaluate} +\calls{printTypeAndTimeSaturn}{printAsTeX} +\usesdollar{printTypeAndTimeSaturn}{printTimeIfTrue} +\usesdollar{printTypeAndTimeSaturn}{printTypeIfTrue} +\usesdollar{printTypeAndTimeSaturn}{interpreterTimedClasses} +\usesdollar{printTypeAndTimeSaturn}{interpreterTimedNames} +<>= +(defun |printTypeAndTimeSaturn| (x m) + (declare (ignore x)) + (let (timeString typeString) + (declare (special |$printTimeIfTrue| |$printTypeIfTrue| + |$interpreterTimedClasses| |$interpreterTimedNames|)) + (if |$printTimeIfTrue| + (setq timeString + (|makeLongTimeString| + |$interpreterTimedNames| + |$interpreterTimedClasses|)) + (setq timeString "")) + (if |$printTypeIfTrue| + (setq typeString (|form2StringAsTeX| (|devaluate| m))) + (setq typeString "")) + (when |$printTypeIfTrue| + (|printAsTeX| "\\axPrintType{") + (if (consp typeString) + (mapc #'|printAsTeX| typeString) + (|printAsTeX| typeString)) + (|printAsTeX| "}")) + (when |$printTimeIfTrue| + (|printAsTeX| "\\axPrintTime{") + (|printAsTeX| timeString) + (|printAsTeX| "}")))) + +@ + +\defun{printAsTeX}{printAsTeX} +\usesdollar{printAsTeX}{texOutputStream} +<>= +(defun |printAsTeX| (x) + (declare (special |$texOutputStream|)) + (princ x |$texOutputStream|)) + +@ + +\defun{sameUnionBranch}{sameUnionBranch} +\begin{verbatim} +sameUnionBranch(uArg, m) == + uArg is [":", ., t] => t = m + uArg = m +\end{verbatim} +<>= +(defun |sameUnionBranch| (uArg m) + (let (t1 t2 t3) + (cond + ((and (pairp uArg) + (eq (qcar uArg) '|:|) + (progn + (setq t1 (qcdr uArg)) + (and (pairp t1) + (progn + (setq t2 (qcdr t1)) + (and (pairp t2) + (eq (qcdr t2) nil) + (progn (setq t3 (qcar t2)) t)))))) + (equal t3 m)) + (t (equal uArg m))))) + + +@ + +\defun{msgText}{msgText} +\calls{msgText}{segmentKeyedMsg} +\calls{msgText}{getKeyedMsg} +\calls{msgText}{substituteSegmentedMsg} +\calls{msgText}{flowSegmentedMsg} +\calls{msgText}{stringimage} +\usesdollar{msgText}{linelength} +\usesdollar{msgText}{margin} +<>= +(defun |msgText| (key args) + (let (msg) + (declare (special $linelength $margin)) + (setq msg (|segmentKeyedMsg| (|getKeyedMsg| key))) + (setq msg (|substituteSegmentedMsg| msg args)) + (setq msg (|flowSegmentedMsg| msg $linelength $margin)) + (apply #'concat (mapcar #'stringimage (cdar msg))))) + +@ + +\defun{justifyMyType}{Right-justify the Type output} +\calls{justifyMyType}{fillerSpaces} +\usesdollar{justifyMyType}{linelength} +<>= +(defun |justifyMyType| (arg) + (let (len) + (declare (special $linelength)) + (setq len (|#| arg)) + (if (> len $linelength) + arg + (concat (|fillerSpaces| (- $linelength len)) arg)))) + +@ + \defun{unescapeStringsInForm}{Destructively fix quotes in strings} \calls{unescapeStringsInForm}{unescapeStringsInForm} \usesdollar{unescapeStringsInForm}{funnyBacks} @@ -3497,8 +3993,8 @@ returning the token-dq and the rest of the line-stream \defun{lfid}{lfid} To pair badge and badgee <>= -(defun |lfid| (|x|) - (list '|id| (intern |x| "BOOT"))) +(defun |lfid| (x) + (list '|id| (intern x "BOOT"))) @ @@ -30572,6 +31068,7 @@ See Steele Common Lisp 1990 pp305-307 <> <> <> +<> <> <> @@ -30747,6 +31244,8 @@ See Steele Common Lisp 1990 pp305-307 <> <> +<> + <> <> <> @@ -30810,6 +31309,7 @@ See Steele Common Lisp 1990 pp305-307 <> <> <> +<> <> <> @@ -30863,6 +31363,7 @@ See Steele Common Lisp 1990 pp305-307 <> <> +<> <> <> <> @@ -30870,6 +31371,7 @@ See Steele Common Lisp 1990 pp305-307 <> <> +<> <> <> <> @@ -30906,12 +31408,21 @@ See Steele Common Lisp 1990 pp305-307 <> <> <> +<> <> +<> +<> <> +<> +<> +<> <> +<> +<> <> <> <> +<> <> <> <> @@ -30938,6 +31449,7 @@ See Steele Common Lisp 1990 pp305-307 <> <> <> +<> <> <> <> @@ -30976,6 +31488,7 @@ See Steele Common Lisp 1990 pp305-307 <> <> +<> <> <> <> diff --git a/changelog b/changelog index e39bd52..1b2f422 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +20100117 tpd src/axiom-website/patches.html 20100117.01.tpd.patch +20100117 tpd src/interp/server.lisp treeshake +20100117 tpd src/interp/i-toplev.lisp treeshake +20100117 tpd books/bookvol5 treeshake i-toplev, server 20100116 tpd src/axiom-website/patches.html 20100116.01.tpd.patch 20100116 tpd src/interp/vmlisp.lisp remove exposed from get-directory-list 20100116 tpd src/interp/util.lisp remove libcheck diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 2caec23..f427d56 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -2376,5 +2376,7 @@ src/input/dop.input rewrite using machineFraction
books/bookvol5 do not set si::*system-directory* in restart
20100116.01.tpd.patch books/bookvol5 merge and remove exposed.lsp
+20100117.01.tpd.patch +books/bookvol5 treeshake i-toplev, server
diff --git a/src/interp/i-toplev.lisp.pamphlet b/src/interp/i-toplev.lisp.pamphlet index 2d012b2..4f02e81 100644 --- a/src/interp/i-toplev.lisp.pamphlet +++ b/src/interp/i-toplev.lisp.pamphlet @@ -19,13 +19,6 @@ from LISP. (IN-PACKAGE "BOOT" ) -;--% Top Level Interpreter Code -;-- When $QuiteCommand is true Spad will not produce any output from -;-- a top level command -;SETANDFILEQ($QuietCommand, NIL) - -(SETANDFILEQ |$QuietCommand| NIL) - ;-- When $ProcessInteractiveValue is true, we don't want the value printed ;-- or recorded. ;SETANDFILEQ($ProcessInteractiveValue, NIL) @@ -170,441 +163,6 @@ from LISP. (COND ((NULL |l|) (|runspad|))) '|EndOfSpad|)))) -;--% Parser Output --> Interpreter -;processInteractive(form, posnForm) == -; -- Top-level dispatcher for the interpreter. It sets local variables -; -- and then calls processInteractive1 to do most of the work. -; -- This function receives the output from the parser. -; initializeTimedNames($interpreterTimedNames,$interpreterTimedClasses) -; $op: local:= (form is [op,:.] => op; form) --name of operator -; $Coerce: local := NIL -; $compErrorMessageStack:local := nil -; $freeVars : local := NIL -; $mapList:local := NIL --list of maps being type analyzed -; $compilingMap:local:= NIL --true when compiling a map -; $compilingLoop:local:= NIL --true when compiling a loop body -; $interpOnly: local := NIL --true when in interpret only mode -; $whereCacheList: local := NIL --maps compiled because of where -; $timeGlobalName: local := '$compTimeSum --see incrementTimeSum -; $StreamFrame: local := nil --used in printing streams -; $declaredMode: local := NIL --Weak type propagation for symbols -; $localVars:local := NIL --list of local variables in function -; $analyzingMapList:local := NIL --names of maps currently being -; --analyzed -; $lastLineInSEQ: local := true --see evalIF and friends -; $instantCoerceCount: local := 0 -; $instantCanCoerceCount: local := 0 -; $instantMmCondCount: local := 0 -; $defaultFortVar:= 'X --default FORTRAN variable name -; $fortVar : local := --variable name for FORTRAN output -; $defaultFortVar -; $minivector: local := NIL -; $minivectorCode: local := NIL -; $minivectorNames: local := NIL -; $domPvar: local := NIL -; $inRetract: local := NIL -; object := processInteractive1(form, posnForm) -; --object := ERRORSET(LIST('processInteractive1,LIST('QUOTE,form),LIST('QUOTE,posnForm)),'t,'t) -; if not($ProcessInteractiveValue) then -; if $reportInstantiations = true then -; reportInstantiations() -; CLRHASH $instantRecord -; writeHistModesAndValues() -; updateHist() -; object - -(DEFUN |processInteractive| (|form| |posnForm|) - (PROG (|$op| |$Coerce| |$compErrorMessageStack| |$freeVars| - |$mapList| |$compilingMap| |$compilingLoop| - |$interpOnly| |$whereCacheList| |$timeGlobalName| - |$StreamFrame| |$declaredMode| |$localVars| - |$analyzingMapList| |$lastLineInSEQ| - |$instantCoerceCount| |$instantCanCoerceCount| - |$instantMmCondCount| |$fortVar| |$minivector| - |$minivectorCode| |$minivectorNames| |$domPvar| - |$inRetract| |op| |object|) - (DECLARE (SPECIAL |$op| |$Coerce| |$compErrorMessageStack| - |$freeVars| |$mapList| |$compilingMap| - |$compilingLoop| |$interpOnly| |$whereCacheList| - |$timeGlobalName| |$StreamFrame| |$declaredMode| - |$localVars| |$analyzingMapList| |$lastLineInSEQ| - |$instantCoerceCount| |$instantCanCoerceCount| - |$instantMmCondCount| |$fortVar| |$minivector| - |$minivectorCode| |$minivectorNames| |$domPvar| - |$inRetract| |$instantRecord| |$reportInstantiations| - |$ProcessInteractiveValue| |$defaultFortVar| - |$interpreterTimedNames| |$interpreterTimedClasses|)) - (RETURN - (PROGN - (|initializeTimedNames| |$interpreterTimedNames| - |$interpreterTimedClasses|) - (SPADLET |$op| - (COND - ((AND (PAIRP |form|) - (PROGN (SPADLET |op| (QCAR |form|)) 'T)) - |op|) - ('T |form|))) - (SPADLET |$Coerce| NIL) - (SPADLET |$compErrorMessageStack| NIL) - (SPADLET |$freeVars| NIL) - (SPADLET |$mapList| NIL) - (SPADLET |$compilingMap| NIL) - (SPADLET |$compilingLoop| NIL) - (SPADLET |$interpOnly| NIL) - (SPADLET |$whereCacheList| NIL) - (SPADLET |$timeGlobalName| '|$compTimeSum|) - (SPADLET |$StreamFrame| NIL) - (SPADLET |$declaredMode| NIL) - (SPADLET |$localVars| NIL) - (SPADLET |$analyzingMapList| NIL) - (SPADLET |$lastLineInSEQ| 'T) - (SPADLET |$instantCoerceCount| 0) - (SPADLET |$instantCanCoerceCount| 0) - (SPADLET |$instantMmCondCount| 0) - (SPADLET |$defaultFortVar| 'X) - (SPADLET |$fortVar| |$defaultFortVar|) - (SPADLET |$minivector| NIL) - (SPADLET |$minivectorCode| NIL) - (SPADLET |$minivectorNames| NIL) - (SPADLET |$domPvar| NIL) - (SPADLET |$inRetract| NIL) - (SPADLET |object| (|processInteractive1| |form| |posnForm|)) - (COND - ((NULL |$ProcessInteractiveValue|) - (COND - ((BOOT-EQUAL |$reportInstantiations| 'T) - (|reportInstantiations|) (CLRHASH |$instantRecord|))) - (|writeHistModesAndValues|) (|updateHist|))) - |object|)))) - -;processInteractive1(form, posnForm) == -; -- calls the analysis and output printing routines -; $e : local := $InteractiveFrame -; recordFrame 'system -; startTimingProcess 'analysis -; object := interpretTopLevel(form, posnForm) -; stopTimingProcess 'analysis -; startTimingProcess 'print -; if not($ProcessInteractiveValue) then -; recordAndPrint(objValUnwrap object,objMode object) -; recordFrame 'normal -; stopTimingProcess 'print -;--spadtestValueHook(objValUnwrap object, objMode object) -; object - -(DEFUN |processInteractive1| (|form| |posnForm|) - (PROG (|$e| |object|) - (DECLARE (SPECIAL |$e| |$ProcessInteractiveValue| |$InteractiveFrame|)) - (RETURN - (PROGN - (SPADLET |$e| |$InteractiveFrame|) - (|recordFrame| '|system|) - (|startTimingProcess| '|analysis|) - (SPADLET |object| (|interpretTopLevel| |form| |posnForm|)) - (|stopTimingProcess| '|analysis|) - (|startTimingProcess| '|print|) - (COND - ((NULL |$ProcessInteractiveValue|) - (|recordAndPrint| (|objValUnwrap| |object|) - (|objMode| |object|)))) - (|recordFrame| '|normal|) - (|stopTimingProcess| '|print|) - |object|)))) - -;--% Result Output Printing -;recordAndPrint(x,md) == -; -- Prints out the value x which is of type m, and records the changes -; -- in environment $e into $InteractiveFrame -; -- $printAnyIfTrue is documented in setvart.boot. controlled with )se me any -; if md = '(Any) and $printAnyIfTrue then -; md' := first x -; x' := rest x -; else -; x' := x -; md' := md -; $outputMode: local := md --used by DEMO BOOT -; mode:= (md=$EmptyMode => quadSch(); md) -; if (md ^= $Void) or $printVoidIfTrue then -; if null $collectOutput then TERPRI $algebraOutputStream -; if $QuietCommand = false then -; output(x',md') -; putHist('%,'value,objNewWrap(x,md),$e) -; if $printTimeIfTrue or $printTypeIfTrue then printTypeAndTime(x',md') -; if $printStorageIfTrue then printStorage() -; if $printStatisticsSummaryIfTrue then printStatisticsSummary() -; if FIXP $HTCompanionWindowID then mkCompanionPage md -; $mkTestFlag = true => recordAndPrintTest md -; $runTestFlag => -; $mkTestOutputType := md -; 'done -; 'done - -(DEFUN |recordAndPrint| (|x| |md|) - (PROG (|$outputMode| |x'| |md'| |mode|) - (DECLARE (SPECIAL |$outputMode| |$mkTestOutputType| |$runTestFlag| |$e| - |$mkTestFlag| |$HTCompanionWindowID| |$QuietCommand| - |$printStatisticsSummaryIfTrue| |$printTypeIfTrue| - |$printStorageIfTrue| |$printTimeIfTrue| |$Void| - |$algebraOutputStream| |$collectOutput| |$EmptyMode| - |$printVoidIfTrue| |$outputMode| |$printAnyIfTrue|)) - (RETURN - (PROGN - (COND - ((AND (BOOT-EQUAL |md| '(|Any|)) |$printAnyIfTrue|) - (SPADLET |md'| (CAR |x|)) (SPADLET |x'| (CDR |x|))) - ('T (SPADLET |x'| |x|) (SPADLET |md'| |md|))) - (SPADLET |$outputMode| |md|) - (SPADLET |mode| - (COND - ((BOOT-EQUAL |md| |$EmptyMode|) (|quadSch|)) - ('T |md|))) - (COND - ((OR (NEQUAL |md| |$Void|) |$printVoidIfTrue|) - (COND - ((NULL |$collectOutput|) (TERPRI |$algebraOutputStream|))) - (COND - ((NULL |$QuietCommand|) (|output| |x'| |md'|)) - ('T NIL)))) - (|putHist| '% '|value| (|objNewWrap| |x| |md|) |$e|) - (COND - ((OR |$printTimeIfTrue| |$printTypeIfTrue|) - (|printTypeAndTime| |x'| |md'|))) - (COND (|$printStorageIfTrue| (|printStorage|))) - (COND - (|$printStatisticsSummaryIfTrue| (|printStatisticsSummary|))) - (COND - ((FIXP |$HTCompanionWindowID|) (|mkCompanionPage| |md|))) - (COND - ((BOOT-EQUAL |$mkTestFlag| 'T) (|recordAndPrintTest| |md|)) - (|$runTestFlag| (SPADLET |$mkTestOutputType| |md|) '|done|) - ('T '|done|)))))) - -;printTypeAndTime(x,m) == --m is the mode/type of the result -; $saturn => printTypeAndTimeSaturn(x, m) -; printTypeAndTimeNormal(x, m) - -(DEFUN |printTypeAndTime| (|x| |m|) - (declare (special |$saturn|)) - (COND - (|$saturn| (|printTypeAndTimeSaturn| |x| |m|)) - ('T (|printTypeAndTimeNormal| |x| |m|)))) - -;printTypeAndTimeNormal(x,m) == -; -- called only if either type or time is to be displayed -; if m is ['Union, :argl] then -; x' := retract(objNewWrap(x,m)) -; m' := objMode x' -; m := ['Union, :[arg for arg in argl | sameUnionBranch(arg, m')], '"..."] -; if $printTimeIfTrue then -; timeString := makeLongTimeString($interpreterTimedNames, -; $interpreterTimedClasses) -; $printTimeIfTrue and $printTypeIfTrue => -; $collectOutput => -; $outputLines := [msgText("S2GL0012", [m]), :$outputLines] -; sayKeyedMsg("S2GL0014",[m,timeString]) -; $printTimeIfTrue => -; $collectOutput => nil -; sayKeyedMsg("S2GL0013",[timeString]) -; $printTypeIfTrue => -; $collectOutput => -; $outputLines := [justifyMyType msgText("S2GL0012", [m]), :$outputLines] -; sayKeyedMsg("S2GL0012",[m]) - -(DEFUN |printTypeAndTimeNormal| (|x| |m|) - (PROG (|argl| |x'| |m'| |timeString|) - (declare (special |$outputLines| |$collectOutput| |$printTypeIfTrue| - |$printTimeIfTrue| |$outputLines| - |$interpreterTimedNames| |$interpreterTimedClasses|)) - (RETURN - (SEQ (PROGN - (COND - ((AND (PAIRP |m|) (EQ (QCAR |m|) '|Union|) - (PROGN (SPADLET |argl| (QCDR |m|)) 'T)) - (SPADLET |x'| (|retract| (|objNewWrap| |x| |m|))) - (SPADLET |m'| (|objMode| |x'|)) - (SPADLET |m| - (CONS '|Union| - (APPEND (PROG (G166209) - (SPADLET G166209 NIL) - (RETURN - (DO - ((G166215 |argl| - (CDR G166215)) - (|arg| NIL)) - ((OR (ATOM G166215) - (PROGN - (SETQ |arg| - (CAR G166215)) - NIL)) - (NREVERSE0 G166209)) - (SEQ - (EXIT - (COND - ((|sameUnionBranch| - |arg| |m'|) - (SETQ G166209 - (CONS |arg| - G166209))))))))) - (CONS (MAKESTRING "...") NIL)))))) - (COND - (|$printTimeIfTrue| - (SPADLET |timeString| - (|makeLongTimeString| - |$interpreterTimedNames| - |$interpreterTimedClasses|)))) - (COND - ((AND |$printTimeIfTrue| |$printTypeIfTrue|) - (COND - (|$collectOutput| - (SPADLET |$outputLines| - (CONS (|msgText| 'S2GL0012 - (CONS |m| NIL)) - |$outputLines|))) - ('T - (|sayKeyedMsg| 'S2GL0014 - (CONS |m| (CONS |timeString| NIL)))))) - (|$printTimeIfTrue| - (COND - (|$collectOutput| NIL) - ('T - (|sayKeyedMsg| 'S2GL0013 (CONS |timeString| NIL))))) - (|$printTypeIfTrue| - (COND - (|$collectOutput| - (SPADLET |$outputLines| - (CONS (|justifyMyType| - (|msgText| 'S2GL0012 - (CONS |m| NIL))) - |$outputLines|))) - ('T (|sayKeyedMsg| 'S2GL0012 (CONS |m| NIL))))))))))) - -;printTypeAndTimeSaturn(x, m) == -; -- header -; if $printTimeIfTrue then -; timeString := makeLongTimeString($interpreterTimedNames, -; $interpreterTimedClasses) -; else -; timeString := '"" -; if $printTypeIfTrue then -; typeString := form2StringAsTeX devaluate m -; else -; typeString := '"" -; if $printTypeIfTrue then -; printAsTeX('"\axPrintType{") -; if CONSP typeString then -; MAPC(FUNCTION printAsTeX, typeString) -; else -; printAsTeX(typeString) -; printAsTeX('"}") -; if $printTimeIfTrue then -; printAsTeX('"\axPrintTime{") -; printAsTeX(timeString) -; printAsTeX('"}") - -(DEFUN |printTypeAndTimeSaturn| (|x| |m|) - (declare (ignore |x|)) - (PROG (|timeString| |typeString|) - (declare (special |$printTimeIfTrue| |$printTypeIfTrue| - |$interpreterTimedClasses| |$interpreterTimedNames|)) - (RETURN - (PROGN - (COND - (|$printTimeIfTrue| - (SPADLET |timeString| - (|makeLongTimeString| |$interpreterTimedNames| - |$interpreterTimedClasses|))) - ('T (SPADLET |timeString| (MAKESTRING "")))) - (COND - (|$printTypeIfTrue| - (SPADLET |typeString| - (|form2StringAsTeX| (|devaluate| |m|)))) - ('T (SPADLET |typeString| (MAKESTRING "")))) - (COND - (|$printTypeIfTrue| - (|printAsTeX| (MAKESTRING "\\axPrintType{")) - (COND - ((CONSP |typeString|) - (MAPC #'|printAsTeX| |typeString|)) - ('T (|printAsTeX| |typeString|))) - (|printAsTeX| (MAKESTRING "}")))) - (COND - (|$printTimeIfTrue| - (|printAsTeX| (MAKESTRING "\\axPrintTime{")) - (|printAsTeX| |timeString|) - (|printAsTeX| (MAKESTRING "}"))) - ('T NIL)))))) - -;printAsTeX(x) == PRINC(x, $texOutputStream) - -(DEFUN |printAsTeX| (|x|) - (declare (special |$texOutputStream|)) - (PRINC |x| |$texOutputStream|)) - -;sameUnionBranch(uArg, m) == -; uArg is [":", ., t] => t = m -; uArg = m - -(DEFUN |sameUnionBranch| (|uArg| |m|) - (PROG (|ISTMP#1| |ISTMP#2| |t|) - (RETURN - (COND - ((AND (PAIRP |uArg|) (EQ (QCAR |uArg|) '|:|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |uArg|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |t| (QCAR |ISTMP#2|)) 'T)))))) - (BOOT-EQUAL |t| |m|)) - ('T (BOOT-EQUAL |uArg| |m|)))))) - -;msgText(key, args) == -; msg := segmentKeyedMsg getKeyedMsg key -; msg := substituteSegmentedMsg(msg,args) -; msg := flowSegmentedMsg(msg,$LINELENGTH,$MARGIN) -; APPLY(function CONCAT, [STRINGIMAGE x for x in CDAR msg]) - -(DEFUN |msgText| (|key| |args|) - (PROG (|msg|) - (declare (special $LINELENGTH $MARGIN)) - (RETURN - (SEQ (PROGN - (SPADLET |msg| (|segmentKeyedMsg| (|getKeyedMsg| |key|))) - (SPADLET |msg| (|substituteSegmentedMsg| |msg| |args|)) - (SPADLET |msg| - (|flowSegmentedMsg| |msg| $LINELENGTH $MARGIN)) - (APPLY (|function| CONCAT) - (PROG (G166267) - (SPADLET G166267 NIL) - (RETURN - (DO ((G166272 (CDAR |msg|) (CDR G166272)) - (|x| NIL)) - ((OR (ATOM G166272) - (PROGN - (SETQ |x| (CAR G166272)) - NIL)) - (NREVERSE0 G166267)) - (SEQ (EXIT (SETQ G166267 - (CONS (STRINGIMAGE |x|) - G166267))))))))))))) - -;justifyMyType(t) == -; len := #t -; len > $LINELENGTH => t -; CONCAT(fillerSpaces($LINELENGTH-len), t) - -(DEFUN |justifyMyType| (|t|) - (PROG (|len|) - (declare (special $LINELENGTH)) - (RETURN - (PROGN - (SPADLET |len| (|#| |t|)) - (COND - ((> |len| $LINELENGTH) |t|) - ('T - (CONCAT (|fillerSpaces| (SPADDIFFERENCE $LINELENGTH |len|)) - |t|))))))) ;typeTimePrin x == ; $highlightDelta: local:= 0 @@ -616,39 +174,6 @@ from LISP. (RETURN (PROGN (SPADLET |$highlightDelta| 0) (|maprinSpecial| |x| 0 79))))) -;printStorage() == -; $collectOutput => nil -; storeString := -; makeLongSpaceString($interpreterTimedNames, $interpreterTimedClasses) -; sayKeyedMsg("S2GL0016",[storeString]) - -(DEFUN |printStorage| () - (PROG (|storeString|) - (declare (special |$interpreterTimedClasses| |$collectOutput| - |$interpreterTimedNames|)) - (RETURN - (COND - (|$collectOutput| NIL) - ('T - (SPADLET |storeString| - (|makeLongSpaceString| |$interpreterTimedNames| - |$interpreterTimedClasses|)) - (|sayKeyedMsg| 'S2GL0016 (CONS |storeString| NIL))))))) - -;printStatisticsSummary() == -; $collectOutput => nil -; summary := statisticsSummary() -; sayKeyedMsg("S2GL0017",[summary]) - -(DEFUN |printStatisticsSummary| () - (PROG (|summary|) - (declare (special |$collectOutput|)) - (RETURN - (COND - (|$collectOutput| NIL) - ('T (SPADLET |summary| (|statisticsSummary|)) - (|sayKeyedMsg| 'S2GL0017 (CONS |summary| NIL))))))) - ;--% Interpreter Middle-Level Driver + Utilities ;interpretTopLevel(x, posnForm) == ; -- Top level entry point from processInteractive1. Sets up catch diff --git a/src/interp/server.lisp.pamphlet b/src/interp/server.lisp.pamphlet index fe9bb0c..684241f 100644 --- a/src/interp/server.lisp.pamphlet +++ b/src/interp/server.lisp.pamphlet @@ -13,65 +13,6 @@ (IN-PACKAGE "BOOT" ) -;-- Scratchpad-II server -;-- Assoc list of interpreter frame names and unique integer identifiers -;parseAndInterpret str == -; $InteractiveMode :fluid := true -; $BOOT: fluid := NIL -; $SPAD: fluid := true -; $e:fluid := $InteractiveFrame -; $useNewParser => -; ncParseAndInterpretString str -; oldParseAndInterpret str - -(DEFUN |parseAndInterpret| (|str|) - (PROG (|$InteractiveMode| $BOOT $SPAD |$e|) - (DECLARE (SPECIAL |$InteractiveMode| $BOOT $SPAD |$e| |$useNewParser| - |$InteractiveFrame|)) - (RETURN - (PROGN - (SPADLET |$InteractiveMode| 'T) - (SPADLET $BOOT NIL) - (SPADLET $SPAD 'T) - (SPADLET |$e| |$InteractiveFrame|) - (COND - (|$useNewParser| (|ncParseAndInterpretString| |str|)) - ('T (|oldParseAndInterpret| |str|))))))) - -;oldParseAndInterpret str == -; tree := string2SpadTree str -; tree => processInteractive(parseTransform postTransform tree, NIL) -; NIL - -(DEFUN |oldParseAndInterpret| (|str|) - (PROG (|tree|) - (RETURN - (PROGN - (SPADLET |tree| (|string2SpadTree| |str|)) - (COND - (|tree| (|processInteractive| - (|parseTransform| (|postTransform| |tree|)) NIL)) - ('T NIL)))))) - -;executeQuietCommand() == -; $QuietCommand: fluid := true -; stringBuf := MAKE_-STRING 512 -; sockGetString($MenuServer, stringBuf, 512) -; CATCH('coerceFailure,CATCH('top__level, CATCH('SPAD__READER, -; parseAndInterpret stringBuf))) - -(DEFUN |executeQuietCommand| () - (PROG (|$QuietCommand| |stringBuf|) - (DECLARE (SPECIAL |$QuietCommand| |$MenuServer|)) - (RETURN - (PROGN - (SPADLET |$QuietCommand| 'T) - (SPADLET |stringBuf| (MAKE-STRING 512)) - (|sockGetString| |$MenuServer| |stringBuf| 512) - (CATCH '|coerceFailure| - (CATCH '|top_level| - (CATCH 'SPAD_READER (|parseAndInterpret| |stringBuf|)))))))) - ;-- Includued for compatability with old-parser systems ;serverLoop() == ; IN_-STREAM: fluid := CURINSTREAM @@ -333,29 +274,6 @@ (|doSystemCommand| (SUBSEQ |string| 1))) ('T (|processInteractive| (|ncParseFromString| |string|) NIL)))) -;protectedEVAL x == -; error := true -; val := NIL -; UNWIND_-PROTECT((val := EVAL x; error := NIL), -; error => (resetStackLimits(); sendHTErrorSignal())) -; val - -(DEFUN |protectedEVAL| (|x|) - (PROG (|val| |error|) - (RETURN - (SEQ (PROGN - (SPADLET |error| 'T) - (SPADLET |val| NIL) - (SEQ (UNWIND-PROTECT - (PROGN - (SPADLET |val| (EVAL |x|)) - (SPADLET |error| NIL)) - (COND - (|error| (EXIT (PROGN - (|resetStackLimits|) - (|sendHTErrorSignal|)))))) - (EXIT |val|))))))) - @ \eject \begin{thebibliography}{99}