* 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.

8 files changed, 74 insertions, 35 deletions

diff --git a/src/ChangeLog b/src/ChangeLog
index 65268277..3017281c 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,5 +1,13 @@
 2010-07-03  Gabriel Dos Reis  <gdr@cs.tamu.edu>
 
+	* 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  <gdr@cs.tamu.edu>
+
 	* interp/define.boot (macroExpand): Tidy.  Only identifiers are
 	allowed to be macro names.
 
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"