From 159814d5cc62f3367369a7309fdf32efd21dbb13 Mon Sep 17 00:00:00 2001
From: dos-reis <gdr@axiomatics.org>
Date: Mon, 6 Oct 2008 11:03:50 +0000
Subject: 	* interp/functor.boot (DescendCode): Update capsule directory
 only 	for non-default implementations. 	* interp/c-util.boot
 ($capsuleDirectory): New. 	(clearCapsuleDirectory): Likewise. 
 (getCapsuleDirectoryEntry): Likewise. 	(updateCapsuleDirectory): Likewise. 
 (foldSpadcall): Likewise. 	(foldExportedFunctionReferences): Likewise. 
 * interp/define.boot (compFunctorBody): Use it.

---
 src/interp/c-util.boot  | 50 +++++++++++++++++++++++++++++++++++++++++++++++++
 src/interp/define.boot  | 11 ++++++++---
 src/interp/functor.boot | 12 ++++++++----
 3 files changed, 66 insertions(+), 7 deletions(-)

(limited to 'src/interp')

diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot
index 080e683d..be616cc5 100644
--- a/src/interp/c-util.boot
+++ b/src/interp/c-util.boot
@@ -38,6 +38,7 @@ namespace BOOT
 module c_-util where
   clearReplacement: %Symbol -> %Thing
   replaceSimpleFunctions: %Form -> %Form
+  foldExportedFunctionReferences: %List -> %List
 
 --% 
 ++ if true continue compiling after errors
@@ -836,6 +837,30 @@ ambiguousSignatureError(op, sigs) ==
   stackSemanticError(['"signature of lhs not unique.  Candidates are:",
     :displayAmbiguousSignatures($op,sigs)],nil)
 
+
+--% Capsule Directory Management
+
+++ Holds the list of slot number-export function pairs of 
+++ the current functor.
+$capsuleDirectory := nil
+
+clearCapsuleDirectory() ==
+  $capsuleDirectory := nil
+  $capsuleFunctionStack := nil
+
+++ Return the linkage name of the exported operation associated with
+++ slot number `slot'.  A nil entry means that either the operation
+++ is not defined, or it is conditional.
+getCapsuleDirectoryEntry slot ==
+  rest ASSOC(slot,$capsuleDirectory)
+
+++ Update the current capsule directory with entry controlled by 
+++ predicate `pred'.
+updateCapsuleDirectory(entry,pred) ==
+  pred ^= true => nil
+  entry isnt ["$",slot,["CONS",["dispatchFunction",fun],:.],:.] => nil
+  $capsuleDirectory := [[slot,:fun],:$capsuleDirectory]
+
 --% 
 
 -- A function is simple if it looks like a super combinator, and it
@@ -895,6 +920,31 @@ replaceSimpleFunctions form ==
   not EQ(fun',fun) => rplac(first form,fun')
   form
 
+
+++ Replace all SPADCALLs to operations defined in the current
+++ domain.  Conditional operations are not folded.
+foldSpadcall: %Form -> %Form
+foldSpadcall form ==
+  isAtomicForm form => form
+  for args in tails rest form repeat
+    foldSpadcall first args
+  first form isnt "SPADCALL" => form
+  fun := lastNode form
+  fun isnt [["getShellEntry","$",slot]] => form
+  null (op := getCapsuleDirectoryEntry slot) => form
+  rplac(first fun, "$")
+  rplac(first form, op)
+
+
+++ `defs' is a list of function definitions from the current domain.
+++ Walk that list and replace references to unconditional operations
+++ with their corresponding linkage names.  
+foldExportedFunctionReferences defs ==
+  for fun in defs repeat
+    foldSpadcall fun is [.,lamex] =>
+      rplac(third lamex, replaceSimpleFunctions third lamex)
+  defs
+
 ++ record optimizations permitted at level `level'.
 setCompilerOptimizations level ==
   level = nil => nil
diff --git a/src/interp/define.boot b/src/interp/define.boot
index 7dc8a79a..a2af1e8a 100644
--- a/src/interp/define.boot
+++ b/src/interp/define.boot
@@ -663,10 +663,15 @@ disallowNilAttribute x ==
 compFunctorBody(body,m,e,parForm) ==
   $bootStrapMode = true =>
     [bootStrapError($functorForm, _/EDITFILE),m,e]
-  $capsuleFunctionStack := nil   -- start collecting capsule functions.
+  clearCapsuleDirectory()        -- start collecting capsule functions.
   T:= compOrCroak(body,m,e)
-  COMP $capsuleFunctionStack
-  $capsuleFunctionStack := nil   -- release storage.
+  $capsuleFunctionStack := nreverse $capsuleFunctionStack
+  -- ??? Don't resolve default definitions, yet.
+  if $insideCategoryPackageIfTrue then
+    COMP $capsuleFunctionStack
+  else 
+    COMP foldExportedFunctionReferences $capsuleFunctionStack
+  clearCapsuleDirectory()        -- release storage.
   body is [op,:.] and MEMQ(op,'(add CAPSULE)) => T
   $NRTaddForm :=
     body is ["SubDomain",domainForm,predicate] => domainForm
diff --git a/src/interp/functor.boot b/src/interp/functor.boot
index af887d1a..a3e122c6 100644
--- a/src/interp/functor.boot
+++ b/src/interp/functor.boot
@@ -639,6 +639,9 @@ DescendCode(code,flag,viewAssoc,EnvToPass) ==
       dom
     body:= ['CONS,implem,dom]
     u:= SetFunctionSlots(sig,body,flag,'original)
+    -- ??? We do not resolve default definitions, yet.
+    if not $insideCategoryPackageIfTrue then
+      updateCapsuleDirectory(rest u, flag)
     ConstantCreator u =>
       if not (flag=true) then u:= ['COND,[ProcessCond(flag,viewAssoc),u]]
       $ConstantAssignments:= [u,:$ConstantAssignments]
@@ -657,9 +660,10 @@ DescendCode(code,flag,viewAssoc,EnvToPass) ==
   code
  
 ConstantCreator u ==
-  null u => nil
-  u is [q,.,.,u'] and (q in '(setShellEntry SETELT QSETREFV)) => ConstantCreator u'
-  u is ['CONS,:.] => nil
+  null u => false
+  u is [q,.,.,u'] and (q in '(setShellEntry SETELT QSETREFV)) => 
+    ConstantCreator u'
+  u is ['CONS,:.] => false
   true
  
 ProcessCond(cond,viewassoc) ==
@@ -683,7 +687,7 @@ SetFunctionSlots(sig,body,flag,mode) == --mode is either "original" or "adding"
 --+
   catNames := ['$]
   for u in $catvecList for v in catNames repeat
-    null body => return NIL
+    null body => return nil
     for catImplem in LookUpSigSlots(sig,u.1) repeat
       if catImplem is [q,.,index] and (q='ELT or q='CONST)
          then
-- 
cgit v1.2.3