From 4a4b92d282fbe89881b469ed0a8ac25bf33cad05 Mon Sep 17 00:00:00 2001 From: dos-reis Date: Mon, 14 Jan 2008 12:17:21 +0000 Subject: * interp/compiler.boot (compSymbol): Don't handle possible case views here. (hasUniqueCaseView): Rename from getUniqueCaseView. Take the target mode as second argument. (compForm2): Use calling convention vector to determine infer flag parameter types. (compCase1): Uniformly handle `case-expressions'. Call genDeltaEntry for selected operator. (coerceExtraHard): Handle coercions from UnionType domains. (autoCoerceByModemap): Tidy. * interp/g-opt.boot (optCall): Be more verbose in diagnostics. * algebra/syntax.spad (Syntax): Rework. * algebra/coerce.spad.pamphlet (UnionType): New. * algebra/Makefile.pamphlet (axiom_algebra_layer_0): Include UTYPE.o * share/algebra: Update databases. --- src/interp/compiler.boot | 73 ++++++++++++++++++++++++++++-------------------- src/interp/g-opt.boot | 2 +- src/interp/nrunfast.boot | 2 +- 3 files changed, 44 insertions(+), 33 deletions(-) (limited to 'src/interp') diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot index b6c72840..c6841f5b 100644 --- a/src/interp/compiler.boot +++ b/src/interp/compiler.boot @@ -308,14 +308,6 @@ compSymbol(s,m,e) == NRTgetLocalIndex s [s,v.mode,e] --s will be replaced by an ELT form in beforeCompile - -- If the symbol s has a type given by a condition as the result of - -- a `case' form or a `suchthat' form, then we want to take - -- advantage of that mode knowledge. However, we must ensure that - -- we are not messing with members of Union objects which need - -- extra indirections to get to the actual object representation. - not isUnionMode(v.mode,e) and (t := getUniqueCaseView(s,e)) => - coerce([s,t,e],m) - [s,v.mode,e] --s has been SETQd m':= getmode(s,e) => if not member(s,$formalArgList) and not MEMQ(s,$FormalMapVariableList) and @@ -325,14 +317,13 @@ compSymbol(s,m,e) == m = $OutputForm or m = $Symbol => [['QUOTE,s],m,e] not isFunction(s,e) => errorRef s -++ Return the more recent unique type case assumption on `x' (if any) -++ that predates its declaration in environment `e'. Note, this cannot -++ be the same thing as just asking for the 'condition' property of `x'. -getUniqueCaseView(s,e) == - props := getProplist(s,e) +++ Return true if `m' is the most recent unique type case assumption +++ on `x' that predates its declaration in environment `e'. +hasUniqueCaseView(x,m,e) == + props := getProplist(x,e) for [p,:v] in props repeat - p = "condition" and v is [["case",.,t],:.] => return t - p = "value" => return nil + p = "condition" and v is [["case",.,t],:.] => return modeEqual(t,m) + p = "value" => return false convertOrCroak(T,m) == @@ -437,11 +428,16 @@ compForm2(form is [op,:argl],m,e,modemapList) == -- We can use MEMQ since deleteList was built out of members of modemapList -- its important that subsumed ops (newList) be considered last if newList then modemapList := append(modemapList,newList) + + -- The calling convention vector is used to determine when it is + -- appropriate to infer type by compiling the argument vs. just + -- looking up the parameter type for flag arguments. + cc := checkCallingConvention([sig for [[.,:sig],:.] in modemapList], #argl) Tl:= - [[.,.,e]:= T for x in argl for z in first modemapList - while (T := inferMode(x,z,e))] where - inferMode(x,z,e) == - isQuasiquote z => [x,quasiquote x,e] + [[.,.,e]:= T for x in argl for i in 0.. + while (T := inferMode(x,cc.i > 0,e))] where + inferMode(x,flag,e) == + flag => [x,quasiquote x,e] isSimple x and compUniquely(x,$EmptyMode,e) or/[x for x in Tl] => @@ -1090,14 +1086,16 @@ compCase(["case",x,m'],m,e) == compCase1(x,m,e) == [x',m',e']:= comp(x,$EmptyMode,e) or return nil - -- `case' operations for non-Union types are function calls - not isUnionMode(m',e') => compForm(["case",x',m],$Boolean,e') u:= - [cexpr - for (modemap:= [map,cexpr]) in getModemapList("case",2,e') - | map is [.,.,s,t] and modeEqual(maybeSpliceMode t,m) + [modemap + for (modemap := [map,cexpr]) in getModemapList("case",2,e') + | map is [.,=$Boolean,s,t] and modeEqual(maybeSpliceMode t,m) and modeEqual(s,m')] or return nil - fn:= (or/[selfn for [cond,selfn] in u | cond=true]) or return nil + fn:= (or/[mm for (mm := [.,[cond,selfn]]) in u | cond=true]) or return nil + fn := genDeltaEntry ["case",:fn] + -- user-defined `case' functions really are binary, as opposed to + -- the compiler-synthetized versions for Union instances. + not isUnionMode(m',e') => [["call",fn,x',MKQ m],$Boolean,e'] [["call",fn,x'],$Boolean,e'] @@ -1244,8 +1242,19 @@ coerceExtraHard(T is [x,m',e],m) == (T'':= coerce(T',m)) => T'' m' is ['Record,:.] and m = $Expression => [['coerceRe2E,x,['ELT,COPY m',0]],m,e] + belongsTo?(m',["UnionType"],e) and hasUniqueCaseView(x,m,e) => + coerceByModemap(T,m) nil +++ returns true if mode `m' is known to belong to category `cat' in +++ the environment `e'. This function is different from its cousines +++ `ofCategory', or `has'. The latter perform runtime checks. Here, +++ we are interested in a static approximation. So, use with care. +belongsTo?(m,cat,e) == + c := get(m,"mode",e) + c isnt ["Join",:cats] => nil + cat in cats + coerceable(m,m',e) == m=m' => m -- must find any free parameters in m @@ -1301,17 +1310,19 @@ coerceByModemap([x,m,e],m') == autoCoerceByModemap([x,source,e],target) == u:= - [cexpr - for (modemap:= [map,cexpr]) in getModemapList("autoCoerce",1,e) | map is [ - .,t,s] and modeEqual(t,target) and modeEqual(s,source)] or return nil - fn:= (or/[selfn for [cond,selfn] in u | cond=true]) or return nil + [modemap + for (modemap:= [map,cexpr]) in getModemapList("autoCoerce",1,e) + | map is [.,t,s] and modeEqual(t,target) + and modeEqual(s,source)] or return nil + fn:= (or/[mm for (mm := [.,[cond,selfn]]) in u | cond=true]) or return nil + source is ["Union",:l] and member(target,l) => (y:= get(x,"condition",e)) and (or/[u is ["case",., =target] for u in y]) - => [["call",fn,x],target,e] + => [["call",genDeltaEntry ["autoCoerce", :fn],x],target,e] x="$fromCoerceable$" => nil stackMessage ["cannot coerce: ",x,"%l"," of mode: ",source,"%l", " to: ",target," without a case statement"] - [["call",fn,x],target,e] + [["call",genDeltaEntry ["autoCoerce", :fn],x],target,e] --% Very old resolve -- should only be used in the old (preWATT) compiler diff --git a/src/interp/g-opt.boot b/src/interp/g-opt.boot index 2c13097d..a1b91344 100644 --- a/src/interp/g-opt.boot +++ b/src/interp/g-opt.boot @@ -158,7 +158,7 @@ optCall (x is ["call",:u]) == if $QuickCode then RPLACA(fn,"QREFELT") RPLAC(rest x,[:a,fn]) x - systemErrorHere '"optCall" + systemErrorHere ['"optCall with", :bright x] optCallSpecially(q,x,n,R) == y:= LASSOC(R,$specialCaseKeyList) => optSpecialCall(x,y,n) diff --git a/src/interp/nrunfast.boot b/src/interp/nrunfast.boot index 663ed874..d8e6736f 100644 --- a/src/interp/nrunfast.boot +++ b/src/interp/nrunfast.boot @@ -513,7 +513,7 @@ newExpandLocalTypeForm([functorName,:argl],dollar,domain) == MEMQ(functorName, '(Record Union)) and first argl is [":",:.] => [functorName,:[['_:,tag,newExpandLocalTypeArgs(dom,dollar,domain,true)] for [.,tag,dom] in argl]] - MEMQ(functorName, '(Union Mapping)) => + MEMQ(functorName, '(Union Mapping _[_|_|_])) => [functorName,:[newExpandLocalTypeArgs(a,dollar,domain,true) for a in argl]] functorName = "QUOTE" => [functorName,:argl] coSig := GETDATABASE(functorName,'COSIG) -- cgit v1.2.3