From 704439cfc3b15316702dabe92419b9cd2f2fe9d7 Mon Sep 17 00:00:00 2001 From: dos-reis Date: Sat, 3 Jul 2010 23:17:46 +0000 Subject: * interp/category.boot (isCategoryForm): Tidy. * interp/compiler.boot (compMacro): Handle parameterized definition. * interp/define.boot (macroExpand): Likewise. (macroExpandList): Move case for niladic macros to macroExpand. * interp/g-util.boot (putMacro): New utility function. --- src/ChangeLog | 8 ++++++ src/interp/category.boot | 6 +++-- src/interp/compiler.boot | 13 ++++++++-- src/interp/define.boot | 65 +++++++++++++++++++++++++++++------------------- src/interp/g-util.boot | 5 ++++ src/interp/postpar.boot | 2 +- src/interp/wi1.boot | 6 ++--- src/interp/wi2.boot | 4 +-- 8 files changed, 74 insertions(+), 35 deletions(-) (limited to 'src') diff --git a/src/ChangeLog b/src/ChangeLog index 65268277..3017281c 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,11 @@ +2010-07-03 Gabriel Dos Reis + + * interp/category.boot (isCategoryForm): Tidy. + * interp/compiler.boot (compMacro): Handle parameterized definition. + * interp/define.boot (macroExpand): Likewise. + (macroExpandList): Move case for niladic macros to macroExpand. + * interp/g-util.boot (putMacro): New utility function. + 2010-07-03 Gabriel Dos Reis * interp/define.boot (macroExpand): Tidy. Only identifiers are diff --git a/src/interp/category.boot b/src/interp/category.boot index b7a301b6..d9ad2e7e 100644 --- a/src/interp/category.boot +++ b/src/interp/category.boot @@ -55,8 +55,10 @@ isCategory a == ++ envronement `e'. isCategoryForm: (%Form,%Env) -> %Boolean isCategoryForm(x,e) == - atom x => u:= get(x,"macro",e) => isCategoryForm(u,e) - categoryForm? first x + atom x => + u := macroExpand(x,e) + cons? u and categoryForm? u + categoryForm? x --% Functions for building categories diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot index bcc37574..44f9c6bf 100644 --- a/src/interp/compiler.boot +++ b/src/interp/compiler.boot @@ -982,7 +982,7 @@ $macroIfTrue := false compMacro(form,m,e) == $macroIfTrue: local:= true - ["MDEF",lhs,signature,specialCases,rhs]:= form + ["MDEF",lhs,signature,specialCases,rhs] := form if $verbose then prhs := rhs is ['CATEGORY,:.] => ['"-- the constructor category"] @@ -993,7 +993,16 @@ compMacro(form,m,e) == sayBrightly ['" processing macro definition",'%b, :formatUnabbreviated lhs,'" ==> ",:prhs,'%d] m=$EmptyMode or m=$NoValueMode => - ["/throwAway",$NoValueMode,put(first lhs,"macro",macroExpand(rhs,e),e)] + -- Macro names shall be identifiers. + not IDENTP lhs.op => + stackMessage('"invalid left-hand-side in macro definition",nil) + e + -- We do not have the means, at this late stage, to make a distinction + -- between a niladic functional macro and an identifier that is + -- defined as a macro. + if lhs.args = nil then lhs := lhs.op + ["/throwAway",$NoValueMode,putMacro(lhs,macroExpand(rhs,e),e)] + nil --% SEQ diff --git a/src/interp/define.boot b/src/interp/define.boot index 4546be69..748b4a13 100644 --- a/src/interp/define.boot +++ b/src/interp/define.boot @@ -120,8 +120,8 @@ DomainSubstitutionFunction: (%List,%Form) -> %Form ++ `pred' (a VM instruction form). Emit appropriate info into the ++ databases. emitSubdomainInfo(form,super,pred) == - pred := eqSubst($AtVariables,rest form,pred) - super := eqSubst($AtVariables,rest form,super) + pred := eqSubst($AtVariables,form.args,pred) + super := eqSubst($AtVariables,form.args,super) evalAndRwriteLispForm("evalOnLoad2",["noteSubDomainInfo", quoteForm form.op,quoteForm super, quoteForm pred]) @@ -258,7 +258,7 @@ checkRepresentation(addForm,body,env) == dom addForm $useRepresentationHack := false - env := put('Rep,'macro,domainRep,env) + env := putMacro('Rep,domainRep,env) env @@ -268,8 +268,8 @@ compDefine1(form,m,e) == --1. decompose after macro-expanding form ['DEF,lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e) $insideWhereIfTrue and isMacro(form,e) and (m=$EmptyMode or m=$NoValueMode) - => [lhs,m,put(lhs.op,"macro",rhs,e)] - checkParameterNames rest lhs + => [lhs,m,putMacro(lhs.op,rhs,e)] + checkParameterNames lhs.args null signature.target and not MEMQ(KAR rhs,$BuiltinConstructorNames) and (sig:= getSignatureFromMode(lhs,e)) => -- here signature of lhs is determined by a previous declaration @@ -289,7 +289,7 @@ compDefine1(form,m,e) == compDefineCategory(form,m,e,nil,$formalArgList) isDomainForm(rhs,e) and not $insideFunctorIfTrue => if null signature.target then signature:= - [getTargetFromRhs(lhs,rhs,giveFormalParametersValues(rest lhs,e)),: + [getTargetFromRhs(lhs,rhs,giveFormalParametersValues(lhs.args,e)),: signature.source] rhs:= addEmptyCapsuleIfNecessary(signature.target,rhs) compDefineFunctor(['DEF,lhs,signature,specialCases,rhs],m,e,nil, @@ -347,17 +347,31 @@ macroExpandInPlace(x,e) == macroExpand: (%Form,%Env) -> %Form macroExpand(x,e) == --not worked out yet - IDENTP x and (u := get(x,"macro",e)) => macroExpand(u,e) - atom x => x + atom x => + not IDENTP x or (u := get(x,'macro,e)) = nil => x + -- Don't expand a functional macro name by itself. + u is ['%mlambda,:.] => x + macroExpand(u,e) x is ['DEF,lhs,sig,spCases,rhs] => ['DEF,macroExpand(lhs,e),macroExpandList(sig,e),macroExpandList(spCases,e), macroExpand(rhs,e)] + -- macros should override niladic props + [op,:args] := x + IDENTP op and args = nil and niladicConstructorFromDB op and + (u := get(op,'macro, e)) => macroExpand(u,e) + IDENTP op and (get(op,'macro,e) is ['%mlambda,parms,body]) => + nargs := #args + nparms := #parms + msg := + nargs < nparms => '"Too few arguments" + nargs > nparms => '"Too many arguments" + nil + msg => (stackMessage(strconc(msg,'" to macro %1bp"),[op]); x) + args' := macroExpandList(args,e) + SUBLISLIS(args',parms,body) macroExpandList(x,e) macroExpandList(l,e) == - -- macros should override niladic props - (l is [name]) and IDENTP name and niladicConstructorFromDB name and - (u := get(name,"macro", e)) => macroExpand(u,e) [macroExpand(x,e) for x in l] --% constructor evaluation @@ -429,7 +443,7 @@ mkCategoryPackage(form is [op,:argl],cat,def) == capsuleDefAlist := fn(def,nil) where fn(x,oplist) == atom x => oplist x is ['DEF,y,:.] => [y,:oplist] - fn(rest x,fn(first x,oplist)) + fn(x.args,fn(x.op,oplist)) catvec := eval mkEvalableCategoryForm form fullCatOpList:=(JoinInner([catvec],$e)).1 catOpList := @@ -538,8 +552,8 @@ compDefineCategory2(form,signature,specialCases,body,m,e, mkConstructor: %Form -> %Form mkConstructor form == atom form => ['devaluate,form] - null rest form => ['QUOTE,[form.op]] - ['LIST,MKQ form.op,:[mkConstructor x for x in rest form]] + null form.args => ['QUOTE,[form.op]] + ['LIST,MKQ form.op,:[mkConstructor x for x in form.args]] compDefineCategory(df,m,e,prefix,fal) == $domainShell: local := nil -- holds the category of the object being compiled @@ -812,7 +826,7 @@ makeFunctorArgumentParameters(argl,sigl,target) == ['Join,s,['CATEGORY,'package,:ss]] fn(a,s) == isCategoryForm(s,$CategoryFrame) => - s is ["Join",:catlist] => genDomainViewList(a,rest s) + s is ["Join",:catlist] => genDomainViewList(a,s.args) [genDomainView(a,a,s,"getDomainView")] [a] @@ -968,12 +982,12 @@ compDefineCapsuleFunction(df is ['DEF,form,signature,specialCases,body], $formalArgList:= [:argl,:$formalArgList] --let target and local signatures help determine modes of arguments - argModeList:= - identSig:= hasSigInTargetCategory(argl,form,signature.target,e) => - (e:= checkAndDeclare(argl,form,identSig,e); rest identSig) + argModeList := + identSig := hasSigInTargetCategory(argl,form,signature.target,e) => + (e:= checkAndDeclare(argl,form,identSig,e); identSig.source) [getArgumentModeOrMoan(a,form,e) for a in argl] - argModeList:= stripOffSubdomainConditions(argModeList,argl) - signature':= [signature.target,:argModeList] + argModeList := stripOffSubdomainConditions(argModeList,argl) + signature' := [signature.target,:argModeList] if null identSig then --make $op a local function $e := put($op,'mode,['Mapping,:signature'],$e) @@ -1038,7 +1052,7 @@ compDefineCapsuleFunction(df is ['DEF,form,signature,specialCases,body], 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) + EQSUBSTLIST(form.args,take(# form.args,$FormalMapVariableList),signature) candidateSignatures(op,nmodes,slot1) == [sig for [[=op,sig,:.],:.] in slot1 | #sig = nmodes] @@ -1338,14 +1352,15 @@ compAdd(['add,$addForm,capsule],m,e) == $NRTaddForm := $addForm [$addForm,.,e]:= $addForm is ["%Comma",:.] => - $NRTaddForm := ["%Comma",:[NRTgetLocalIndex x for x in rest $addForm]] + $NRTaddForm := ["%Comma",:[NRTgetLocalIndex x for x in $addForm.args]] for x in $addForm.args repeat registerInlinableDomain(x,e) compOrCroak(compTuple2Record $addForm,$EmptyMode,e) registerInlinableDomain($addForm,e) compOrCroak($addForm,$EmptyMode,e) compCapsule(capsule,m,e) -compTuple2Record u == ['Record,:[[":",i,x] for i in 1.. for x in rest u]] +compTuple2Record u == + ['Record,:[[":",i,x] for i in 1.. for x in u.args]] compCapsule(['CAPSULE,:itemList],m,e) == $bootStrapMode = true => @@ -1472,7 +1487,7 @@ doIt(item,$predl) == item is ["where",b,:l] => compOrCroak(item,$EmptyMode,$e) item is ["MDEF",:.] => [.,.,$e]:= compOrCroak(item,$EmptyMode,$e) item is ['DEF,[op,:.],:.] => - body:= isMacro(item,$e) => $e:= put(op,"macro",body,$e) + body := isMacro(item,$e) => $e := putMacro(op,body,$e) [.,.,$e]:= t:= compOrCroak(item,$EmptyMode,$e) item.op := "CodeDefine" --Note that DescendCode, in CodeDefine, is looking for this @@ -1644,7 +1659,7 @@ DomainSubstitutionFunction(parameters,body) == [Subst(parameters,u) for u in body] not (body is ["Join",:.]) => body atom $definition => body - null rest $definition => body + null $definition.args => body --should not bother if it will only be called once name:= INTERN strconc(KAR $definition,";CAT") SETANDFILE(name,nil) diff --git a/src/interp/g-util.boot b/src/interp/g-util.boot index 89d2ebf4..267df900 100644 --- a/src/interp/g-util.boot +++ b/src/interp/g-util.boot @@ -650,6 +650,11 @@ addIntSymTabBinding(var,proplist,e is [[curContour,:.],:.]) == first(e).first := [[var,:proplist],:curContour] e +putMacro(lhs,rhs,e) == + atom lhs => put(lhs,'macro,rhs,e) + parms := [gensym() for p in lhs.args] + put(lhs.op,'macro,['%mlambda,parms,SUBLISLIS(parms,lhs.args,rhs)],e) + --% Syntax manipulation ++ Build a quasiquotation form for `x'. diff --git a/src/interp/postpar.boot b/src/interp/postpar.boot index c12ef1a7..b8b80a04 100644 --- a/src/interp/postpar.boot +++ b/src/interp/postpar.boot @@ -217,7 +217,7 @@ postComma u == postDef: %ParseTree -> %ParseForm postDef t == t isnt [defOp,lhs,rhs] => systemErrorHere ["postDef",t] - lhs is ["macro",name] => postMDef ["==>",name,rhs] + lhs is ['macro,name] => postMDef ["==>",name,rhs] recordHeaderDocumentation nil if $maxSignatureLineNumber ~= 0 then diff --git a/src/interp/wi1.boot b/src/interp/wi1.boot index f8f7c5c9..4cd28026 100644 --- a/src/interp/wi1.boot +++ b/src/interp/wi1.boot @@ -511,7 +511,7 @@ compMacro(form,m,e) == :formatUnabbreviated lhs,'" ==> ",:rhs,'%d] ["MDEF",lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e) m=$EmptyMode or m=$NoValueMode => - ["/throwAway",$NoValueMode,put(first lhs,"macro",rhs,e)] + ["/throwAway",$NoValueMode,putMacro(lhs.op,rhs,e)] --compMacro(form,m,e) == -- $macroIfTrue: local:= true @@ -527,7 +527,7 @@ compMacro(form,m,e) == -- ["MDEF",lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e) -- m=$EmptyMode or m=$NoValueMode => -- rhs := markMacro(lhs,rhs) --- ["/throwAway",$NoValueMode,put(first lhs,"macro",rhs,e)] +-- ["/throwAway",$NoValueMode,putMacro(lhs.op,rhs,e)] compSetq(oform,m,E) == ["%LET",form,val] := oform @@ -1076,7 +1076,7 @@ compDefine1(form,m,e) == --1. decompose after macro-expanding form ['DEF,lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e) $insideWhereIfTrue and isMacro(form,e) and (m=$EmptyMode or m=$NoValueMode) - => [lhs,m,put(first lhs,"macro",rhs,e)] + => [lhs,m,putMacro(lhs.op,rhs,e)] null signature.target and not MEMQ(KAR rhs,$BuiltinConstructorNames) and (sig:= getSignatureFromMode(lhs,e)) => -- here signature of lhs is determined by a previous declaration diff --git a/src/interp/wi2.boot b/src/interp/wi2.boot index 1bd25e3b..ce36da65 100644 --- a/src/interp/wi2.boot +++ b/src/interp/wi2.boot @@ -400,7 +400,7 @@ compMakeCategoryObject(c,$e) == nil macroExpand(x,e) == --not worked out yet - atom x => (u:= get(x,"macro",e) => macroExpand(u,e); x) + atom x => (u:= get(x,'macro,e) => macroExpand(u,e); x) x is ['DEF,lhs,sig,spCases,rhs] => ['DEF,macroExpand(lhs,e), macroExpandList(sig,e),macroExpandList(spCases,e), macroExpand(rhs,e)] @@ -1074,7 +1074,7 @@ rhsOfLetIsDomainForm code == doItDef item == ['DEF,[op,:.],:.] := item - body:= isMacro(item,$e) => $e:= put(op,"macro",body,$e) + body:= isMacro(item,$e) => $e := putMacro(op,body,$e) [.,.,$e]:= t:= compOrCroak(item,$EmptyMode,$e) chk(item,3) item.first := "CodeDefine" -- cgit v1.2.3