From 9e86e73fe1aa9115233952ffbf8188b169677d6e Mon Sep 17 00:00:00 2001
From: dos-reis <gdr@axiomatics.org>
Date: Fri, 12 Jun 2009 17:35:50 +0000
Subject: 	Support retract of domains. 	* interp/i-funsel.boot
 (findFunctionInDomain): Don't look into 	categories. 	*
 interp/i-coerce.boot (retract): Retract domain objects too. 	(retract1): Do
 it. 	(coerceInteractive): Likewise. 	* interp/nrunfast.boot
 (getDomainCategoriesVector): New. 	(getDomainCompleteCategories):
 Likewise.

---
 src/interp/i-coerce.boot | 10 +++++++++-
 src/interp/i-funsel.boot |  2 ++
 src/interp/nrunfast.boot | 16 +++++++++++++++-
 3 files changed, 26 insertions(+), 2 deletions(-)

(limited to 'src/interp')

diff --git a/src/interp/i-coerce.boot b/src/interp/i-coerce.boot
index a46711e0..b4756002 100644
--- a/src/interp/i-coerce.boot
+++ b/src/interp/i-coerce.boot
@@ -91,7 +91,9 @@ retract object ==
   STRINGP type => 'failed
   type = $EmptyMode => 'failed
   val := objVal object
-  not isWrapped val and val isnt ["%Map",:.] => 'failed
+  if not isWrapped val and val isnt ["%Map",:.] then
+    type ^= $Domain => return "failed"
+    val := wrap eval val
   type' := equiType(type)
   (ans := retract1 objNew(val,equiType(type))) = 'failed => ans
   objNew(objVal ans,eqType objMode ans)
@@ -108,6 +110,8 @@ retract1 object ==
   type = $PositiveInteger =>    objNew(val,$NonNegativeInteger)
   type = $NonNegativeInteger => objNew(val,$Integer)
   type = $Integer and SINTP unwrap val => objNew(val, $SingleInteger)
+  type = $Domain => 
+    objNew(val, ["Join",:getDomainCompleteCategories unwrap val])
   type' := equiType(type)
   if not EQ(type,type') then object := objNew(val,type')
   (1 = #type') or (type' is ['Union,:.]) or
@@ -456,6 +460,7 @@ canCoerce1(t1,t2) ==
         canCoerce(t1,t) and canCoerceByFunction(t,t2) and 'T
     ans or member(t1,'((PositiveInteger) (NonNegativeInteger)))
       and canCoerce($Integer,t2)
+  t1 is ["Join",:.] => not null member(t2,rest t1) -- for now, gdr.
 
 canCoerceFrom0(t1,t2) ==
 -- top level test for coercion, which transfers all RN, RF and RR into
@@ -745,6 +750,9 @@ coerceInteractive(triple,t2) ==
   t2 = '$NoValueMode => objNew(val,t2)
   if t2 is ['SubDomain,x,.] then t2:= x
   -- JHD added category Aug 1996 for BasicMath
+  -- Categories are not domain of computations so we have to handle
+  -- them by hand, until we get a better world. -- gdr, 2009-06-12.
+  t1 is ["Join",:.] and canCoerce(t1,t2) => objNew(val,t2)
   member(t1,$LangSupportTypes) =>
     t2 = $OutputForm => objNew(val,t2)
     t1 = $Domain and conceptualType t2 = $Category 
diff --git a/src/interp/i-funsel.boot b/src/interp/i-funsel.boot
index 89942903..7e4700e3 100644
--- a/src/interp/i-funsel.boot
+++ b/src/interp/i-funsel.boot
@@ -776,6 +776,8 @@ findFunctionInDomain(op,dc,tar,args1,args2,$Coerce,$SubDom) ==
   -- tar may be NIL (= unknown)
   null isLegitimateMode(tar, nil, nil) => nil
   dcName:= CAR dc
+  -- A category is not a domain of computation, so get out 
+  categoryForm? dcName => nil
   member(dcName,'(Union Record Mapping Enumeration)) =>
     -- First cut code that ignores args2, $Coerce and $SubDom
     -- When domains no longer have to have Set, the hard coded 6 and 7
diff --git a/src/interp/nrunfast.boot b/src/interp/nrunfast.boot
index e7dc7a19..ff6c517c 100644
--- a/src/interp/nrunfast.boot
+++ b/src/interp/nrunfast.boot
@@ -62,6 +62,20 @@ isNewWorldDomain domain ==
  
 getDomainByteVector dom == 
   CDDR dom.4
+
+++ Return the sequence of categories `dom' belongs to, as a vector
+++ of lazy category forms.
+getDomainCategoriesVector dom ==
+  second(dom.4)
+
+++ Same as getDomainCategoriesVector except that we return a list of
+++ input forms for the categories.
+getDomainCompleteCategories dom ==
+  vec := getDomainCategoriesVector dom
+  cats := nil
+  for i in 0..MAXINDEX vec repeat
+    cats := [newExpandLocalType(vec.i,dom,dom), :cats]
+  nreverse cats
  
 getOpCode(op,vec,max) ==
 --search Op vector for "op" returning code if found, nil otherwise
@@ -671,7 +685,7 @@ lazyMatchAssocV1(x,vec,domain) ==               --old style slot4
 --    predvec := domain.3
 --    testBitVector(predvec,predIndex)
 --  false
- 
+
 --=======================================================
 --                   Utility Functions
 --=======================================================
-- 
cgit v1.2.3