diff options
| -rw-r--r-- | src/interp/ChangeLog | 37 | ||||
| -rw-r--r-- | src/interp/compiler.boot | 161 | ||||
| -rw-r--r-- | src/interp/define.boot | 39 | ||||
| -rw-r--r-- | src/interp/fnewmeta.lisp | 5 | ||||
| -rw-r--r-- | src/interp/g-util.boot | 8 | ||||
| -rw-r--r-- | src/interp/i-intern.boot | 37 | ||||
| -rw-r--r-- | src/interp/i-object.boot | 7 | ||||
| -rw-r--r-- | src/interp/i-spec1.boot | 32 | ||||
| -rw-r--r-- | src/interp/modemap.boot | 3 | ||||
| -rw-r--r-- | src/interp/nruncomp.boot | 14 | ||||
| -rw-r--r-- | src/interp/nrunfast.boot | 6 | ||||
| -rw-r--r-- | src/interp/sys-constants.boot | 2 | ||||
| -rw-r--r-- | src/interp/template.boot | 3 |
13 files changed, 268 insertions, 86 deletions
diff --git a/src/interp/ChangeLog b/src/interp/ChangeLog index 34dafa84..e2e1d25e 100644 --- a/src/interp/ChangeLog +++ b/src/interp/ChangeLog @@ -1,3 +1,40 @@ +2007-12-12 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * compiler.boot (comp3): Use isQuasiquote. + (compSymbol): Use condition type view for non Union objects. + (getUniqueCaseView): New. Subroutine of compSymbol. + (compForm2): Don't infer type for flag parameter through + unique compilcation. + (checkCallingConvention): New. + (compileQuasiquote): coerce, don't convert. + (compCase1): Handle non Union type object through modemap + selection. + (maybeSpliceMode): New. Subroutine of compCase1. + Register special form compiler with their names, not pointers. + * define.boot (candidateSignatures): New. + (hasSigInTargetCategory): Use it. Tidy. + (checkAndDeclare): Use isQuasiquote. + (spadCompileorSetq): Rename non atomic parameters before calling + LISP compiler. + * g-util.boot (quasiquote): New. + (isQuasiquote): Likewise. + * i-intern.boot (flagArguments): New. + (signatureFromModemap): Likewise. + (mkAtree3): Use them. Handle functions taking flag arguments. + * i-object.boot (getFlagArgsPos): New. + * i-spec1.boot (userDefinedCase): Now prepare form and hands back + to bottomUp. + (upcase): Adjust call to userDefinedCase. + * modemap.boot (addDomain): Don't add flag domains to the + environment. + * nruncomp.boot (NRTencode): Handle flag values. + (NRTgetLocalIndex1): Likewise. + * nrunfast.boot (lazyMatch): Likewise. + (newExpandLocalTypeForm): Likewise. + * sys-constants.boot ($DummyFunctorNames): Include quasiquote + constructor. + * template.boot (NRTaddInner): Handle flag values. + 2007-12-09 Gabriel Dos Reis <gdr@cs.tamu.edu> * br-saturn.boot (compDefineCapsuleFunction): Remove. diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot index b39ad841..5a8ecd27 100644 --- a/src/interp/compiler.boot +++ b/src/interp/compiler.boot @@ -134,6 +134,10 @@ comp3(x,m,$e) == m is ["Mapping",:.] => compWithMappingMode(x,m,e) m is ["QUOTE",a] => (x=a => [x,m,$e]; nil) STRINGP m => (atom x => (m=x or m=STRINGIMAGE x => [m,m,e]; nil); nil) + -- In quasiquote mode, x should match exactly + (y := isQuasiquote m) => + y = x => [["QUOTE",x], m, $e] + nil ^x or atom x => compAtom(x,m,e) op:= first x getmode(op,e) is ["Mapping",:ml] and (u:= applyMapping(x,m,e,ml)) => u @@ -298,11 +302,20 @@ compSymbol(s,m,e) == s="true" => ['(QUOTE T),$Boolean,e] s="false" => [false,$Boolean,e] s=m or get(s,"isLiteral",e) => [["QUOTE",s],s,e] - v:= get(s,"value",e) => + v := get(s,"value",e) => --+ MEMQ(s,$functorLocalParameters) => 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 @@ -312,6 +325,16 @@ compSymbol(s,m,e) == m = $Expression 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) + for [p,:v] in props repeat + p = "condition" and v is [["case",.,t],:.] => return t + p = "value" => return nil + + convertOrCroak(T,m) == u:= convert(T,m) => u userError ["CANNOT CONVERT: ",T.expr,"%l"," OF MODE: ",T.mode,"%l", @@ -415,8 +438,12 @@ compForm2(form is [op,:argl],m,e,modemapList) == -- its important that subsumed ops (newList) be considered last if newList then modemapList := append(modemapList,newList) Tl:= - [[.,.,e]:= T - for x in argl while (isSimple x and (T:= compUniquely(x,$EmptyMode,e)))] + [[.,.,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] + isSimple x and compUniquely(x,$EmptyMode,e) + or/[x for x in Tl] => partialModeList:= [(x => x.mode; nil) for x in Tl] compFormPartiallyBottomUp(form,m,e,modemapList,partialModeList) or @@ -463,6 +490,28 @@ getFormModemaps(form is [op,:argl],e) == stackMessage ["no modemap for","%b",op,"%d","with ",nargs," arguments"] finalModemapList +++ We are either compiling a function call, or trying to determine +++ whether we know something about a function being defined with +++ parameters are not declared in the definition. `sigs' is the list of +++ candidate signatures for `nargs' arguments or parameters. We need +++ to detemine whether any of the arguments are flags. If any +++ operation takes a flag argument, then all other overloads must have +++ the same arity and must take flag argument in the same position. +++ Returns a vector of length `nargs' with positive entries indicating +++ flag arguments, and negative entries for normal argument passing. +checkCallingConvention(sigs,nargs) == + v := GETZEROVEC nargs + for sig in sigs repeat + for t in rest sig + for i in 0.. repeat + isQuasiquote t => + v.i < 0 => userError '"flag argument restriction violation" + v.i := v.i + 1 + v.i > 0 => userError '"flag argument restriction violation" + v.i := v.i - 1 + v + + getConstructorFormOfMode(m,e) == isConstructorForm m => m if m="$" then m:= "Rep" @@ -679,7 +728,7 @@ setqMultipleExplicit(nameList,valList,m,e) == ++ fledged AST algebra -- which we don't have yet in mainstream. compileQuasiquote(["[||]",:form],m,e) == null form => nil - [["QUOTE", :form],$Syntax,e] + coerce([["QUOTE", :form],$Syntax,e], m) --% WHERE @@ -1041,13 +1090,25 @@ 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(t,m) and modeEqual(s,m')] or return nil + for (modemap:= [map,cexpr]) in getModemapList("case",2,e') + | map is [.,.,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 [["call",fn,x'],$Boolean,e'] + +++ For `case' operation implemented in library, the second operand +++ (target type) is taken unevaluated. The corresponding parameter +++ type in the modemap was specified as quasiquotation. We +++ want to look at the actual type when comparing with modeEqual. +maybeSpliceMode m == + (m' := isQuasiquote m) => m' + m + compColon([":",f,t],m,e) == $insideExpressionIfTrue=true => compColonInside(f,m,e,t) --if inside an expression, ":" means to convert to m "on faith" @@ -1442,48 +1503,48 @@ compilerDoitWithScreenedLisplib(constructor, fun) == --% Register compilers for special forms. -- Those compilers are on the `SPECIAL' property of the corresponding -- special form operator symbol. -for x in [["_|", :function compSuchthat],_ - ["_@", :function compAtSign],_ - ["_:", :function compColon],_ - ["_:_:", :function compCoerce],_ - ["QUOTE", :function compQuote],_ - ["add", :function compAdd],_ - ["CAPSULE", :function compCapsule],_ - ["case", :function compCase],_ - ["CATEGORY", :function compCategory],_ - ["COLLECT", :function compRepeatOrCollect],_ - ["COLLECTV", :function compCollectV],_ - ["CONS", :function compCons],_ - ["construct", :function compConstruct],_ - ["DEF", :function compDefine],_ - ["elt", :function compElt],_ - ["exit", :function compExit],_ - ["has", :function compHas],_ - ["IF", :function compIf],_ - ["import", :function compImport],_ - ["is", :function compIs],_ - ["Join", :function compJoin],_ - ["leave", :function compLeave],_ - ["LET", :function compSetq],_ - ["ListCategory", :function compConstructorCategory],_ - ["MDEF", :function compMacro],_ - ["not", :function compileNot],_ - ["pretend", :function compPretend],_ - ["Record", :function compCat],_ - ["RecordCategory", :function compConstructorCategory],_ - ["REDUCE", :function compReduce],_ - ["REPEAT", :function compRepeatOrCollect],_ - ["return", :function compReturn],_ - ["SEQ", :function compSeq],_ - ["SETQ", :function compSetq],_ - ["String", :function compString],_ - ["SubDomain", :function compSubDomain],_ - ["SubsetCategory", :function compSubsetCategory],_ - ["Union", :function compCat],_ - ["Mapping", :function compCat],_ - ["UnionCategory", :function compConstructorCategory],_ - ["VECTOR", :function compVector],_ - ["VectorCategory", :function compConstructorCategory],_ - ["where", :function compWhere],_ - ["[||]", :function compileQuasiquote]] repeat +for x in [["_|", :"compSuchthat"],_ + ["_@", :"compAtSign"],_ + ["_:", :"compColon"],_ + ["_:_:", :"compCoerce"],_ + ["QUOTE", :"compQuote"],_ + ["add", :"compAdd"],_ + ["CAPSULE", :"compCapsule"],_ + ["case", :"compCase"],_ + ["CATEGORY", :"compCategory"],_ + ["COLLECT", :"compRepeatOrCollect"],_ + ["COLLECTV", :"compCollectV"],_ + ["CONS", :"compCons"],_ + ["construct", :"compConstruct"],_ + ["DEF", :"compDefine"],_ + ["elt", :"compElt"],_ + ["exit", :"compExit"],_ + ["has", :"compHas"],_ + ["IF", : "compIf"],_ + ["import", :"compImport"],_ + ["is", :"compIs"],_ + ["Join", :"compJoin"],_ + ["leave", :"compLeave"],_ + ["LET", :"compSetq"],_ + ["ListCategory", :"compConstructorCategory"],_ + ["MDEF", :"compMacro"],_ + ["not", :"compileNot"],_ + ["pretend", :"compPretend"],_ + ["Record", :"compCat"],_ + ["RecordCategory", :"compConstructorCategory"],_ + ["REDUCE", :"compReduce"],_ + ["REPEAT", :"compRepeatOrCollect"],_ + ["return", :"compReturn"],_ + ["SEQ", :"compSeq"],_ + ["SETQ", :"compSetq"],_ + ["String", :"compString"],_ + ["SubDomain", :"compSubDomain"],_ + ["SubsetCategory", :"compSubsetCategory"],_ + ["Union", :"compCat"],_ + ["Mapping", :"compCat"],_ + ["UnionCategory", :"compConstructorCategory"],_ + ["VECTOR", :"compVector"],_ + ["VectorCategory", :"compConstructorCategory"],_ + ["where", :"compWhere"],_ + ["[||]", :"compileQuasiquote"]] repeat MAKEPROP(car x, 'SPECIAL, cdr x) diff --git a/src/interp/define.boot b/src/interp/define.boot index 43405cc3..8430610e 100644 --- a/src/interp/define.boot +++ b/src/interp/define.boot @@ -231,7 +231,8 @@ compDefineCategory2(form,signature,specialCases,body,m,e, -- 2. obtain signature signature':= - [first signature,:[getArgumentModeOrMoan(a,$definition,e) for a in argl]] + [first signature, + :[getArgumentModeOrMoan(a,$definition,e) for a in argl]] e:= giveFormalParametersValues(argl,e) -- 3. replace arguments by $1,..., substitute into body, @@ -832,17 +833,26 @@ getSignatureFromMode(form,e) == getmode(opOf form,e) is ['Mapping,:signature] => #form^=#signature => stackAndThrow ["Wrong number of arguments: ",form] EQSUBSTLIST(rest form,take(#rest form,$FormalMapVariableList),signature) - + +candidateSignatures(op,nmodes,slot1) == + [sig for [[=op,sig,:.],:.] in slot1 | #sig = nmodes] + +++ We are compiling a capsule function definition with head given by `form'. +++ Determine whether the function with possibly partial signature `opsig' +++ is exported. Return the complete signature if yes; otherwise +++ return nil, with diagnostic in ambiguity case. hasSigInTargetCategory(argl,form,opsig,e) == - mList:= [getArgumentMode(x,e) for x in argl] + sigs := candidateSignatures($op,#form,$domainShell.1) + cc := checkCallingConvention(sigs,#argl) + mList:= [(cc.i > 0 => quasiquote x; getArgumentMode(x,e)) + for x in argl for i in 0..] --each element is a declared mode for the variable or nil if none exists potentialSigList:= REMDUP - [sig - for [[opName,sig,:.],:.] in $domainShell.(1) | - fn(opName,sig,opsig,mList,form)] where - fn(opName,sig,opsig,mList,form) == - opName=$op and #sig=#form and (null opsig or opsig=first sig) and + [sig for sig in sigs | + fn(sig,opsig,mList)] where + fn(sig,opsig,mList) == + (null opsig or opsig=first sig) and (and/[compareMode2Arg(x,m) for x in mList for m in rest sig]) c:= #potentialSigList 1=c => first potentialSigList @@ -866,10 +876,10 @@ getArgumentMode(x,e) == m:= get(x,'mode,e) => m checkAndDeclare(argl,form,sig,e) == - -- arguments with declared types must agree with those in sig; -- those that don't get declarations put into e for a in argl for m in rest sig repeat + isQuasiquote m => nil -- we just built m from a. m1:= getArgumentMode(a,e) => ^modeEqual(m1,m) => stack:= [" ",:bright a,'"must have type ",m, @@ -1063,6 +1073,17 @@ spadCompileOrSetq (form is [nam,[lam,vl,body]]) == --bizarre hack to take account of the existence of "known" functions --good for performance (LISPLLIB size, BPI size, NILSEC) CONTAINED(" ",body) => sayBrightly ['" ",:bright nam,'" not compiled"] + + -- flag parameters needs to be made atomic, otherwise Lisp is confused. + -- We try our best to preserve + -- Note that we don't need substitution in the body because flag + -- parameters are never used in the body. + vl := [ renameParameter for v in vl] where + renameParameter() == + NUMBERP v or IDENTP v or STRINGP v => v + GENSYM '"flag" + form := [nam,[lam,vl,body]] + if vl is [:vl',E] and body is [nam',: =vl'] then LAM_,EVALANDFILEACTQ ['PUT,MKQ nam,MKQ 'SPADreplace,MKQ nam'] sayBrightly ['" ",:bright nam,'"is replaced by",:bright nam'] diff --git a/src/interp/fnewmeta.lisp b/src/interp/fnewmeta.lisp index 43d7d3c5..feab45b8 100644 --- a/src/interp/fnewmeta.lisp +++ b/src/interp/fnewmeta.lisp @@ -819,9 +819,8 @@ (MUST (MATCH-ADVANCE-STRING "|]")) (PUSH-REDUCTION '|PARSE-Enclosure| (CONS '|[\|\|]| - (CONS (POP-STACK-1) NIL)))))) - - + (CONS (POP-STACK-1) NIL))) + ))) )) diff --git a/src/interp/g-util.boot b/src/interp/g-util.boot index 20feccf0..2f900f6a 100644 --- a/src/interp/g-util.boot +++ b/src/interp/g-util.boot @@ -93,6 +93,14 @@ put(x,prop,val,e) == addBinding(x,newProplist,e) +++ Build a quasiquotation form for `x'. +quasiquote x == + ["[||]",x] + +++ Extract the quoted form, otherwise return nil +isQuasiquote m == + m is ["[||]",y] => y + -- Convert an arbitrary lisp object to canonical boolean. bool x == diff --git a/src/interp/i-intern.boot b/src/interp/i-intern.boot index e58821c1..8eefe0d7 100644 --- a/src/interp/i-intern.boot +++ b/src/interp/i-intern.boot @@ -264,9 +264,26 @@ mkAtree3(x,op,argl) == v := mkAtreeNode $immediateDataSymbol putValue(v,getBasicObject op) v - atom op => mkAtreeNode op + atom op => + t := mkAtreeNode op + putAtree(t, 'flagArgsPos, flagArguments(op,#argl)) + t mkAtree1 op - [z,:[mkAtree1 y for y in argl]] + -- this is a general form handled by modemap selection. Be + -- careful not to evaluate arguments that are not meant to. + flagArgPos := getFlagArgsPos z + [z,:[buildTreeForOperand for y in argl for i in 0..]] where + buildTreeForOperand() == + flagArgPos and flagArgPos.i > 0 => + y' := parseTransform postTransform y + a := mkAtreeNode $immediateDataSymbol + m := quasiquote y' + putMode(a, m) + putValue(a, objNewWrap(MKQ y',m)) + putModeSet(a, [m]) + a + mkAtree1 y + where fn(a,b) == a and b => @@ -274,6 +291,22 @@ mkAtree3(x,op,argl) == else throwMessage '" double declaration of parameter" a or b +++ Check if op accepts flag arguments. If so, returns a vector whose +++ positive entry indicates that modemaps for `op' takes flag arguments +++ in that position. +flagArguments(op, nargs) == + v := GETZEROVEC nargs + sigs := [signatureFromModemap m for m in getModemapsFromDatabase(op, nargs)] + checkCallingConvention(sigs, nargs) + +++ Extract the signature of modemap `m'. +signatureFromModemap m == + [sig,pred,:.] := m + pred = true => rest sig + car pred = "AND" => + sl := [[a,:b] for [.,a,b] in cdr pred] + rest SUBLIS(sl,sig) + collectDefTypesAndPreds args == -- given an arglist to a DEF-like form, this function returns -- a vector of three things: diff --git a/src/interp/i-object.boot b/src/interp/i-object.boot index 2ac8ae61..d9dbd969 100644 --- a/src/interp/i-object.boot +++ b/src/interp/i-object.boot @@ -393,6 +393,13 @@ srcPosDisplay(sp) == true +++ Returns the calling convention vector for an operation +++ represented by the VAT `t'. +getFlagArgsPos t == + VECP t => getAtree(t, 'flagArgsPos) + atom t => keyedSystemError("S2II0001",[t]) + getFlagArgsPos car t + --% Transfer of VAT properties. diff --git a/src/interp/i-spec1.boot b/src/interp/i-spec1.boot index 0047f7f0..574d5b75 100644 --- a/src/interp/i-spec1.boot +++ b/src/interp/i-spec1.boot @@ -303,27 +303,27 @@ upor x == ++ subroutine of upcase. Handles the situation where `case' may ++ have been defined as a library function. -++ `op', `lhs' are VATs; `rhs' is a parse form. -++ Note: Some of the code here needs to be refactored with code -++ in bottomUp and elsewhere to avoid logic duplication. -userDefinedCase(op, lhs, rhs) == - -- At this point, op and lhs have already been bottomUp'd. - rhs := mkAtree rhs - bottomUp rhs - -- Prepare for evaluating call to a library function. - for x in [lhs, rhs] for i in 1.. repeat - putAtree(x, "callingFunction", "case") - putAtree(x, "argumentNumber", i) - putAtree(x, "totalArgs", 2) - bottomUpForm([op, lhs, rhs], op, "case", [lhs, rhs], - [bottomUp lhs, bottomUp rhs]) - +++ `op', `lhs' are VATs; `rhs' is unevaluated. +userDefinedCase(t is [op, lhs, rhs]) == + -- We want to resolve the situation by general modemap selection. + -- So, we want to let bottomUp (which called us through upcase) + -- to continue the work. The way we do that is to return `nil'. + -- Therefore we need a VAT for `rhs' with sufficient information + -- to prevent bottomUp from trying to evaluate `rhs'. + putAtree(op, 'flagArgsPos, flagArguments("case",2)) + r := mkAtreeNode $immediateDataSymbol + m := quasiquote rhs + putMode(r, m) + putValue(r, objNewWrap(MKQ rhs,m)) + putModeSet(r, [m]) + RPLACD(cdr t, [r]) -- fix up contained for rhs. + nil -- tell bottomUp to continue. upcase t == t isnt [op,lhs,rhs] => nil bottomUp lhs triple := getValue lhs - objMode(triple) isnt ['Union,:unionDoms] => userDefinedCase(op,lhs,rhs) + objMode(triple) isnt ['Union,:unionDoms] => userDefinedCase t if (rhs' := isDomainValuedVariable(rhs)) then rhs := rhs' if first unionDoms is [":",.,.] then for i in 0.. for d in unionDoms repeat diff --git a/src/interp/modemap.boot b/src/interp/modemap.boot index 7dc30283..1cdfdd2c 100644 --- a/src/interp/modemap.boot +++ b/src/interp/modemap.boot @@ -56,6 +56,9 @@ addDomain(domain,e) == addNewDomain(domain,e) -- constructor? test needed for domains compiled with $bootStrapMode=true isFunctor name or constructor? name => addNewDomain(domain,e) + -- ??? we should probably augment $DummyFunctorNames with CATEGORY + -- ??? so that we don't have to do this special check here. Investigate. + isQuasiquote domain => e if not isCategoryForm(domain,e) and not member(name,'(Mapping CATEGORY)) then unknownTypeError name diff --git a/src/interp/nruncomp.boot b/src/interp/nruncomp.boot index 15468369..b732ece8 100644 --- a/src/interp/nruncomp.boot +++ b/src/interp/nruncomp.boot @@ -106,6 +106,7 @@ NRTencode(x,y) == encode(x,y,true) where encode(x,compForm,firstTime) == QCAR x='Record or x is ['Union,['_:,a,b],:.] => [QCAR x,:[['_:,a,encode(b,c,false)] for [.,a,b] in QCDR x for [.,=a,c] in CDR compForm]] + isQuasiquote x => x constructor? QCAR x or MEMQ(QCAR x,'(Union Mapping)) => [QCAR x,:[encode(y,z,false) for y in QCDR x for z in CDR compForm]] ['NRTEVAL,NRTreplaceAllLocalReferences COPY_-TREE lispize compForm] @@ -244,11 +245,20 @@ NRTgetLocalIndex1(item,killBindingIfTrue) == $NRTdeltaListComp:=[item,:$NRTdeltaListComp] $NRTdeltaLength := $NRTdeltaLength+1 $NRTbase + $NRTdeltaLength - 1 - $NRTdeltaList:= [['domain,NRTaddInner item,:value],:$NRTdeltaList] + -- when assigning slot to flag values, we don't really want to + -- compile them. Rather, we want to record them as if they were atoms. + flag := isQuasiquote item + $NRTdeltaList:= [['domain,(flag => item; NRTaddInner item),:value], + :$NRTdeltaList] saveNRTdeltaListComp:= $NRTdeltaListComp:=[nil,:$NRTdeltaListComp] saveIndex := $NRTbase + $NRTdeltaLength $NRTdeltaLength := $NRTdeltaLength+1 - compEntry:= (compOrCroak(item,$EmptyMode,$e)).expr + compEntry:= + -- we don't need to compile the flag again. + -- ??? In fact we should not be compiling again at this phase. + -- ??? That we do is likely a bug. + flag => item + (compOrCroak(item,$EmptyMode,$e)).expr -- item RPLACA(saveNRTdeltaListComp,compEntry) saveIndex diff --git a/src/interp/nrunfast.boot b/src/interp/nrunfast.boot index 770c956c..d791335a 100644 --- a/src/interp/nrunfast.boot +++ b/src/interp/nrunfast.boot @@ -430,6 +430,7 @@ lazyMatch(source,lazyt,dollar,domain) == for [.,stag,s] in sargl for [.,atag,a] in argl] MEMQ(op,'(Union Mapping QUOTE)) => and/[lazyMatchArg(s,a,dollar,domain) for s in sargl for a in argl] + op="[||]" => source = lazyt coSig := GETDATABASE(op,'COSIG) NULL coSig => error ["bad Constructor op", op] and/[lazyMatchArg2(s,a,dollar,domain,flag) @@ -439,8 +440,9 @@ lazyMatch(source,lazyt,dollar,domain) == lazyt is ['_#, slotNum] => source = #(domain.slotNum) lazyt is ['call,'LENGTH, slotNum] => source = #(domain.slotNum) nil - source is ['construct,:l] => l = lazyt + -- A hideous hack on the same lines as the previous four lines JHD/MCD + source is ['construct,:l] => l = lazyt nil @@ -511,7 +513,7 @@ newExpandLocalTypeForm([functorName,:argl],dollar,domain) == for [.,tag,dom] in argl]] MEMQ(functorName, '(Union Mapping)) => [functorName,:[newExpandLocalTypeArgs(a,dollar,domain,true) for a in argl]] - functorName = 'QUOTE => [functorName,:argl] + functorName in '(QUOTE _[_|_|_]) => [functorName,:argl] coSig := GETDATABASE(functorName,'COSIG) NULL coSig => error ["bad functorName", functorName] [functorName,:[newExpandLocalTypeArgs(a,dollar,domain,flag) diff --git a/src/interp/sys-constants.boot b/src/interp/sys-constants.boot index 0ce969c6..0f008f5a 100644 --- a/src/interp/sys-constants.boot +++ b/src/interp/sys-constants.boot @@ -529,7 +529,7 @@ $ConstructorNames == ++ A list of functors that do not really have modemaps $DummyFunctorNames == - '(Mapping) + '(Mapping _[_|_|_]) --% diff --git a/src/interp/template.boot b/src/interp/template.boot index 75e61ac8..a8abe566 100644 --- a/src/interp/template.boot +++ b/src/interp/template.boot @@ -286,6 +286,7 @@ NRTaddInner x == getConstructorSignature x is [.,:ml] => for y in rest x for m in ml | not (y = '$) repeat isCategoryForm(m,$CategoryFrame) => NRTinnerGetLocalIndex y + isQuasiquote x => NRTinnerGetLocalIndex x keyedSystemError("S2NR0003",[x]) x @@ -294,7 +295,7 @@ NRTaddInner x == NRTinnerGetLocalIndex x == atom x => x -- following test should skip Unions, Records, Mapping - MEMQ(opOf x,'(Union Record Mapping)) => NRTgetLocalIndex x + MEMQ(opOf x,'(Union Record Mapping _[_|_|_])) => NRTgetLocalIndex x constructor?(x) => NRTgetLocalIndex x NRTaddInner x |