diff options
Diffstat (limited to 'src/interp/i-intern.boot.pamphlet')
| -rw-r--r-- | src/interp/i-intern.boot.pamphlet | 818 |
1 files changed, 818 insertions, 0 deletions
diff --git a/src/interp/i-intern.boot.pamphlet b/src/interp/i-intern.boot.pamphlet new file mode 100644 index 00000000..144aa0e5 --- /dev/null +++ b/src/interp/i-intern.boot.pamphlet @@ -0,0 +1,818 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp i-intern.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\begin{verbatim} +Internal Interpreter Facilities + +Vectorized Attributed Trees + +The interpreter translates parse forms into vats for analysis. +These contain a number of slots in each node for information. +The leaves are now all vectors, though the leaves for basic types +such as integers and strings used to just be the objects themselves. +The vectors for the leaves with such constants now have the value +of $immediateDataSymbol as their name. Their are undoubtably still +some functions that still check whether a leaf is a constant. Note +that if it is not a vector it is a subtree. + +attributed tree nodes have the following form: +slot description +---- ----------------------------------------------------- + 0 operation name or literal + 1 declared mode of variable + 2 computed value of subtree from this node + 3 modeset: list of single computed mode of subtree + 4 prop list for extra things + +\end{verbatim} +\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>> + +SETANDFILEQ($useParserSrcPos, NIL) +SETANDFILEQ($transferParserSrcPos, NIL) + +-- Making Trees + +mkAtreeNode x == + -- maker of attrib tree node + v := MAKE_-VEC 5 + v.0 := x + v + +mkAtree x == + -- maker of attrib tree from parser form + mkAtree1 mkAtreeExpandMacros x + +mkAtreeWithSrcPos(form, posnForm) == + posnForm and $useParserSrcPos => pf2Atree(posnForm) + transferSrcPosInfo(posnForm, mkAtree form) + +mkAtree1WithSrcPos(form, posnForm) == + transferSrcPosInfo(posnForm, mkAtree1 form) + +mkAtreeNodeWithSrcPos(form, posnForm) == + transferSrcPosInfo(posnForm, mkAtreeNode form) + +transferSrcPosInfo(pf, atree) == + not (pf and $transferParserSrcPos) => atree + pos := pfPosOrNopos(pf) + pfNoPosition?(pos) => atree + + -- following is a hack because parser code for getting filename + -- seems wrong. + fn := lnPlaceOfOrigin poGetLineObject(pos) + if NULL fn or fn = '"strings" then fn := '"console" + + putSrcPos(atree, fn, pfSourceText(pf), pfLinePosn(pos), pfCharPosn(pos)) + atree + +mkAtreeExpandMacros x == + -- handle macro expansion. if the macros have args we require that + -- we match the correct number of args + if x isnt ['MDEF,:.] and x isnt ['DEF,['macro,:.],:.] then + atom x and (m := isInterpMacro x) => + [args,:body] := m + args => 'doNothing + x := body + x is [op,:argl] => + op = 'QUOTE => 'doNothing + op = 'where and argl is [before,after] => + -- in a where clause, what follows "where" (the "after" parm + -- above) might be a local macro, so do not expand the "before" + -- part yet + x := [op,before,mkAtreeExpandMacros after] + argl := [mkAtreeExpandMacros a for a in argl] + (m := isInterpMacro op) => + [args,:body] := m + #args = #argl => + sl := [[a,:s] for a in args for s in argl] + x := SUBLISNQ(sl,body) + null args => x := [body,:argl] + x := [op,:argl] + x := [mkAtreeExpandMacros op,:argl] + x + +mkAtree1 x == + -- first special handler for making attrib tree + null x => throwKeyedMsg("S2IP0005",['"NIL"]) + VECP x => x + atom x => + x in '(noBranch noMapVal) => x + x in '(nil true false) => mkAtree2([x],x,NIL) + x = '_/throwAway => + -- don't want to actually compute this + tree := mkAtree1 '(void) + putValue(tree,objNewWrap(voidValue(),$Void)) + putModeSet(tree,[$Void]) + tree + getBasicMode x => + v := mkAtreeNode $immediateDataSymbol + putValue(v,getBasicObject x) + v + IDENTP x => mkAtreeNode x + keyedSystemError("S2II0002",[x]) + x is [op,:argl] => mkAtree2(x,op,argl) + systemErrorHere '"mkAtree1" + +-- mkAtree2 and mkAtree3 were created because mkAtree1 got so big + +mkAtree2(x,op,argl) == + nargl := #argl + (op= '_-) and (nargl = 1) and (INTEGERP CAR argl) => + mkAtree1(MINUS CAR argl) + op='_: and argl is [y,z] => [mkAtreeNode 'Declare,:argl] + op='COLLECT => [mkAtreeNode op,:transformCollect argl] + op= 'break => + argl is [.,val] => + if val = '$NoValue then val := '(void) + [mkAtreeNode op,mkAtree1 val] + [mkAtreeNode op,mkAtree1 '(void)] + op= 'return => + argl is [val] => + if val = '$NoValue then val := '(void) + [mkAtreeNode op,mkAtree1 val] + [mkAtreeNode op,mkAtree1 '(void)] + op='exit => mkAtree1 CADR argl + op = 'QUOTE => [mkAtreeNode op,:argl] + op='SEGMENT => + argl is [a] => [mkAtreeNode op, mkAtree1 a] + z := + null argl.1 => nil + mkAtree1 argl.1 + [mkAtreeNode op, mkAtree1 argl.0,z] + op in '(pretend is isnt) => + [mkAtreeNode op,mkAtree1 first argl,:rest argl] + op = '_:_: => + [mkAtreeNode 'COERCE,mkAtree1 first argl,CADR argl] + x is ['_@, expr, type] => + t := evaluateType unabbrev type + t = '(DoubleFloat) and expr is [['_$elt, '(Float), 'float], :args] => + mkAtree1 [['_$elt, '(DoubleFloat), 'float], :args] + t = '(DoubleFloat) and INTEGERP expr => + v := mkAtreeNode $immediateDataSymbol + putValue(v,getBasicObject float expr) + v + t = '(Float) and INTEGERP expr => + mkAtree1 ["::", expr, t] + typeIsASmallInteger(t) and INTEGERP expr => + mkAtree1 ["::", expr, t] + [mkAtreeNode 'TARGET,mkAtree1 expr, type] + (op='case) and (nargl = 2) => + [mkAtreeNode 'case,mkAtree1 first argl,unabbrev CADR argl] + op='REPEAT => [mkAtreeNode op,:transformREPEAT argl] + op='LET and argl is [['construct,:.],rhs] => + [mkAtreeNode 'LET,first argl,mkAtree1 rhs] + op='LET and argl is [['_:,a,.],rhs] => + mkAtree1 ['SEQ,first argl,['LET,a,rhs]] + op is ['_$elt,D,op1] => + op1 is '_= => + a' := [mkAtreeNode '_=,:[mkAtree1 arg for arg in argl]] + [mkAtreeNode 'Dollar,D,a'] + [mkAtreeNode 'Dollar,D,mkAtree1 [op1,:argl]] + op='_$elt => + argl is [D,a] => + INTEGERP a => + a = 0 => mkAtree1 [['_$elt,D,'Zero]] + a = 1 => mkAtree1 [['_$elt,D,'One]] + t := evaluateType unabbrev [D] + typeIsASmallInteger(t) and SINTP a => + v := mkAtreeNode $immediateDataSymbol + putValue(v,mkObjWrap(a, t)) + v + mkAtree1 ["*",a,[['_$elt,D,'One]]] + [mkAtreeNode 'Dollar,D,mkAtree1 a] + keyedSystemError("S2II0003",['"$",argl, + '"not qualifying an operator"]) + mkAtree3(x,op,argl) + +mkAtree3(x,op,argl) == + op='REDUCE and argl is [op1,axis,body] => + [mkAtreeNode op,axis,mkAtree1 op1,mkAtree1 body] + op='has => [mkAtreeNode op, :argl] + op='_| => [mkAtreeNode 'AlgExtension,:[mkAtree1 arg for arg in argl]] + op='_= => [mkAtreeNode 'equation,:[mkAtree1 arg for arg in argl]] + op='not and argl is [["=",lhs,rhs]] => + [mkAtreeNode 'not,[mkAtreeNode "=",mkAtree1 lhs,mkAtree1 rhs]] + op='in and argl is [var ,['SEGMENT,lb,ul]] => + upTest:= + null ul => NIL + mkLessOrEqual(var,ul) + lowTest:=mkLessOrEqual(lb,var) + z := + ul => ['and,lowTest,upTest] + lowTest + mkAtree1 z + x is ['IF,p,'noBranch,a] => mkAtree1 ['IF,['not,p],a,'noBranch] + x is ['RULEDEF,:.] => [mkAtreeNode 'RULEDEF,:CDR x] + x is ['MDEF,sym,junk1,junk2,val] => + -- new macros look like macro f == or macro f(x) === + -- so transform into that format + mkAtree1 ['DEF,['macro,sym],junk1,junk2,val] + x is ["~=",a,b] => mkAtree1 ['not,["=",a,b]] + x is ["+->",funargs,funbody] => + if funbody is [":",body,type] then + types := [type] + funbody := body + else types := [NIL] + v := collectDefTypesAndPreds funargs + types := [:types,:v.1] + [mkAtreeNode 'ADEF,[v.0,types,[NIL for a in types],funbody], + if v.2 then v.2 else true, false] + x is ['ADEF,arg,:r] => + r := mkAtreeValueOf r + v := + null arg => VECTOR(NIL,NIL,NIL) + PAIRP arg and rest arg and first arg^= "|" => + collectDefTypesAndPreds ['Tuple,:arg] + null rest arg => collectDefTypesAndPreds first arg + collectDefTypesAndPreds arg + [types,:r'] := r + at := [fn(x,y) for x in rest types for y in v.1] where + fn(a,b) == + a and b => + if a = b then a + else throwMessage '" double declaration of parameter" + a or b + r := [[first types,:at],:r'] + [mkAtreeNode 'ADEF,[v.0,:r],if v.2 then v.2 else true,false] + x is ['where,before,after] => + [mkAtreeNode 'where,before,mkAtree1 after] + x is ['DEF,['macro,form],.,.,body] => + [mkAtreeNode 'MDEF,form,body] + x is ['DEF,a,:r] => + r := mkAtreeValueOf r + a is [op,:arg] => + v := + null arg => VECTOR(NIL,NIL,NIL) + PAIRP arg and rest arg and first arg^= "|" => + collectDefTypesAndPreds ['Tuple,:arg] + null rest arg => collectDefTypesAndPreds first arg + collectDefTypesAndPreds arg + [types,:r'] := r + -- see case for ADEF above for defn of fn + at := [fn(x,y) for x in rest types for y in v.1] + r := [[first types,:at],:r'] + [mkAtreeNode 'DEF,[[op,:v.0],:r],if v.2 then v.2 else true,false] + [mkAtreeNode 'DEF,[a,:r],true,false] +--x is ['when,y,pred] => +-- y isnt ['DEF,a,:r] => +-- keyedSystemError("S2II0003",['"when",y,'"improper argument form"]) +-- a is [op,p1,:pr] => +-- null pr => mkAtree1 ['DEF,[op,["|",p1,pred]],:r] +-- mkAtree1 ['DEF,[op,["|",['Tuple,p1,:pr],pred]],:r] +-- [mkAtreeNode 'DEF, CDR y,pred,false] +--x is ['otherwise,u] => +-- throwMessage '" otherwise is no longer supported." + z := + getBasicMode op => + v := mkAtreeNode $immediateDataSymbol + putValue(v,getBasicObject op) + v + atom op => mkAtreeNode op + mkAtree1 op + [z,:[mkAtree1 y for y in argl]] + +collectDefTypesAndPreds args == + -- given an arglist to a DEF-like form, this function returns + -- a vector of three things: + -- slot 0: just the variables + -- slot 1: the type declarations on the variables + -- slot 2: a predicate for all arguments + pred := types := vars := NIL + junk := + IDENTP args => + types := [NIL] + vars := [args] + args is [":",var,type] => + types := [type] + var is ["|",var',p] => + vars := [var'] + pred := addPred(pred,p) where + addPred(old,new) == + null new => old + null old => new + ['and,old,new] + vars := [var] + args is ["|",var,p] => + pred := addPred(pred,p) + var is [":",var',type] => + types := [type] + vars := [var'] + var is ['Tuple,:.] or var is ["|",:.] => + v := collectDefTypesAndPreds var + vars := [:vars,:v.0] + types := [:types,:v.1] + pred := addPred(pred,v.2) + vars := [var] + types := [NIL] + args is ['Tuple,:args'] => + for a in args' repeat + v := collectDefTypesAndPreds a + vars := [:vars,first v.0] + types := [:types,first v.1] + pred := addPred(pred,v.2) + types := [NIL] + vars := [args] + VECTOR(vars,types,pred) + +mkAtreeValueOf l == + -- scans for ['valueOf,atom] + not CONTAINED('valueOf,l) => l + mkAtreeValueOf1 l + +mkAtreeValueOf1 l == + null l or atom l or null rest l => l + l is ['valueOf,u] and IDENTP u => + v := mkAtreeNode $immediateDataSymbol + putValue(v,get(u,'value,$InteractiveFrame) or + objNewWrap(u,['Variable,u])) + v + [mkAtreeValueOf1 x for x in l] + +mkLessOrEqual(lhs,rhs) == ['not,['_<,rhs,lhs]] + +emptyAtree expr == + -- remove mode, value, and misc. info from attrib tree + VECP expr => + $immediateDataSymbol = expr.0 => nil + expr.1:= NIL + expr.2:= NIL + expr.3:= NIL + -- kill proplist too? + atom expr => nil + for e in expr repeat emptyAtree e + +unVectorize body == + -- transforms from an atree back into a tree + VECP body => + name := getUnname body + name ^= $immediateDataSymbol => name + objValUnwrap getValue body + atom body => body + body is [op,:argl] => + newOp:=unVectorize op + if newOp = 'SUCHTHAT then newOp := '_| + if newOp = 'COERCE then newOp := '_:_: + if newOp = 'Dollar then newOp := "$elt" + [newOp,:unVectorize argl] + systemErrorHere '"unVectorize" + + +-- Stuffing and Getting Info + +putAtree(x,prop,val) == + x is [op,:.] => + -- only willing to add property if op is a vector + -- otherwise will be pushing to deeply into calling structure + if VECP op then putAtree(op,prop,val) + x + null VECP x => x -- just ignore it + n := QLASSQ(prop,'((mode . 1) (value . 2) (modeSet . 3))) + => x.n := val + x.4 := insertShortAlist(prop,val,x.4) + x + +getAtree(x,prop) == + x is [op,:.] => + -- only willing to get property if op is a vector + -- otherwise will be pushing to deeply into calling structure + VECP op => getAtree(op,prop) + NIL + null VECP x => NIL -- just ignore it + n:= QLASSQ(prop,'((mode . 1) (value . 2) (modeSet . 3))) + => x.n + QLASSQ(prop,x.4) + +putTarget(x, targ) == + -- want to put nil modes perhaps to clear old target + if targ = $EmptyMode then targ := nil + putAtree(x,'target,targ) + +getTarget(x) == getAtree(x,'target) + +insertShortAlist(prop,val,al) == + pair := QASSQ(prop,al) => + RPLACD(pair,val) + al + [[prop,:val],:al] + +transferPropsToNode(x,t) == + propList := getProplist(x,$env) + QLASSQ('Led,propList) or QLASSQ('Nud,propList) => nil + node := + VECP t => t + first t + for prop in '(mode localModemap value name generatedCode) + repeat transfer(x,node,prop) + where + transfer(x,node,prop) == + u := get(x,prop,$env) => putAtree(node,prop,u) + (not (x in $localVars)) and (u := get(x,prop,$e)) => + putAtree(node,prop,u) + if not getMode(t) and (am := get(x,'automode,$env)) then + putModeSet(t,[am]) + putMode(t,am) + t + +isLeaf x == atom x --may be a number or a vector + +getMode x == + x is [op,:.] => getMode op + VECP x => x.1 + m := getBasicMode x => m + keyedSystemError("S2II0001",[x]) + +putMode(x,y) == + x is [op,:.] => putMode(op,y) + null VECP x => keyedSystemError("S2II0001",[x]) + x.1 := y + +getValue x == + VECP x => x.2 + atom x => + t := getBasicObject x => t + keyedSystemError("S2II0001",[x]) + getValue first x + +putValue(x,y) == + x is [op,:.] => putValue(op,y) + null VECP x => keyedSystemError("S2II0001",[x]) + x.2 := y + +putValueValue(vec,val) == + putValue(vec,val) + vec + +getUnnameIfCan x == + VECP x => x.0 + x is [op,:.] => getUnnameIfCan op + atom x => x + nil + +getUnname x == + x is [op,:.] => getUnname op + getUnname1 x + +getUnname1 x == + VECP x => x.0 + null atom x => keyedSystemError("S2II0001",[x]) + x + +computedMode t == + getModeSet t is [m] => m + keyedSystemError("S2GE0016",['"computedMode",'"non-singleton modeset"]) + +putModeSet(x,y) == + x is [op,:.] => putModeSet(op,y) + not VECP x => keyedSystemError("S2II0001",[x]) + x.3 := y + y + +getModeOrFirstModeSetIfThere x == + x is [op,:.] => getModeOrFirstModeSetIfThere op + VECP x => + m := x.1 => m + val := x.2 => objMode val + y := x.aModeSet => + (y = [$EmptyMode]) and ((m := getMode x) is ['Mapping,:.]) => m + first y + NIL + m := getBasicMode x => m + NIL + +getModeSet x == + x and PAIRP x => getModeSet first x + VECP x => + y:= x.aModeSet => + (y = [$EmptyMode]) and ((m := getMode x) is ['Mapping,:.]) => + [m] + y + keyedSystemError("S2GE0016",['"getModeSet",'"no mode set"]) + m:= getBasicMode x => [m] + null atom x => getModeSet first x + keyedSystemError("S2GE0016",['"getModeSet", + '"not an attributed tree"]) + +getModeSetUseSubdomain x == + x and PAIRP x => getModeSetUseSubdomain first x + VECP(x) => + -- don't play subdomain games with retracted args + getAtree(x,'retracted) => getModeSet x + y := x.aModeSet => + (y = [$EmptyMode]) and ((m := getMode x) is ['Mapping,:.]) => + [m] + val := getValue x + (x.0 = $immediateDataSymbol) and (y = [$Integer]) => + val := objValUnwrap val + m := getBasicMode0(val,true) + x.2 := objNewWrap(val,m) + x.aModeSet := [m] + [m] + null val => y + isEqualOrSubDomain(objMode(val),$Integer) and + INTEGERP(f := objValUnwrap val) => + [getBasicMode0(f,true)] + y + keyedSystemError("S2GE0016", + ['"getModeSetUseSubomain",'"no mode set"]) + m := getBasicMode0(x,true) => [m] + null atom x => getModeSetUseSubdomain first x + keyedSystemError("S2GE0016", + ['"getModeSetUseSubomain",'"not an attributed tree"]) + +atree2EvaluatedTree x == atree2Tree1(x,true) + +atree2Tree1(x,evalIfTrue) == + (triple := getValue x) and objMode(triple) ^= $EmptyMode => + coerceOrCroak(triple,$OutputForm,$mapName) + isLeaf x => + VECP x => x.0 + x + [atree2Tree1(y,evalIfTrue) for y in x] + +--% Environment Utilities + +-- getValueFromEnvironment(x,mode) == +-- $failure ^= (v := getValueFromSpecificEnvironment(x,mode,$env)) => v +-- $failure ^= (v := getValueFromSpecificEnvironment(x,mode,$e)) => v +-- throwKeyedMsg("S2IE0001",[x]) +getValueFromEnvironment(x,mode) == + $failure ^= (v := getValueFromSpecificEnvironment(x,mode,$env)) => v + $failure ^= (v := getValueFromSpecificEnvironment(x,mode,$e)) => v + null(v := coerceInt(objNew(x, ['Variable, x]), mode)) => + throwKeyedMsg("S2IE0001",[x]) + objValUnwrap v + +getValueFromSpecificEnvironment(id,mode,e) == + PAIRP e => + u := get(id,'value,e) => + objMode(u) = $EmptyMode => + systemErrorHere '"getValueFromSpecificEnvironment" + v := objValUnwrap u + mode isnt ['Mapping,:mapSig] => v + v isnt ['MAP,:.] => v + v' := coerceInt(u,mode) + null v' => throwKeyedMsg("S2IC0002",[objMode u,mode]) + objValUnwrap v' + + m := get(id,'mode,e) => + -- See if we can make it into declared mode from symbolic form + -- For example, (x : P[x] I; x + 1) + if isPartialMode(m) then m' := resolveTM(['Variable,id],m) + else m' := m + m' and + (u := coerceInteractive(objNewWrap(id,['Variable,id]),m')) => + objValUnwrap u + + throwKeyedMsg("S2IE0002",[id,m]) + $failure + $failure + +addBindingInteractive(var,proplist,e is [[curContour,:.],:.]) == + -- change proplist of var in e destructively + u := ASSQ(var,curContour) => + RPLACD(u,proplist) + e + RPLAC(CAAR e,[[var,:proplist],:curContour]) + e + +augProplistInteractive(proplist,prop,val) == + u := ASSQ(prop,proplist) => + RPLACD(u,val) + proplist + [[prop,:val],:proplist] + +getFlag x == get("--flags--",x,$e) + +putFlag(flag,value) == + $e := put ("--flags--", flag, value, $e) + +get(x,prop,e) == + $InteractiveMode => get0(x,prop,e) + get1(x,prop,e) + +get0(x,prop,e) == + null atom x => get(QCAR x,prop,e) + u:= QLASSQ(x,CAR QCAR e) => QLASSQ(prop,u) + (tail:= CDR QCAR e) and (u:= fastSearchCurrentEnv(x,tail)) => + QLASSQ(prop,u) + nil + +get1(x,prop,e) == + --this is the old get + null atom x => get(QCAR x,prop,e) + prop="modemap" and $insideCapsuleFunctionIfTrue=true => + LASSOC("modemap",getProplist(x,$CapsuleModemapFrame)) + or get2(x,prop,e) + LASSOC(prop,getProplist(x,e)) or get2(x,prop,e) + +get2(x,prop,e) == + prop="modemap" and constructor? x => + (u := getConstructorModemap(x)) => [u] + nil + nil + +getI(x,prop) == get(x,prop,$InteractiveFrame) + +putI(x,prop,val) == ($InteractiveFrame := put(x,prop,val,$InteractiveFrame)) + +getIProplist x == getProplist(x,$InteractiveFrame) + +removeBindingI x == + RPLAC(CAAR $InteractiveFrame,deleteAssocWOC(x,CAAR $InteractiveFrame)) + +rempropI(x,prop) == + id:= + atom x => x + first x + getI(id,prop) => + recordNewValue(id,prop,NIL) + recordOldValue(id,prop,getI(id,prop)) + $InteractiveFrame:= remprop(id,prop,$InteractiveFrame) + +remprop(x,prop,e) == + u:= ASSOC(prop,pl:= getProplist(x,e)) => + e:= addBinding(x,DELASC(first u,pl),e) + e + e + +fastSearchCurrentEnv(x,currentEnv) == + u:= QLASSQ(x,CAR currentEnv) => u + while (currentEnv:= QCDR currentEnv) repeat + u:= QLASSQ(x,CAR currentEnv) => u + +put(x,prop,val,e) == + $InteractiveMode and not EQ(e,$CategoryFrame) => + putIntSymTab(x,prop,val,e) + --e must never be $CapsuleModemapFrame + null atom x => put(first x,prop,val,e) + newProplist:= augProplistOf(x,prop,val,e) + prop="modemap" and $insideCapsuleFunctionIfTrue=true => + SAY ["**** modemap PUT on CapsuleModemapFrame: ",val] + $CapsuleModemapFrame:= + addBinding(x,augProplistOf(x,"modemap",val,$CapsuleModemapFrame), + $CapsuleModemapFrame) + e + addBinding(x,newProplist,e) + +putIntSymTab(x,prop,val,e) == + null atom x => putIntSymTab(first x,prop,val,e) + pl0 := pl := search(x,e) + pl := + null pl => [[prop,:val]] + u := ASSQ(prop,pl) => + RPLACD(u,val) + pl + lp := LASTPAIR pl + u := [[prop,:val]] + RPLACD(lp,u) + pl + EQ(pl0,pl) => e + addIntSymTabBinding(x,pl,e) + +addIntSymTabBinding(var,proplist,e is [[curContour,:.],:.]) == + -- change proplist of var in e destructively + u := ASSQ(var,curContour) => + RPLACD(u,proplist) + e + RPLAC(CAAR e,[[var,:proplist],:curContour]) + e + + +--% Source and position information + +-- In the following, src is a string containing an original input line, +-- line is the line number of the string within the source file, +-- and col is the index within src of the start of the form represented +-- by x. x is a VAT. + +putSrcPos(x, file, src, line, col) == + putAtree(x, 'srcAndPos, srcPos_New(file, src, line, col)) + +getSrcPos(x) == getAtree(x, 'srcAndPos) + +srcPosNew(file, src, line, col) == LIST2VEC [file, src, line, col] + +srcPosFile(sp) == + if sp then sp.0 else nil + +srcPosSource(sp) == + if sp then sp.1 else nil + +srcPosLine(sp) == + if sp then sp.2 else nil + +srcPosColumn(sp) == + if sp then sp.3 else nil + +srcPosDisplay(sp) == + null sp => nil + s := STRCONC('"_"", srcPosFile sp, '"_", line ", + STRINGIMAGE srcPosLine sp, '": ") + sayBrightly [s, srcPosSource sp] + col := srcPosColumn sp + dots := + col = 0 => '"" + fillerSpaces(col, '".") + sayBrightly [fillerSpaces(#s, '" "), dots, '"^"] + true + +--% Functions on interpreter objects + +-- Interpreter objects used to be called triples because they had the +-- structure [value, type, environment]. For many years, the environment +-- was not used, so finally in January, 1990, the structure of objects +-- was changed to be (type . value). This was chosen because it was the +-- structure of objects of type Any. Sometimes the values are wrapped +-- (see the function isWrapped to see what this means physically). +-- Wrapped values are not actual values belonging to their types. An +-- unwrapped value must be evaluated to get an actual value. A wrapped +-- value must be unwrapped before being passed to a library function. +-- Typically, an unwrapped value in the interpreter consists of LISP +-- code, e.g., parts of a function that is being constructed. +-- RSS 1/14/90 + +-- These are the new structure functions. + +mkObj(val, mode) == CONS(mode,val) -- old names +mkObjWrap(val, mode) == CONS(mode,wrap val) +mkObjCode(val, mode) == ['CONS, MKQ mode,val ] + +objNew(val, mode) == CONS(mode,val) -- new names as of 10/14/93 +objNewWrap(val, mode) == CONS(mode,wrap val) +objNewCode(val, mode) == ['CONS, MKQ mode,val ] +objSetVal(obj,val) == RPLACD(obj,val) +objSetMode(obj,mode) == RPLACA(obj,mode) + +objVal obj == CDR obj +objValUnwrap obj == unwrap CDR obj +objMode obj == CAR obj +objEnv obj == $NE + +objCodeVal obj == CADDR obj +objCodeMode obj == CADR obj + + + + +--% Library compiler structures needed by the interpreter + +-- Tuples and Crosses + +asTupleNew(size, listOfElts) == CONS(size, LIST2VEC listOfElts) +asTupleNew0(listOfElts) == CONS(#listOfElts, LIST2VEC listOfElts) + +asTupleNewCode(size, listOfElts) == ["asTupleNew", size, ['LIST, :listOfElts]] +asTupleNewCode0(listForm) == ["asTupleNew0", listForm] + +asTupleSize(at) == CAR at +asTupleAsVector(at) == CDR at +asTupleAsList(at) == VEC2LIST asTupleAsVector at +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} |