From ab8cc85adde879fb963c94d15675783f2cf4b183 Mon Sep 17 00:00:00 2001 From: dos-reis Date: Tue, 14 Aug 2007 05:14:52 +0000 Subject: Initial population. --- src/interp/i-toplev.boot.pamphlet | 360 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 360 insertions(+) create mode 100644 src/interp/i-toplev.boot.pamphlet (limited to 'src/interp/i-toplev.boot.pamphlet') diff --git a/src/interp/i-toplev.boot.pamphlet b/src/interp/i-toplev.boot.pamphlet new file mode 100644 index 00000000..665c6371 --- /dev/null +++ b/src/interp/i-toplev.boot.pamphlet @@ -0,0 +1,360 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp i-toplev.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\begin{verbatim} +This file contains the top-most code for receiving parser output, +calling the analysis routines and printing the result output. It +also contains several flavors of routines that start the interpreter +from LISP. +\end{verbatim} +\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. + +@ +<<*>>= +<> + +--% Top Level Interpreter Code + +-- When $QuiteCommand is true Spad will not produce any output from +-- a top level command +SETANDFILEQ($QuietCommand, NIL) +-- When $ProcessInteractiveValue is true, we don't want the value printed +-- or recorded. +SETANDFILEQ($ProcessInteractiveValue, NIL) +SETANDFILEQ($HTCompanionWindowID, NIL) + +--% Starting the interpreter from LISP + +spadpo() == + -- starts the interpreter but only displays parsed input + $PrintOnly: local:= true + spad() + +start(:l) == + -- The function start begins the interpreter process, reading in + -- the profile and printing start-up messages. + $PrintCompilerMessageIfTrue: local + $inLispVM : local := nil + if $displayStartMsgs then sayKeyedMsg("S2IZ0053",['"interpreter"]) + initializeTimedNames($interpreterTimedNames,$interpreterTimedClasses) + statisticsInitialization() + $InteractiveFrame := makeInitialModemapFrame() + initializeSystemCommands() + initializeInterpreterFrameRing() + SETQ(ERROROUTSTREAM, + DEFIOSTREAM('((DEVICE . CONSOLE)(MODE . OUTPUT)),80,0)) + setOutputAlgebra "%initialize%" + loadExposureGroupData() + if $displayStartMsgs then sayKeyedMsg("S2IZ0053",['"database"]) + mkLowerCaseConTable() + if not $ruleSetsInitialized then initializeRuleSets() + if $displayStartMsgs then sayKeyedMsg("S2IZ0053",['"constructors"]) + makeConstructorsAutoLoad() + GCMSG(NIL) + SETQ($IOindex,1) + if $displayStartMsgs then sayKeyedMsg("S2IZ0053",['"history"]) + initHist() + if functionp 'addtopath then addtopath CONCAT($SPADROOT,'"bin") + SETQ($CURRENT_-DIRECTORY,_*DEFAULT_-PATHNAME_-DEFAULTS_*) + if null(l) then + if $displayStartMsgs then + sayKeyedMsg("S2IZ0053",[namestring ['_.axiom,'input]]) + readSpadProfileIfThere() + if $displayStartMsgs then spadStartUpMsgs() + if $OLDLINE then + SAY fillerSpaces($LINELENGTH,'"=") + sayKeyedMsg("S2IZ0050",[namestring ['axiom,'input]]) + if $OLDLINE ^= 'END__UNIT + then + centerAndHighlight($OLDLINE,$LINELENGTH,'" ") + sayKeyedMsg("S2IZ0051",NIL) + else sayKeyedMsg("S2IZ0052",NIL) + SAY fillerSpaces($LINELENGTH,'"=") + TERPRI() + $OLDLINE := NIL + $superHash := MAKE_-HASHTABLE('UEQUAL) + if null l then runspad() + 'EndOfSpad + +readSpadProfileIfThere() == + -- reads SPADPROF INPUT if it exists + file := ['_.axiom,'input] + MAKE_-INPUT_-FILENAME file => + SETQ(_/EDITFILE,file) + _/RQ () + NIL + +--% 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 + $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 + +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 + +--% 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 + +printTypeAndTime(x,m) == --m is the mode/type of the result + $saturn => printTypeAndTimeSaturn(x, m) + 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]) + +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('"}") + +printAsTeX(x) == PRINC(x, $texOutputStream) + +sameUnionBranch(uArg, m) == + uArg is [":", ., t] => t = m + 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]) + +justifyMyType(t) == + len := #t + len > $LINELENGTH => t + CONCAT(fillerSpaces($LINELENGTH-len), t) + +typeTimePrin x == + $highlightDelta: local:= 0 + maprinSpecial(x,0,79) + +printStorage() == + $collectOutput => nil + storeString := + makeLongSpaceString($interpreterTimedNames, $interpreterTimedClasses) + sayKeyedMsg("S2GL0016",[storeString]) + +printStatisticsSummary() == + $collectOutput => nil + summary := statisticsSummary() + sayKeyedMsg("S2GL0017",[summary]) + +--% Interpreter Middle-Level Driver + Utilities + +interpretTopLevel(x, posnForm) == + -- Top level entry point from processInteractive1. Sets up catch + -- for a thrown result + savedTimerStack := COPY $timedNameStack + c := CATCH('interpreter,interpret(x, posnForm)) + while savedTimerStack ^= $timedNameStack repeat + stopTimingProcess peekTimedName() + c = 'tryAgain => interpretTopLevel(x, posnForm) + c + +interpret(x, :restargs) == + posnForm := if PAIRP restargs then CAR restargs else restargs + --type analyzes and evaluates expression x, returns object + $env:local := [[NIL]] + $eval:local := true --generate code-- don't just type analyze + $genValue:local := true --evaluate all generated code + interpret1(x,nil,posnForm) + +interpret1(x,rootMode,posnForm) == + -- dispatcher for the type analysis routines. type analyzes and + -- evaluates the expression x in the rootMode (if non-nil) + -- which may be $EmptyMode. returns an object if evaluating, and a + -- modeset otherwise + + -- create the attributed tree + + node := mkAtreeWithSrcPos(x, posnForm) + if rootMode then putTarget(node,rootMode) + + -- do type analysis and evaluation of expression. The real guts + + modeSet:= bottomUp node + not $eval => modeSet + newRootMode := (null rootMode => first modeSet ; rootMode) + argVal := getArgValue(node, newRootMode) + argVal and not $genValue => objNew(argVal, newRootMode) + argVal and (val:=getValue node) => interpret2(val,newRootMode,posnForm) + keyedSystemError("S2IS0053",[x]) + +interpret2(object,m1,posnForm) == + -- this is the late interpretCoerce. I removed the call to + -- coerceInteractive, so it only does the JENKS cases ALBI + m1=$ThrowAwayMode => object + x := objVal object + m := objMode object + m=$EmptyMode => + x is [op,:.] and op in '(MAP STREAM) => objNew(x,m1) + m1 = $EmptyMode => objNew(x,m) + systemErrorHere '"interpret2" + m1 => + if (ans := coerceInteractive(object,m1)) then ans + else throwKeyedMsgCannotCoerceWithValue(x,m,m1) + object +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} -- cgit v1.2.3