aboutsummaryrefslogtreecommitdiff
path: root/src/interp/buildom.boot
diff options
context:
space:
mode:
Diffstat (limited to 'src/interp/buildom.boot')
-rw-r--r--src/interp/buildom.boot351
1 files changed, 191 insertions, 160 deletions
diff --git a/src/interp/buildom.boot b/src/interp/buildom.boot
index f1ec268a..a78a281b 100644
--- a/src/interp/buildom.boot
+++ b/src/interp/buildom.boot
@@ -36,6 +36,9 @@
-- be written in ScratchpadII yet. They are not cached because they
-- are very cheap to instantiate.
-- SMW and SCM July 86
+-- These have been substantially modified to work with the new
+-- runtime system.
+-- GDR, March 2008.
import '"sys-macros"
)package "BOOT"
@@ -50,13 +53,19 @@ $commonCategoryAncestors ==
++ Default category packages for Record, Union, Mapping and
++ Enumeration domains.
$commonCategoryDefaults ==
- ['(SetCategory_&), '(BasicType_&), NIL]
+ ['(SetCategory_& $), '(BasicType_& $), NIL]
+
+++ The slot number in a domain shell that holds the first parameter to
+++ a domain constructor.
+$FirstParamSlot ==
+ 6
--% Record
-- Want to eventually have the elts and setelts.
-- Record is a macro in BUILDOM LISP. It takes out the colons.
-isRecord type == type is ["Record",:.]
+isRecord type ==
+ type is ["Record",:.]
RecordInner args ==
-- this is old and should be removed wherever it occurs
@@ -64,63 +73,76 @@ RecordInner args ==
sayBrightly '"-->> Whoops! RecordInner called from this code."
Record0 VEC2LIST args
+++ returns the code for the `n'th item recorded in a domain shell,
+++ according to the old runtime system. Note that the old runtime
+++ scheme is used only for the handful of constructors created
+++ in this file.
+oldSlotCode: %Short -> %Short
+oldSlotCode n ==
+ 2 * ($FirstParamSlot + n)
+
Record0 args ==
- dom := newShell 10
- -- JHD added an extra slot to cache EQUAL methods
- dom.0 := ["Record", :[["_:", CAR a, devaluate CDR a] for a in args]]
- dom.1 :=
- [function lookupInTable,dom,
- [["_=",[[["Boolean"],"_$","_$"],:12]],
- ["coerce",[[$OutputForm,"_$"],:14]]]]
- dom.2 := NIL
- dom.3 := ["RecordCategory",:QCDR dom.0]
- dom.4 :=
- [$commonCategoryDefaults, $commonCategoryAncestors]
- dom.5 := [CDR a for a in args]
- dom.6 := [function RecordEqual, :dom]
- dom.7 := [function RecordPrint, :dom]
- dom.8 := [function Undef, :dom]
- -- following is cache for equality functions
- dom.9 := if (n:= LENGTH args) <= 2
- then [NIL,:NIL]
- else newShell n
- dom
+ nargs := #args
+ dom := newShell(nargs + 10)
+ -- JHD added an extra slot to cache EQUAL methods
+ dom.0 := ["Record", :[[":", first a, devaluate rest a] for a in args]]
+ dom.1 :=
+ ["lookupInTable",dom,
+ [["=",[[$Boolean,"$","$"],:oldSlotCode nargs]],
+ ["~=",[[$Boolean,"$","$"],:0]],
+ ["coerce",[[$OutputForm,"$"],:oldSlotCode(nargs + 1)]]]]
+ dom.2 := NIL
+ dom.3 := ["RecordCategory",:QCDR dom.0]
+ dom.4 := [$commonCategoryDefaults, $commonCategoryAncestors]
+ dom.5 := nil
+ for i in $FirstParamSlot.. for a in args repeat dom.i := rest a
+ dom.($FirstParamSlot + nargs) := [function RecordEqual, :dom]
+ dom.($FirstParamSlot + nargs + 1) := [function RecordPrint, :dom]
+ dom.($FirstParamSlot + nargs + 2) := [function Undef, :dom]
+-- following is cache for equality functions
+ dom.($FirstParamSlot + nargs + 3) := if nargs <= 2
+ then [NIL,:NIL]
+ else newShell nargs
+ dom
RecordEqual(x,y,dom) ==
+ nargs := #rest(dom.0)
PAIRP x =>
b:=
- SPADCALL(CAR x, CAR y, CAR(dom.9) or
- CAR RPLACA(dom.9,findEqualFun(dom.5.0)))
- NULL rest(dom.5) => b
+ SPADCALL(first x, first y, first(dom.(nargs + 9)) or
+ first RPLACA(dom.(nargs + 9),findEqualFun(dom.$FirstParamSlot)))
+ nargs = 1 => b
b and
- SPADCALL(CDR x, CDR y, CDR (dom.9) or
- CDR RPLACD(dom.9,findEqualFun(dom.5.1)))
+ SPADCALL(rest x, rest y, rest (dom.(nargs + 9)) or
+ rest RPLACD(dom.(nargs + 9),findEqualFun(dom.($FirstParamSlot+1))))
VECP x =>
- equalfuns := dom.9
- and/[SPADCALL(x.i,y.i,equalfuns.i or (equalfuns.i:=findEqualFun(fdom)))
- for i in 0.. for fdom in dom.5]
+ equalfuns := dom.(nargs + 9)
+ and/[SPADCALL(x.i,y.i,equalfuns.i or _
+ (equalfuns.i:=findEqualFun(dom.($FirstParamSlot + i))))_
+ for i in 0..(nargs - 1)]
error '"Bug: Silly record representation"
-RecordPrint(x,dom) == coerceRe2E(x,dom.3)
+RecordPrint(x,dom) ==
+ coerceRe2E(x,dom.3)
coerceVal2E(x,m) ==
objValUnwrap coerceByFunction(objNewWrap(x,m),$OutputForm)
findEqualFun(dom) ==
- compiledLookup("_=",[$Boolean,"$","$"],dom)
+ compiledLookup("=",[$Boolean,"$","$"],dom)
coerceRe2E(x,source) ==
- n := # CDR source
+ n := # rest source
n = 1 =>
["construct",
- ["_=", source.1.1, coerceVal2E(CAR x,source.1.2)] ]
+ ["=", source.1.1, coerceVal2E(first x,source.1.2)] ]
n = 2 =>
["construct",
- ["_=", source.1.1, coerceVal2E(CAR x,source.1.2)], _
- ["_=", source.2.1, coerceVal2E(CDR x,source.2.2)] ]
+ ["=", source.1.1, coerceVal2E(first x,source.1.2)], _
+ ["=", source.2.1, coerceVal2E(rest x,source.2.2)] ]
VECP x =>
['construct,
- :[["_=",tag,coerceVal2E(x.i, fdom)]
+ :[["=",tag,coerceVal2E(x.i, fdom)]
for i in 0.. for [.,tag,fdom] in rest source]]
error '"Bug: ridiculous record representation"
@@ -129,22 +151,24 @@ coerceRe2E(x,source) ==
-- Want to eventually have the coerce to and from branch types.
Union(:args) ==
- dom := newShell 9
- dom.0 := ["Union", :[(if a is ["_:",tag,domval] then ["_:",tag,devaluate domval]
- else devaluate a) for a in args]]
- dom.1 :=
- [function lookupInTable,dom,
- [["_=",[[["Boolean"],"_$","_$"],:12]],
- ["coerce",[[$OutputForm,"_$"],:14]]]]
- dom.2 := NIL
- dom.3 := ["UnionCategory",:QCDR dom.0]
- dom.4 :=
- [$commonCategoryDefaults, $commonCategoryAncestors]
- dom.5 := args
- dom.6 := [function UnionEqual, :dom]
- dom.7 := [function UnionPrint, :dom]
- dom.8 := [function Undef, :dom]
- dom
+ nargs := #args
+ dom := newShell (nargs + 9)
+ dom.0 := ["Union", :[(if a is [":",tag,domval] then [":",tag,devaluate domval]
+ else devaluate a) for a in args]]
+ dom.1 :=
+ ["lookupInTable",dom,
+ [["=",[[$Boolean,"$","$"],:oldSlotCode nargs]],
+ ["~=",[[$Boolean,"$","$"],:0]],
+ ["coerce",[[$OutputForm,"$"],:oldSlotCode (nargs+1)]]]]
+ dom.2 := NIL
+ dom.3 := ["UnionCategory",:QCDR dom.0]
+ dom.4 := [$commonCategoryDefaults, $commonCategoryAncestors]
+ dom.5 := nil
+ for i in $FirstParamSlot.. for a in args repeat dom.i := a
+ dom.($FirstParamSlot + nargs) := [function UnionEqual, :dom]
+ dom.($FirstParamSlot + nargs + 1) := [function UnionPrint, :dom]
+ dom.($FirstParamSlot + nargs + 2) := [function Undef, :dom]
+ dom
UnionEqual(x, y, dom) ==
["Union",:branches] := dom.0
@@ -181,58 +205,66 @@ coerceUn2E(x,source) ==
-- Want to eventually have elt: ($, args) -> target
Mapping(:args) ==
- dom := newShell 9
- dom.0 := ["Mapping", :[devaluate a for a in args]]
- dom.1 :=
- [function lookupInTable,dom,
- [["_=",[[["Boolean"],"_$","_$"],:12]],
- ["coerce",[[$OutputForm,"_$"],:14]]]]
- dom.2 := NIL
- dom.3 :=
- '(SetCategory)
- dom.4 :=
- [$commonCategoryDefaults, $commonCategoryAncestors]
- dom.5 := args
- dom.6 := [function MappingEqual, :dom]
- dom.7 := [function MappingPrint, :dom]
- dom.8 := [function Undef, :dom]
- dom
+ nargs := #args
+ dom := newShell(nargs + 9)
+ dom.0 := ["Mapping", :[devaluate a for a in args]]
+ dom.1 :=
+ ["lookupInTable",dom,
+ [["=",[[$Boolean,"$","$"],:oldSlotCode nargs]],
+ ["~=",[[$Boolean,"$","$"],:0]],
+ ["coerce",[[$OutputForm,"$"],:oldSlotCode(nargs + 1)]]]]
+ dom.2 := NIL
+ dom.3 := '(SetCategory)
+ dom.4 := [$commonCategoryDefaults, $commonCategoryAncestors]
+ dom.5 := nil
+ for i in $FirstParamSlot.. for a in args repeat dom.i := a
+ dom.($FirstParamSlot + nargs) := [function MappingEqual, :dom]
+ dom.($FirstParamSlot + nargs + 1) := [function MappingPrint, :dom]
+ dom.($FirstParamSlot + nargs + 2) := [function Undef, :dom]
+ dom
MappingEqual(x, y, dom) == EQ(x,y)
MappingPrint(x, dom) == coerceMap2E(x)
coerceMap2E(x) ==
-- nrlib domain
- ARRAYP CDR x => ["theMap", BPINAME CAR x,
- if $testingSystem then 0 else REMAINDER(HASHEQ CDR x, 1000)]
+ ARRAYP rest x => ["theMap", BPINAME first x,
+ if $testingSystem then 0 else REMAINDER(HASHEQ rest x, 1000)]
-- aldor
- ["theMap", BPINAME CAR x ]
+ ["theMap", BPINAME first x ]
--% Enumeration
Enumeration(:"args") ==
- dom := newShell 9
- -- JHD added an extra slot to cache EQUAL methods
- dom.0 := ["Enumeration", :args]
- dom.1 :=
- [function lookupInTable,dom,
- [["_=",[[["Boolean"],"_$","_$"],:12]],
- ["coerce",[[$OutputForm,"_$"],:14], [["_$", $Symbol], :16]]
- ]]
- dom.2 := NIL
- dom.3 := ["EnumerationCategory",:QCDR dom.0]
- dom.4 :=
- [$commonCategoryDefaults, $commonCategoryAncestors]
- dom.5 := args
- dom.6 := [function EnumEqual, :dom]
- dom.7 := [function EnumPrint, :dom]
- dom.8 := [function createEnum, :dom]
- dom
-
-EnumEqual(e1,e2,dom) == e1=e2
-EnumPrint(enum, dom) == dom.5.enum
+ nargs := #nargs
+ dom := newShell(nargs + 9)
+ -- JHD added an extra slot to cache EQUAL methods
+ dom.0 := ["Enumeration", :args]
+ dom.1 :=
+ ["lookupInTable",dom,
+ [["=",[[$Boolean,"$","$"],:oldSlotCode nargs]],
+ ["~=",[[$Boolean,"$","$"],:0]],
+ ["coerce",[[$OutputForm,"$"],:oldSlotCode(nargs+1)],
+ [["$", $Symbol], :oldSlotCode(nargs+2)]]
+ ]]
+ dom.2 := NIL
+ dom.3 := ["EnumerationCategory",:QCDR dom.0]
+ dom.4 := [$commonCategoryDefaults, $commonCategoryAncestors]
+ dom.5 := nil
+ for i in $FirstParamSlot.. for a in args repeat dom.i := a
+ dom.($FirstParamSlot + nargs) := [function EnumEqual, :dom]
+ dom.($FirstParamSlot + nargs + 1) := [function createEnum, :dom]
+ dom.($FirstParamSlot + nargs + 2) := [function EnumPrint, :dom]
+ dom
+
+EnumEqual(e1,e2,dom) ==
+ e1=e2
+
+EnumPrint(enum, dom) ==
+ (rest(dom.0)).enum
+
createEnum(sym, dom) ==
- args := dom.5
+ args := rest(dom.0)
val := -1
for v in args for i in 0.. repeat
sym=v => return(val:=i)
@@ -260,56 +292,53 @@ constructorCategory (title is [op,:.]) ==
--mkMappingFunList(nam,mapForm,e) == [[],e]
mkMappingFunList(nam,mapForm,e) ==
+ nargs := #rest mapForm
dc := GENSYM()
sigFunAlist:=
- [["_=",[["Boolean"],nam ,nam],["ELT",dc,6]],
- ["coerce",[$OutputForm,nam],["ELT",dc,7]]]
+ [["=",[$Boolean,nam ,nam], ["ELT",dc,$FirstParamSlot + nargs]],
+ ["~=",[$Boolean,nam,nam],["ELT",dc,0]],
+ ["coerce",[$OutputForm,nam], ["ELT",dc,$FirstParamSlot + nargs + 1]]]
[substitute(nam,dc,substituteDollarIfRepHack sigFunAlist),e]
mkRecordFunList(nam,["Record",:Alist],e) ==
len:= #Alist
-
--- for (.,a,.) in Alist do
--- if getmode(a,e) then MOAN("Symbol: ",a,
--- " must not be both a variable and literal")
--- e:= put(a,"isLiteral","true",e)
dc := GENSYM()
sigFunAlist:=
- --:((a,(A,nam),("XLAM",("$1","$2"),("RECORDELT","$1",i,len)))
- -- for i in 0..,(.,a,A) in Alist),
-
[["construct",[nam,:[A for [.,a,A] in Alist]],"mkRecord"],
- ["_=",[["Boolean"],nam ,nam],["ELT",dc,6]],
- ["coerce",[$OutputForm,nam],["ELT",dc,7]],:
- [["elt",[A,nam,PNAME a],["XLAM",["$1","$2"],["RECORDELT","$1",i,len]]]
- for i in 0.. for [.,a,A] in Alist],:
- [["setelt",[A,nam,PNAME a,A],["XLAM",["$1","$2","$3"],
- ["SETRECORDELT","$1",i, len,"$3"]]]
- for i in 0.. for [.,a,A] in Alist],:
- [["copy",[nam,nam],["XLAM",["$1"],["RECORDCOPY",
- "$1",len]]]]]
+ ["=",[$Boolean,nam ,nam],["ELT",dc,$FirstParamSlot + len]],
+ ["~=",[$Boolean,nam,nam],["ELT",dc,0]],
+ ["coerce",[$OutputForm,nam],["ELT",dc,$FirstParamSlot+len+1]],:
+ [["elt",[A,nam,PNAME a],["XLAM",["$1","$2"],["RECORDELT","$1",i,len]]]
+ for i in 0.. for [.,a,A] in Alist],:
+ [["setelt",[A,nam,PNAME a,A],["XLAM",["$1","$2","$3"],
+ ["SETRECORDELT","$1",i, len,"$3"]]]
+ for i in 0.. for [.,a,A] in Alist],:
+ [["copy",[nam,nam],["XLAM",["$1"],["RECORDCOPY",
+ "$1",len]]]]]
[substitute(nam,dc,substituteDollarIfRepHack sigFunAlist),e]
mkNewUnionFunList(name,form is ["Union",:listOfEntries],e) ==
+ nargs := #listOfEntries
dc := name
m := dollarIfRepHack name
--2. create coercions from subtypes to subUnion
cList:=
- [["_=",[["Boolean"],name ,name],["ELT",dc,6]],
- ["coerce",[$OutputForm,name],["ELT",dc,7]],:
- ("append"/
- [[["construct",[name,type],["XLAM",["#1"],["CONS",i,"#1"]]],
- ["elt",[type,name,tag],cdownFun],
- ["case",['(Boolean),name,tag],
- ["XLAM",["#1"],["QEQCAR","#1",i]]]]
- for [.,tag,type] in listOfEntries for i in 0..])] where
- cdownFun() ==
- gg:=GENSYM()
- $InteractiveMode =>
- ["XLAM",["#1"],["PROG1",["QCDR","#1"],
- ["check_-union",["QEQCAR","#1",i],type,"#1"]]]
- ["XLAM",["#1"],["PROG2",["LET",gg,"#1"],["QCDR",gg],
- ["check_-union",["QEQCAR",gg,i],type,gg]]]
+ [["=",[$Boolean,name ,name],["ELT",dc,$FirstParamSlot+nargs]],
+ ["~=",[$Boolean,name,name],["ELT",dc,0]],
+ ["coerce",[$OutputForm,name],["ELT",dc,$FirstParamSlot+nargs+1]],:
+ ("append"/
+ [[["construct",[name,type],["XLAM",["#1"],["CONS",i,"#1"]]],
+ ["elt",[type,name,tag],cdownFun],
+ ["case",['(Boolean),name,tag],
+ ["XLAM",["#1"],["QEQCAR","#1",i]]]]
+ for [.,tag,type] in listOfEntries for i in 0..])] where
+ cdownFun() ==
+ gg:=GENSYM()
+ $InteractiveMode =>
+ ["XLAM",["#1"],["PROG1",["QCDR","#1"],
+ ["check-union",["QEQCAR","#1",i],type,"#1"]]]
+ ["XLAM",["#1"],["PROG2",["LET",gg,"#1"],["QCDR",gg],
+ ["check-union",["QEQCAR",gg,i],type,gg]]]
[cList,e]
mkEnumerationFunList(nam,["Enumeration",:SL],e) ==
@@ -317,50 +346,52 @@ mkEnumerationFunList(nam,["Enumeration",:SL],e) ==
dc := nam
cList :=
[nil,
- ["_=",[["Boolean"],nam ,nam],["ELT",dc,6]],
- ["_^_=",[["Boolean"],nam ,nam],["ELT",dc,7]],
- ["coerce",[nam, ["Symbol"]], ["ELT", dc, 8]],
- ["coerce",[["OutputForm"],nam],["ELT",dc, 9]]]
+ ["=",[$Boolean,nam ,nam],["ELT",dc,$FirstParamSlot+len]],
+ ["~=",[$Boolean,nam ,nam],["ELT",dc,0]],
+ ["coerce",[nam, ["Symbol"]], ["ELT", dc,$FirstParamSlot+len+1]],
+ ["coerce",[["OutputForm"],nam],["ELT",dc,$FirstParamSlot+len+2]]]
[substitute(nam, dc, cList),e]
mkUnionFunList(op,form is ["Union",:listOfEntries],e) ==
first listOfEntries is [":",.,.] => mkNewUnionFunList(op,form,e)
-- following call to order is a bug, but needs massive recomp to fix
listOfEntries:= orderUnionEntries listOfEntries
+ nargs := #listOfEntries
--1. create representations of subtypes
predList:= mkPredList listOfEntries
g:=GENSYM()
--2. create coercions from subtypes to subUnion
cList:=
- [["_=",[["Boolean"],g ,g],["ELT",op,6]],
- ["coerce",[$OutputForm,g],["ELT",op,7]],:
- ("append"/
- [[["autoCoerce",[g,t],upFun],
- ["coerce",[t,g],cdownFun],
- ["autoCoerce",[t,g],downFun], --this should be removed eventually
- ["case",['(Boolean),g,t],typeFun]]
- for p in predList for t in listOfEntries])] where
- upFun() ==
- p is ["EQCAR",x,n] => ["XLAM",["#1"],["CONS",n,"#1"]]
- ["XLAM",["#1"],"#1"]
- cdownFun() ==
- gg:=GENSYM()
- if p is ["EQCAR",x,n] then
- ref:=["QCDR",gg]
- q:= ["QEQCAR", gg, n]
- else
- ref:=gg
- q:= substitute(gg,"#1",p)
- ["XLAM",["#1"],["PROG2",["LET",gg,"#1"],ref,
- ["check_-union",q,t,gg]]]
- downFun() ==
- p is ["EQCAR",x,.] =>
- ["XLAM",["#1"],["QCDR","#1"]]
- ["XLAM",["#1"],"#1"]
- typeFun() ==
- p is ["EQCAR",x,n] =>
- ["XLAM",["#1"],["QEQCAR",x,n]]
- ["XLAM",["#1"],p]
+ [["=",[$Boolean,g ,g],["ELT",op,$FirstParamSlot + nargs]],
+ ["~=",[$Boolean,g,g],["ELT",op,0]],
+ ["coerce",[$OutputForm,g],["ELT",op,$FirstParamSlot+nargs+1]],:
+ ("append"/
+ [[["autoCoerce",[g,t],upFun],
+ ["coerce",[t,g],cdownFun],
+ ["autoCoerce",[t,g],downFun], --this should be removed eventually
+ ["case",['(Boolean),g,t],typeFun]]
+ for p in predList for t in listOfEntries])] where
+ upFun() ==
+ p is ["EQCAR",x,n] => ["XLAM",["#1"],["CONS",n,"#1"]]
+ ["XLAM",["#1"],"#1"]
+ cdownFun() ==
+ gg:=GENSYM()
+ if p is ["EQCAR",x,n] then
+ ref:=["QCDR",gg]
+ q:= ["QEQCAR", gg, n]
+ else
+ ref:=gg
+ q:= substitute(gg,"#1",p)
+ ["XLAM",["#1"],["PROG2",["LET",gg,"#1"],ref,
+ ["check-union",q,t,gg]]]
+ downFun() ==
+ p is ["EQCAR",x,.] =>
+ ["XLAM",["#1"],["QCDR","#1"]]
+ ["XLAM",["#1"],"#1"]
+ typeFun() ==
+ p is ["EQCAR",x,n] =>
+ ["XLAM",["#1"],["QEQCAR",x,n]]
+ ["XLAM",["#1"],p]
cList:= substitute(dollarIfRepHack op,g,cList)
[cList,e]
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-09 04:23:49 +0000