aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/ChangeLog11
-rw-r--r--src/interp/i-coerce.boot10
-rw-r--r--src/interp/i-funsel.boot2
-rw-r--r--src/interp/nrunfast.boot16
4 files changed, 37 insertions, 2 deletions
diff --git a/src/ChangeLog b/src/ChangeLog
index 04d74ab8..fb0f44e8 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,3 +1,14 @@
+2009-06-12 Gabriel Dos Reis <gdr@cs.tamu.edu>
+
+ 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.
+
2009-06-11 Gabriel Dos Reis <gdr@cs.tamu.edu>
* algebra/: Don't quote '!' at end of names.
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
--=======================================================