From a9f8febec0969527822d333548739eafd5fce99e Mon Sep 17 00:00:00 2001
From: dos-reis <gdr@axiomatics.org>
Date: Sun, 19 May 2013 14:16:33 +0000
Subject: 	* interp/define.boot (sourceMatches): New. 
 (getDollarName): Likewise. 	(getSignature): Them.  Tidy. 
 (setDollarName): New. 	(compDefineFunctor1): Use it.

---
 src/interp/define.boot | 30 ++++++++++++++++++++++++++++--
 1 file changed, 28 insertions(+), 2 deletions(-)

(limited to 'src/interp')

diff --git a/src/interp/define.boot b/src/interp/define.boot
index c11a4fbf..df55d0cc 100644
--- a/src/interp/define.boot
+++ b/src/interp/define.boot
@@ -1424,6 +1424,19 @@ substituteCategoryArguments(argl,catform) ==
   argl := substitute("$$","$",argl)
   applySubst(pairList($FormalMapVariableList,argl),catform)
  
+++ Register in the current environment, the variable name for the
+++ current domain.  Usually it is $; except when we are compiling
+++ a synthesized package containing category defaults.
+setDollarName(form,env) ==
+  name :=
+    isCategoryPackageName form.op => first form.args
+    '$
+  put('%compilerData,'%dollar,name,env)
+
+++ Retrieve the variable name for the current instantiation.
+getDollarName env ==
+  get('%compilerData,'%dollar,env)
+
 compDefineFunctor(df,m,e,fal) ==
   $domainShell: local := nil -- holds the category of the object being compiled
   $profileCompiler: local := true
@@ -1458,6 +1471,7 @@ compDefineFunctor1(df is ['DEF,form,signature,body],m,$e,$formalArgList) ==
     dbCompilerData(db) := makeCompilationData()
     dbFormalSubst(db) := pairList(form.args,$FormalMapVariableList)
     $e := registerConstructor($op,$e)
+    $e := setDollarName(form,$e)
     deduceImplicitParameters(db,$e)
     $formalArgList:= [:form.args,:$formalArgList]
     -- all defaulting packages should have caching turned off
@@ -2017,13 +2031,25 @@ addDomain(domain,e) ==
   if not isCategoryForm(domain,e) and name ~= "Mapping" then
     unknownTypeError name
   e        --is not a functor
- 
+
+++ Subroutine of getSignature.
+++ Return true if the given parameter type list `src' is a refinment of
+++ of the seed `pat'.
+sourceMatches?(src,pat) ==
+  repeat
+    src = nil => return pat = nil
+    pat = nil => return src = nil
+    pat.first ~= nil and src.first ~= pat.first => return false
+    src := src.rest
+    pat := pat.rest
 
 getSignature(op,argModeList,e) ==
   mmList := get(op,'modemap,e)
+  dollar := getDollarName e
   sigl := removeDuplicates
       [sig for [[dc,:sig],[pred,:.]] in mmList
-         | dc='$ and sig.source = argModeList and knownInfo(pred,e)]
+         | dc=dollar and sourceMatches?(sig.source,argModeList)
+            and knownInfo(pred,e)]
   sigl is [sig] => sig
   null sigl =>
     getXmode(op,e) is ['Mapping,:sig] => sig
-- 
cgit v1.2.3