aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/interp/ChangeLog37
-rw-r--r--src/interp/compiler.boot161
-rw-r--r--src/interp/define.boot39
-rw-r--r--src/interp/fnewmeta.lisp5
-rw-r--r--src/interp/g-util.boot8
-rw-r--r--src/interp/i-intern.boot37
-rw-r--r--src/interp/i-object.boot7
-rw-r--r--src/interp/i-spec1.boot32
-rw-r--r--src/interp/modemap.boot3
-rw-r--r--src/interp/nruncomp.boot14
-rw-r--r--src/interp/nrunfast.boot6
-rw-r--r--src/interp/sys-constants.boot2
-rw-r--r--src/interp/template.boot3
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