* interp/lisplib.boot (compDefineExports): Now take operation

	exported list, instead of category object.  Tidy.
	* interp/define.boot (compDefineFunctor1): Adjust call to
	compDefineExports. 

5 files changed, 35 insertions, 12 deletions

diff --git a/src/ChangeLog b/src/ChangeLog
index 68248438..53ea2f32 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,3 +1,10 @@
+2008-11-17  Gabriel Dos Reis  <gdr@cs.tamu.edu>
+
+	* interp/lisplib.boot (compDefineExports): Now take operation
+	exported list, instead of category object.  Tidy.
+	* interp/define.boot (compDefineFunctor1): Adjust call to
+	compDefineExports. 
+
 2008-11-16  Gabriel Dos Reis  <gdr@cs.tamu.edu>
 
 	* lisp/core.lisp.in (|getOptionValue|): Make second argument optional.
diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot
index c91458e1..686192e7 100644
--- a/src/interp/compiler.boot
+++ b/src/interp/compiler.boot
@@ -73,7 +73,6 @@ compFormMatch: (%Modemap,%List) -> %Boolean
 compFormWithModemap: (%Form,%Mode,%Env,%Modemap) -> %Maybe %Triple
 compToApply: (%Form,%List,%Mode,%Env) -> %Maybe %Triple
 compApplication: (%Form,%List,%Mode,%Env,%Triple) -> %Maybe %Triple
-compApplyModemap: (%Form,%Modemap,%Env,%List) -> %Maybe %Triple
 
 primitiveType: %Thing -> %Mode
 modeEqual: (%Form,%Form) -> %Boolean
diff --git a/src/interp/define.boot b/src/interp/define.boot
index 8b9b5677..5526a3fb 100644
--- a/src/interp/define.boot
+++ b/src/interp/define.boot
@@ -582,7 +582,7 @@ compDefineFunctor1(df is ['DEF,form,signature,$functorSpecialCases,body],
     $e:= giveFormalParametersValues(argl,$e)
     [ds,.,$e]:= compMakeCategoryObject(target,$e) or return
        stackAndThrow('"   cannot produce category object: %1pb",[target])
-    $compileExportsOnly => compDefineExports($op, ds, signature',$e)
+    $compileExportsOnly => compDefineExports($op, ds.1, signature',$e)
     $domainShell:= COPY_-SEQ ds
 --+ copy needed since slot1 is reset; compMake.. can return a cached vector
     attributeList := disallowNilAttribute ds.2 --see below under "loadTimeAlist"
@@ -623,7 +623,6 @@ compDefineFunctor1(df is ['DEF,form,signature,$functorSpecialCases,body],
       then $e:= augModemapsFromCategoryRep('_$,ab,cb,target,$e)
       else $e:= augModemapsFromCategory('_$,'_$,'_$,target,$e)
     $signature:= signature'
-    operationAlist:= SUBLIS($pairlis,$domainShell.(1))
     parSignature:= SUBLIS($pairlis,signature')
     parForm:= SUBLIS($pairlis,form)
  
diff --git a/src/interp/lisplib.boot b/src/interp/lisplib.boot
index 755e3f8e..5619a231 100644
--- a/src/interp/lisplib.boot
+++ b/src/interp/lisplib.boot
@@ -225,8 +225,8 @@ convertOpAlist2compilerInfo(opalist) ==
    "append"/[[formatSig(op,sig) for sig in siglist]
                 for [op,:siglist] in opalist] where
       formatSig(op, [typelist, slot,:stuff]) ==
-          pred := if stuff then first stuff else 'T
-          impl := if CDR stuff then CADR stuff else 'ELT -- handles 'CONST
+          pred := if stuff then first stuff else true
+          impl := if rest stuff then second stuff else "ELT" -- handles 'CONST
           [[op, typelist], pred, [impl, '$, slot]]
    
 updateCategoryFrameForConstructor(constructor) ==
@@ -706,16 +706,33 @@ getIndexTable dir ==
     nil)
 
 --%
-compDefineExports(op,catobj,sig,e) ==
+compDefineExports(op,ops,sig,e) ==
   not $LISPLIB => systemErrorHere "compDefineExports"
+  -- Ensure constructor parameters appear as formals
+  sig := SUBLIS($pairlis, sig)
+  ops := SUBLIS($pairlis,ops)
+  -- Since we don't compile the capsule, the slot numbers are
+  -- most likely bogus.  Nullify them so people don't think they
+  -- bear any meaningful semantics (well, they should not think
+  -- these are forwarding either).
+  for entry in ops repeat
+    fixupSigloc entry where
+      fixupSigloc entry ==
+        [opsig,pred,funsel] := entry
+	if pred ^= 'T then 
+           rplac(second entry, simpBool pred)
+	funsel is [op,a,:.] and op in '(ELT CONST) =>
+          rplac(third entry,[op,a,nil])
+  ops := listSort(function GGREATERP, ops, function first)
   libName := getConstructorAbbreviation op
   exportsFile := strconc(STRING libName,'".sig")
   removeFile exportsFile
   withOutputFile(s,exportsFile, 
     PRETTYPRINT(
-      ["put", quoteForm op, quoteForm "isFunctor", quoteForm catobj.1,
-        ["addModemap", quoteForm op, quoteForm first sig,
-           quoteForm sig, true, quoteForm op,
-             ["put", quoteForm op, quoteForm "mode",
-                quoteForm ["Mapping",:sig], "$CategoryFrame"]]], s))
+      ["SETQ", "$CategoryFrame",
+        ["put", quoteForm op, quoteForm "isFunctor", quoteForm ops,
+          ["addModemap", quoteForm op, quoteForm first sig,
+             quoteForm sig, true, quoteForm op,
+               ["put", quoteForm op, quoteForm "mode",
+                 quoteForm ["Mapping",:sig], "$CategoryFrame"]]]], s))
   [op,["Mapping",:sig],e]
diff --git a/src/interp/modemap.boot b/src/interp/modemap.boot
index 38ee6e52..fce0fb46 100644
--- a/src/interp/modemap.boot
+++ b/src/interp/modemap.boot
@@ -332,7 +332,8 @@ evalAndSub(domainName,viewName,functorForm,form,$e) ==
   [substAlist,$e]
  
 getOperationAlist(name,functorForm,form) ==
-  if atom name and niladicConstructorFromDB name then functorForm:= [functorForm]
+  if atom name and niladicConstructorFromDB name then 
+    functorForm:= [functorForm]
 -- (null isConstructorForm functorForm) and (u:= isFunctor functorForm)
   (u:= isFunctor functorForm) and not
     ($insideFunctorIfTrue and first functorForm=first $functorForm) => u