diff options
Diffstat (limited to 'src/interp')
-rw-r--r-- | src/interp/i-object.boot | 77 | ||||
-rw-r--r-- | src/interp/nruncomp.boot | 44 | ||||
-rw-r--r-- | src/interp/nrunfast.boot | 26 |
3 files changed, 72 insertions, 75 deletions
diff --git a/src/interp/i-object.boot b/src/interp/i-object.boot index 882007b7..b8560f59 100644 --- a/src/interp/i-object.boot +++ b/src/interp/i-object.boot @@ -67,7 +67,7 @@ $useIntegerSubdomain := true -- These are the new structure functions. -objNew(val, mode) == [mode,:val] -- new names as of 10/14/93 +objNew(val, mode) == [mode,:val] -- new names as of 10/14/93 objNewWrap(val, mode) == [mode,:wrap val] objNewCode(val, mode) == ["CONS", MKQ mode,val ] objSetVal(obj,val) == obj.rest := val @@ -93,10 +93,11 @@ wrap x == isWrapped x => x ["WRAPPED",:x] -isWrapped x == x is ['WRAPPED,:.] or integer? x or FLOATP x or string? x +isWrapped x == + x is ['WRAPPED,:.] or integer? x or float? x or string? x unwrap x == - integer? x or FLOATP x or string? x => x + integer? x or float? x or string? x => x x is ["WRAPPED",:y] => y x @@ -114,7 +115,7 @@ getValueNormalForm obj == val := objVal obj atom val => val [op,:argl] := val - op = "WRAPPED" => MKQ argl + op is "WRAPPED" => MKQ argl IDENTP op and isConstructorName op => isConceptualCategory objMode obj => instantiationNormalForm(op,argl) MKQ val @@ -163,7 +164,8 @@ $immediateDataSymbol == ++ If x is a literal of the basic types (Integer String DoubleFloat) then ++ this function returns its type, and nil otherwise. -getBasicMode x == getBasicMode0(x,$useIntegerSubdomain) +macro getBasicMode x == + getBasicMode0(x,$useIntegerSubdomain) ++ Subroutine of getBasicMode. getBasicMode0(x,useIntegerSubdomain) == @@ -219,19 +221,20 @@ getBasicObject x == mkAtreeNode x == -- maker of attrib tree node v := newShell 5 - v.0 := x + vectorRef(v,0) := x v ++ remove mode, value, and misc. info from attrib tree emptyAtree expr == vector? expr => - $immediateDataSymbol = expr.0 => nil - expr.1:= nil - expr.2:= nil - expr.3:= nil + symbolEq?($immediateDataSymbol,vectorRef(expr,0)) => nil + vectorRef(expr,1) := nil + vectorRef(expr,2) := nil + vectorRef(expr,3) := nil -- kill proplist too? atom expr => nil - for e in expr repeat emptyAtree e + for e in expr repeat + emptyAtree e ++ returns true if x is a leaf VAT object. @@ -250,13 +253,13 @@ getMode x == putMode(x,y) == x is [op,:.] => putMode(op,y) not vector? x => keyedSystemError("S2II0001",[x]) - x.1 := y + vectorRef(x,1) := y ++ returns an interpreter object that represents the value of node x. ++ Note that an interpreter object is a pair of mode and value. ++ Also used by the algebra interface to the interperter. getValue x == - vector? x => x.2 + vector? x => vectorRef(x,2) atom x => t := getBasicObject x => t keyedSystemError("S2II0001",[x]) @@ -266,7 +269,7 @@ getValue x == putValue(x,y) == x is [op,:.] => putValue(op,y) not vector? x => keyedSystemError("S2II0001",[x]) - x.2 := y + vectorRef(x,2) := y ++ same as putValue(vec, val), except that vec is returned instead of val. putValueValue(vec,val) == @@ -276,7 +279,7 @@ putValueValue(vec,val) == ++ Returns the node class of x, if possible; otherwise nil. ++ Also used by the algebra interface to the interpreter. getUnnameIfCan x == - vector? x => x.0 + vector? x => vectorRef(x,0) x is [op,:.] => getUnnameIfCan op atom x => x nil @@ -288,7 +291,7 @@ getUnname x == ++ Subroutine of getUnname. getUnname1 x == - vector? x => x.0 + vector? x => vectorRef(x,0) cons? x => keyedSystemError("S2II0001",[x]) x @@ -310,14 +313,14 @@ getModeSet x == putModeSet(x,y) == x is [op,:.] => putModeSet(op,y) not vector? x => keyedSystemError("S2II0001",[x]) - x.3 := y + vectorRef(x,3) := y y getModeOrFirstModeSetIfThere x == x is [op,:.] => getModeOrFirstModeSetIfThere op vector? x => - m := x.1 => m - val := x.2 => objMode val + m := vectorRef(x,1) => m + val := vectorRef(x,2) => objMode val y := x.aModeSet => (y = [$EmptyMode]) and ((m := getMode x) is ['Mapping,:.]) => m first y @@ -326,18 +329,18 @@ getModeOrFirstModeSetIfThere x == nil getModeSetUseSubdomain x == - x and cons? x => getModeSetUseSubdomain first x - vector?(x) => + cons? x => getModeSetUseSubdomain first x + vector? 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]) => + (vectorRef(x,0) = $immediateDataSymbol) and (y = [$Integer]) => val := objValUnwrap val m := getBasicMode0(val,true) - x.2 := objNewWrap(val,m) + vectorRef(x,2) := objNewWrap(val,m) x.aModeSet := [m] [m] null val => y @@ -373,8 +376,8 @@ putAtree(x,prop,val) == x not vector? x => x -- just ignore it n := QLASSQ(prop,'((mode . 1) (value . 2) (modeSet . 3))) - => x.n := val - x.4 := insertShortAlist(prop,val,x.4) + => vectorRef(x,n) := val + vectorRef(x,4) := insertShortAlist(prop,val,x.4) x getAtree(x,prop) == @@ -384,9 +387,9 @@ getAtree(x,prop) == vector? op => getAtree(op,prop) nil not vector? x => nil -- just ignore it - n:= QLASSQ(prop,'((mode . 1) (value . 2) (modeSet . 3))) - => x.n - QLASSQ(prop,x.4) + n := QLASSQ(prop,'((mode . 1) (value . 2) (modeSet . 3))) + => vectorRef(x,n) + QLASSQ(prop,vectorRef(x,4)) putTarget(x, targ) == -- want to put nil modes perhaps to clear old target @@ -409,31 +412,35 @@ getSrcPos(x) == ++ sets the source location information for VAT node x. putSrcPos(x, file, src, line, col) == - putAtree(x, 'srcAndPos, srcPos_New(file, src, line, col)) + putAtree(x, 'srcAndPos, srcPosNew(file, src, line, col)) srcPosNew(file, src, line, col) == - LIST2VEC [file, src, line, col] + vector [file, src, line, col] ++ returns the name of source file for source location `sp'. srcPosFile(sp) == - if sp then sp.0 else nil + sp ~= nil => vectorRef(sp,0) + nil ++ returns the input source string for source location `sp'. srcPosSource(sp) == - if sp then sp.1 else nil + sp ~= nil => vectorRef(sp,1) + nil ++ returns the line number for source location `sp'. srcPosLine(sp) == - if sp then sp.2 else nil + sp ~= nil => vectorRef(sp,2) + nil ++ returns the column number for source location `sp'. srcPosColumn(sp) == - if sp then sp.3 else nil + sp ~= nil => vectorRef(sp,3) + nil srcPosDisplay(sp) == null sp => nil s := strconc('"_"", srcPosFile sp, '"_", line ", - STRINGIMAGE srcPosLine sp, '": ") + toString srcPosLine sp, '": ") sayBrightly [s, srcPosSource sp] col := srcPosColumn sp dots := diff --git a/src/interp/nruncomp.boot b/src/interp/nruncomp.boot index 51682508..b4105dbd 100644 --- a/src/interp/nruncomp.boot +++ b/src/interp/nruncomp.boot @@ -117,24 +117,22 @@ NRTencode(x,y) == encode(x,y,true) where encode(x,compForm,firstTime) == not firstTime and (k:= NRTassocIndex x) => k vector? x => systemErrorHere '"NRTencode" cons? x => - op := first x - op = "Record" or x is ['Union,['_:,a,b],:.] => - [op,:[['_:,a,encode(b,c,false)] - for [.,a,b] in rest x for [.,=a,c] in rest compForm]] + op := x.op + op is ":" => [op,second x,encode(third x,third compForm,false)] (x' := isQuasiquote x) => quasiquote encode(x',isQuasiquote compForm,false) - IDENTP op and (constructor? op or op in '(Union Mapping)) => - [op,:[encode(y,z,false) for y in rest x for z in rest compForm]] + op is "Enumeration" => x + IDENTP op and (constructor? op or builtinConstructor? op) => + [op,:[encode(y,z,false) for y in x.args for z in compForm.args]] -- enumeration constants are like field names, they do not need -- to be encoded. - op = "Enumeration" => x - ["NRTEVAL",NRTreplaceAllLocalReferences COPY_-TREE simplifyVMForm compForm] + ["NRTEVAL",NRTreplaceAllLocalReferences copyTree simplifyVMForm compForm] symbolMember?(x,$formalArgList) => v := $FormalMapVariableList.(POSN1(x,$formalArgList)) firstTime => ["local",v] v - x = "$" => x - x = "$$" => x + x is "$" => x + x is "$$" => x ['QUOTE,x] --------------FUNCTIONS CALLED DURING CAPSULE FUNCTION COMPILATION------------- @@ -143,7 +141,7 @@ listOfBoundVars form == form is '$ => [] IDENTP form and (u:=get(form,'value,$e)) => u:=u.expr - KAR u in '(Union Record) => listOfBoundVars u + builtinConstructor? KAR u => listOfBoundVars u [form] atom form => [] first form is 'QUOTE => [] @@ -292,29 +290,25 @@ NRTassignCapsuleFunctionSlot(op,sig) == ++ This would prevent putting spurious items in $NRTdeltaList NRTinnerGetLocalIndex x == atom x => x - -- following test should skip Unions, Records, Mapping - op := first x - op in '(Union Record Mapping Enumeration _[_|_|_]) => NRTgetLocalIndex x - constructor? op => NRTgetLocalIndex x + op := x.op + IDENTP op and (constructor? op or builtinConstructor? op) => + NRTgetLocalIndex x + op is "[||]" => NRTgetLocalIndex x NRTaddInner x NRTaddInner x == --called by genDeltaEntry and others that affect $NRTdeltaList - PROGN + do atom x => nil - x is ['Record,:l] => - for [.,.,y] in l repeat NRTinnerGetLocalIndex y - first x in '(Union Mapping _[_|_|_]) => - for y in rest x repeat - y is [":",.,z] => NRTinnerGetLocalIndex z - NRTinnerGetLocalIndex y + x is [":",y,z] => [x.op,y,NRTinnerGetLocalIndex z] x is ['SubDomain,y,:.] => NRTinnerGetLocalIndex y + builtinConstructor? x.op or x.op is "[||]" => + for y in x.args repeat + NRTinnerGetLocalIndex y getConstructorSignature first x is [.,:ml] => - for y in rest x for m in ml | y isnt '$ repeat + for y in x.args for m in ml | y isnt '$ repeat isCategoryForm(m,$CategoryFrame) => NRTinnerGetLocalIndex y - x is ["Enumeration",:.] => - for y in rest x repeat NRTinnerGetLocalIndex y keyedSystemError("S2NR0003",[x]) x diff --git a/src/interp/nrunfast.boot b/src/interp/nrunfast.boot index b4fba7f9..a470cdbb 100644 --- a/src/interp/nrunfast.boot +++ b/src/interp/nrunfast.boot @@ -107,12 +107,7 @@ evalSlotDomain(u,dollar) == y u is ['NRTEVAL,y] => eval y u is ['QUOTE,y] => y - u is ['Record,:argl] => - apply('Record,[[":",tag,evalSlotDomain(dom,dollar)] - for [.,tag,dom] in argl]) - u is ['Union,:argl] and first argl is ['_:,.,.] => - apply('Union,[['_:,tag,evalSlotDomain(dom,dollar)] - for [.,tag,dom] in argl]) + u is [":",tag,dom] => [":",tag,evalSlotDomain(dom,dollar)] u is ["Enumeration",:.] => eval u cons? u => -- The domain form may value arguments, get VM form first. @@ -557,14 +552,15 @@ newExpandLocalType(lazyt,dollar,domain) == newExpandLocalTypeForm(lazyt,dollar,domain) --new style newExpandLocalTypeForm([functorName,:argl],dollar,domain) == - functorName in '(Record Union) and first argl is [":",:.] => - [functorName,:[['_:,tag,newExpandLocalTypeArgs(dom,dollar,domain,true)] - for [.,tag,dom] in argl]] - functorName in '(Union Mapping _[_|_|_] Enumeration) => - [functorName,:[newExpandLocalTypeArgs(a,dollar,domain,true) for a in argl]] + functorName is ":" => + [":",first argl,newExpandLocalTypeArgs(second argl,dollar,domain,true)] + functorName is "[||]" => + [functorName,newExpandLocalTypeArgs(first argl,dollar,domain,true)] functorName is "QUOTE" => [functorName,:argl] - coSig := getDualSignatureFromDB functorName - null coSig => error ["bad functorName", functorName] + builtinConstructor? functorName => + [functorName,:[newExpandLocalTypeArgs(a,dollar,domain,true) for a in argl]] + coSig := getDualSignatureFromDB functorName or + error ["unknown constructor name", functorName] [functorName,:[newExpandLocalTypeArgs(a,dollar,domain,flag) for a in argl for flag in rest coSig]] @@ -632,9 +628,9 @@ resolveNiladicConstructors form == -- in spad code. Please do not break this! An example is the use of -- Interval (an Aldor domain) by SIGNEF in limitps.spad. MCD. newHasTest(domform,catOrAtt) == - domform is [dom,:.] and dom in '(Union Record Mapping Enumeration) => - ofCategory(domform, catOrAtt) catOrAtt is '(Type) => true + cons? domform and builtinFunctorName? domform.op => + ofCategory(domform,catOrAtt) asharpConstructorFromDB opOf domform => fn(domform,catOrAtt) where -- atom (infovec := getInfovec opOf domform) => fn(domform,catOrAtt) where fn(a,b) == |