-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd. -- All rights reserved. -- Copyright (C) 2007-2012, Gabriel Dos Reis. -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are -- met: -- -- - Redistributions of source code must retain the above copyright -- notice, this list of conditions and the following disclaimer. -- -- - Redistributions in binary form must reproduce the above copyright -- notice, this list of conditions and the following disclaimer in -- the documentation and/or other materials provided with the -- distribution. -- -- - Neither the name of The Numerical Algorithms Group Ltd. nor the -- names of its contributors may be used to endorse or promote products -- derived from this software without specific prior written permission. -- -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS -- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A -- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER -- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- This file contains the constructors for the domains that cannot -- 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 import c_-util namespace BOOT $noCategoryDomains == '(Mode SubDomain) $nonLisplibDomains == append($DomainNames,$noCategoryDomains) ++ Category ancestors for Record, Union, Mapping, and Enumeration domains. $commonCategoryAncestors == ['(SetCategory), '(BasicType), '(CoercibleTo (OutputForm))] ++ Default category packages for Record, Union, Mapping and ++ Enumeration domains. $commonCategoryDefaults == ['(SetCategory& $), '(BasicType& $), nil] ++ The slot number in a domain shell that holds the first parameter to ++ a domain constructor. $FirstParamSlot == 6 --% Monitoring functions lookupDisplay(op,sig,vectorOrForm,suffix) == not $NRTmonitorIfTrue => nil prefix := (suffix is '"" => ">"; "<") sayBrightly concat(prefix,formatOpSignature(op,sig), '" from ", prefix2String devaluateDeeply vectorOrForm,suffix) isInstantiated [op,:argl] == u:= lassocShiftWithFunction(argl,tableValue($ConstructorCache,op), function domainEqualList) => CDRwithIncrement u nil --======================================================= -- Predicates --======================================================= lookupPred(pred,dollar,domain) == pred = true => true pred is [op,:pl] and op in '(AND and %and) => and/[lookupPred(p,dollar,domain) for p in pl] pred is [op,:pl] and op in '(OR or %or) => or/[lookupPred(p,dollar,domain) for p in pl] pred is [op,p] and op in '(NOT not %not) => not lookupPred(p,dollar,domain) pred is ['is,dom1,dom2] => domainEqual(dom1,dom2) pred is ["has",a,b] => vector? a => keyedSystemError("S2GE0016",['"lookupPred", '"vector as first argument to has"]) a := eval mkEvalable substDollarArgs(dollar,domain,a) b := substDollarArgs(dollar,domain,b) HasCategory(a,b) keyedSystemError("S2NR0002",[pred]) substDollarArgs(dollar,domain,object) == form := devaluate domain applySubst(pairList(["$",:$FormalMapVariableList],[devaluate dollar,:rest form]), object) compareSig(sig,tableSig,dollar,domain) == #sig ~= #tableSig => false null(target := first sig) or lazyCompareSigEqual(target,first tableSig,dollar,domain) => and/[lazyCompareSigEqual(s,t,dollar,domain) for s in rest sig for t in rest tableSig] lazyCompareSigEqual(s,tslot,dollar,domain) == tslot is '$ => s is "$" or s = devaluate dollar integer? tslot and cons?(lazyt := domainRef(domain,tslot)) and cons? s => lazyt is [.,.,.,[.,item,.]] and item is [.,[functorName,:.]] and functorName = s.op => compareSigEqual(s,canonicalForm evalDomain lazyt,dollar,domain) nil compareSigEqual(s,replaceLocalTypes(tslot,domain),dollar,domain) compareSigEqual(s,t,dollar,domain) == s = t => true t isnt [.,:.] => u := t is '$ => dollar isSharpVar t => vector? domain => instantiationArgs(domain).(symbolPosition(t,$FormalMapVariableList)) domain.args.(symbolPosition(t,$FormalMapVariableList)) string? t and ident? s => (s := symbolName s; t) nil s is '$ => compareSigEqual(dollar,u,dollar,domain) u => compareSigEqual(s,u,dollar,domain) s = u s is '$ => compareSigEqual(dollar,t,dollar,domain) s isnt [.,:.] => nil #s ~= #t => nil match := true for u in s for v in t repeat not compareSigEqual(u,v,dollar,domain) => return(match:=false) match --======================================================= -- Lookup From Interpreter --======================================================= compiledLookup(op,sig,dollar) == --called by coerceByFunction, evalForm, findEqualFun, findUniqueOpInDomain, -- getFunctionFromDomain, optDeltaEntry, retractByFunction if not vector? dollar then dollar := evalDomain dollar -- "^" is an alternate name for "**" in OpenAxiom libraries. -- ??? When, we get to support Aldor libraries and the equivalence -- ??? does not hold, we may want to do the reverse lookup too. -- ??? See compiledLookupCheck below. if op = "^" then op := "**" basicLookup(op,sig,dollar,dollar) lookupInDomainVector(op,sig,domain,dollar) == SPADCALL(op,sig,dollar,domainRef(domain,1)) lookupInDomain(op,sig,addFormDomain,dollar,index) == addFormCell := vectorRef(addFormDomain,index) => integer? KAR addFormCell => or/[lookupInDomain(op,sig,addFormDomain,dollar,i) for i in addFormCell] if not vector? addFormCell then addFormCell := eval addFormCell lookupInDomainVector(op,sig,addFormCell,dollar) nil ++ same as lookupInDomainVector except that the use of defaults ++ (either in category packages or add-chains) is controlled ++ by `useDefaults'. lookupInDomainAndDefaults(op,sig,domain,dollar,useDefaults) == $lookupDefaults: local := useDefaults lookupInDomainVector(op,sig,domain,dollar) basicLookup(op,sig,domain,dollar) == item := domainDirectory domain cons? item and first item in '(lookupInDomain lookupInTable) => lookupInDomainVector(op,sig,domain,dollar) ----------new world code follows------------ u := lookupInDomainAndDefaults(op,sig,domain,dollar,false) => u lookupInDomainAndDefaults(op,sig,domain,dollar,true) compiledLookupCheck(op,sig,dollar) == fn := compiledLookup(op,sig,dollar) -- NEW COMPILER COMPATIBILITY ON if (fn = nil) and (op = "**") then fn := compiledLookup("^",sig,dollar) -- NEW COMPILER COMPATIBILITY OFF fn = nil => keyedSystemError("S2NR0001",[op,formatSignature sig,canonicalForm dollar]) fn --======================================================= -- Lookup From Compiled Code --======================================================= goGet(:l) == [:arglist,env] := l arglist is ['goGet,:.] => stop() [[.,[op,initSig,:code]],thisDomain] := env domainSlot := code quo 8192 code1 := code rem 8192 isConstant := odd? code1 code2 := code1 quo 2 explicitLookupDomainIfTrue := odd? code2 index := code2 quo 2 kind := (isConstant => 'CONST; 'ELT) sig := [replaceLocalTypes(s,thisDomain) for s in initSig] sig := substDomainArgs(thisDomain,sig) lookupDomain := domainSlot = 0 => thisDomain domainRef(thisDomain,domainSlot) -- where we look for the operation if cons? lookupDomain then lookupDomain := evalDomain lookupDomain dollar := -- what matches $ in signatures explicitLookupDomainIfTrue => lookupDomain thisDomain if cons? dollar then dollar := evalDomain dollar fn := basicLookup(op,sig,lookupDomain,dollar) fn = nil => keyedSystemError("S2NR0001",[op,sig,canonicalForm lookupDomain]) val := apply(first fn,[:arglist,rest fn]) domainRef(thisDomain,index) := fn val replaceLocalTypes(t,dom) == t isnt [.,:.] => not integer? t => t t := domainRef(dom,t) if cons? t then t := evalDomain t canonicalForm t t.op is ":" or builtinConstructor? t.op => [t.op,:[replaceLocalTypes(x,dom) for x in t.args]] t substDomainArgs(domain,object) == form := devaluate domain applySubst(pairList(["$$",:$FormalMapVariableList],[form,:form.args]),object) --======================================================= -- Category Default Lookup (from goGet or lookupInAddChain) --======================================================= lookupInCategories(op,sig,dom,dollar) == catformList := domainRef(dom,4).0 varList := ["$",:$FormalMapVariableList] nsig := MSUBST(canonicalForm dom,canonicalForm dollar,sig) -- the following lines don't need to check for predicates because -- this code (the old runtime scheme) is used only for -- builtin constructors -- their predicates are always true. r := or/[lookupInDomainVector(op,nsig, eval applySubst(pairList(varList,valueList),catform),dollar) for catform in catformList | catform ~= nil ] where valueList() == [MKQ dom,:[MKQ domainRef(dom,5+i) for i in 1..(#rest catform)]] r or lookupDisplay(op,sig,'"category defaults",'"-- not found") --======================================================= -- Lookup Addlist (from lookupInDomainTable or lookupInDomain) --======================================================= defaultingFunction op == op isnt [.,:dom] => false not vector? dom => false not (#dom > 0) => false canonicalForm dom isnt [packageName,:.] => false not ident? packageName => false isDefaultPackageName packageName lookupInAddChain(op,sig,addFormDomain,dollar) == addFunction := lookupInDomain(op,sig,addFormDomain,dollar,5) defaultingFunction addFunction => lookupInCategories(op,sig,addFormDomain,dollar) or addFunction addFunction or lookupInCategories(op,sig,addFormDomain,dollar) --======================================================= -- Lookup Function in Slot 1 (via SPADCALL) --======================================================= lookupInTable(op,sig,dollar,[domain,table]) == table is "derived" => lookupInAddChain(op,sig,domain,dollar) success := nil -- lookup result someMatch := false while not success for [sig1,:code] in symbolTarget(op,table) repeat success := not compareSig(sig,sig1,canonicalForm dollar,domain) => false code is ['Subsumed,a] => subsumptionSig := applySubst(pairList($FormalMapVariableList,canonicalForm(domain).args),a) someMatch := true nil predIndex := code quo 8192 predIndex ~= 0 and not lookupPred($predVector.predIndex,dollar,domain) => nil loc := (code rem 8192) quo 2 loc = 0 => someMatch := true nil slot := domainRef(domain,loc) slot is ["goGet",:.] => lookupDisplay(op,sig,domain,'" !! goGet found, will ignore") lookupInAddChain(op,sig,domain,dollar) or 'failed slot = nil => lookupDisplay(op,sig,domain,'" !! null slot entry, continuing") lookupInAddChain(op,sig,domain,dollar) or 'failed lookupDisplay(op,sig,domain,'" !! found in NEW table!!") slot success isnt 'failed and success ~= nil => success subsumptionSig ~= nil and (u := SPADCALL(op,subsumptionSig,dollar,domainRef(domain,1))) => u someMatch => lookupInAddChain(op,sig,domain,dollar) nil knownEqualPred dom == fun := compiledLookup("=",[$Boolean,"$","$"],dom) => getFunctionReplacement BPINAME first fun nil hashable dom == -- FIXME: there should test for OIL opcodes. symbolMember?(knownEqualPred dom,'(EQ EQL EQUAL)) --% 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",:.] ++ 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) ++ Same as `oldSlotCode', except that it is used for constants. macro oldConstantSlodCode n == oldSlotCode n + 1 Record(:args) == srcArgs := [[":", second a, devaluate third a] for a in args] nargs := #args dom := newShell(nargs + 10) -- JHD added an extra slot to cache EQUAL methods canonicalForm(dom) := ["Record", :srcArgs] domainDirectory(dom) := ["lookupInTable",dom, [["=",[[$Boolean,"$","$"],:oldSlotCode nargs]], ["~=",[[$Boolean,"$","$"],:0]], ["hash",[[$SingleInteger,"$"],:0]], ["coerce",[[$OutputForm,"$"],:oldSlotCode(nargs + 1)]]]] domainRef(dom,3) := ["RecordCategory",:instantiationArgs dom] domainRef(dom,4) := [$commonCategoryDefaults, $commonCategoryAncestors] for i in $FirstParamSlot.. for a in args repeat domainRef(dom,i) := third a domainRef(dom,$FirstParamSlot + nargs) := [function RecordEqual, :dom] domainRef(dom,$FirstParamSlot + nargs + 1) := [function RecordPrint, :dom] domainRef(dom,$FirstParamSlot + nargs + 2) := [function Undef, :dom] -- following is cache for equality functions domainRef(dom,$FirstParamSlot + nargs + 3) := if nargs <= 2 then [nil,:nil] else newShell nargs dom RecordEqual(x,y,dom) == nargs := #instantiationArgs dom cons? x => b := SPADCALL(first x, first y, first(domainRef(dom,nargs + 9)) or first(domainRef(dom,nargs + 9).first := findEqualFun domainRef(dom,$FirstParamSlot))) nargs = 1 => b b and SPADCALL(rest x, rest y, rest (dom.(nargs + 9)) or rest (dom.(nargs + 9).rest := findEqualFun(dom.($FirstParamSlot+1)))) vector? x => equalfuns := domainRef(dom,nargs + 9) and/[SPADCALL(x.i,y.i,equalfuns.i or _ (equalfuns.i := findEqualFun domainRef(dom,$FirstParamSlot + i)))_ for i in 0..(nargs - 1)] error '"Bug: Silly record representation" RecordPrint(x,dom) == coerceRe2E(x,dom.3) coerceVal2E(x,m) == objValUnwrap coerceByFunction(objNewWrap(x,m),$OutputForm) findEqualFun(dom) == compiledLookup("=",[$Boolean,"$","$"],dom) coerceRe2E(x,source) == n := # rest source n = 1 => ["construct", ["=", source.1.1, coerceVal2E(first x,source.1.2)] ] n = 2 => ["construct", ["=", source.1.1, coerceVal2E(first x,source.1.2)], _ ["=", source.2.1, coerceVal2E(rest x,source.2.2)] ] vector? x => ['construct, :[["=",tag,coerceVal2E(x.i, fdom)] for i in 0.. for [.,tag,fdom] in rest source]] error '"Bug: ridiculous record representation" --% Union -- Want to eventually have the coerce to and from branch types. Union(:args) == srcArgs := [(a is [":",tag,d] => [":",tag,devaluate d]; devaluate a) for a in args] nargs := #args dom := newShell (nargs + 9) canonicalForm(dom) := ["Union", :srcArgs] domainDirectory(dom) := ["lookupInTable",dom, [["=",[[$Boolean,"$","$"],:oldSlotCode nargs]], ["~=",[[$Boolean,"$","$"],:0]], ["hash", [[$SingleInteger,"$"],:0]], ["coerce",[[$OutputForm,"$"],:oldSlotCode (nargs+1)]]]] domainRef(dom,3) := ["UnionCategory",:instantiationArgs dom] domainRef(dom,4) := [$commonCategoryDefaults, $commonCategoryAncestors] for i in $FirstParamSlot.. for a in args repeat domainRef(dom,i) := a domainRef(dom,$FirstParamSlot + nargs) := [function UnionEqual, :dom] domainRef(dom,$FirstParamSlot + nargs + 1) := [function UnionPrint, :dom] domainRef(dom,$FirstParamSlot + nargs + 2) := [function Undef, :dom] dom UnionEqual(x, y, dom) == ["Union",:branches] := canonicalForm dom predlist := mkPredList branches same := false for b in stripTags branches for p in predlist while not same repeat typeFun := eval ['%lambda,'(_#1),p] FUNCALL(typeFun,x) and FUNCALL(typeFun,y) => string? b => same := (x = y) if p is ['%ieq,['%head,.],:.] then (x := rest x; y := rest y) same := SPADCALL(x, y, findEqualFun(evalDomain b)) same UnionPrint(x, dom) == coerceUn2E(x, canonicalForm dom) coerceUn2E(x,source) == ["Union",:branches] := source predlist := mkPredList branches byGeorge := byJane := gensym() for b in stripTags branches for p in predlist repeat typeFun := eval ['%lambda,'(_#1),p] if FUNCALL(typeFun,x) then return if p is ['%ieq,['%head,.],:.] then x := rest x -- string? b => return x -- to catch "failed" etc. string? b => byGeorge := x -- to catch "failed" etc. byGeorge := coerceVal2E(x,b) byGeorge = byJane => error '"Union bug: Cannot find appropriate branch for coerce to E" byGeorge --% Mapping -- Want to eventually have elt: ($, args) -> target ++ Implementation of the `MappinCategory' as builtin. ++ A domain that satisfy this predicate provides implementation ++ to abstraction that map values from some type to values ++ of another type. MappingCategory(:sig) == sig = nil => error '"MappingCategory requires at least one argument" cat := eval ['Join,$Type, ['mkCategory,quote 'domain, quote [[['elt,[first sig,'$,:rest sig]],true]], [], [], nil]] canonicalForm(cat) := ['MappingCategory,:sig] cat Mapping(:args) == srcArgs := [devaluate a for a in args] nargs := #args dom := newShell(nargs + 9) canonicalForm(dom) := ["Mapping", :srcArgs] domainDirectory(dom) := ["lookupInTable",dom, [["=",[[$Boolean,"$","$"],:oldSlotCode nargs]], ["~=",[[$Boolean,"$","$"],:0]], ["hash", [[$SingleInteger,"$"],:0]], ["coerce",[[$OutputForm,"$"],:oldSlotCode(nargs + 1)]]]] domainRef(dom,3) := $SetCategory domainRef(dom,4) := [$commonCategoryDefaults, $commonCategoryAncestors] for i in $FirstParamSlot.. for a in args repeat domainRef(dom,i) := a domainRef(dom,$FirstParamSlot + nargs) := [function MappingEqual, :dom] domainRef(dom,$FirstParamSlot + nargs + 1) := [function MappingPrint, :dom] domainRef(dom,$FirstParamSlot + nargs + 2) := [function Undef, :dom] dom MappingEqual(x, y, dom) == sameObject?(x,y) MappingPrint(x, dom) == coerceMap2E(x) coerceMap2E(x) == -- nrlib domain array? rest x => ["theMap", BPINAME first x, if $testingSystem then 0 else HASHEQ(rest x) rem 1000] -- aldor ["theMap", BPINAME first x ] --% Enumeration EnumerationCategory(:"args") == cat := eval ['Join,$SetCategory, ['mkCategory,quote 'domain, quote [[[arg,['$],'constant],'T] for arg in args], [], [], nil]] canonicalForm(cat) := ['EnumerationCategory,:args] cat Enumeration(:"args") == nargs := #args dom := newShell(2 * nargs + 9) -- JHD added an extra slot to cache EQUAL methods canonicalForm(dom) := ["Enumeration",:args] domainDirectory(dom) := ["lookupInTable",dom, [["=",[[$Boolean,"$","$"],:oldSlotCode nargs]], ["~=",[[$Boolean,"$","$"],:0]], ["hash", [[$SingleInteger,"$"],:0]], ["coerce",[[$OutputForm,"$"],:oldSlotCode(nargs+1)], [["$", $Symbol], :oldSlotCode(nargs+2)]], :[[arg,[["$"],:oldConstantSlodCode(nargs+3+i)]] for arg in args for i in 0..] ]] domainRef(dom,3) := ["EnumerationCategory",:instantiationArgs dom] domainRef(dom,4) := [$commonCategoryDefaults, $commonCategoryAncestors] for i in $FirstParamSlot.. for a in args repeat domainRef(dom,i) := a domainRef(dom,$FirstParamSlot + nargs) := [function EnumEqual, :dom] domainRef(dom,$FirstParamSlot + nargs + 1) := [function EnumPrint, :dom] domainRef(dom,$FirstParamSlot + nargs + 2) := [function createEnum, :dom] -- Fille slots for constant returning functions. -- Note: this is wasteful in terms of space since the constants are -- already stored as arguments to this domain. for i in ($FirstParamSlot + nargs + 3).. for . in args for v in 0.. repeat domainRef(dom,i) := [function IDENTITY,:v] dom EnumEqual(e1,e2,dom) == scalarEq?(e1,e2) EnumPrint(enum, dom) == instantiationArgs(dom).enum createEnum(sym, dom) == args := instantiationArgs dom val := -1 for v in args for i in 0.. repeat symbolEq?(sym,v) => return(val:=i) val < 0 => userError ['"Cannot coerce",sym,'"to",["Enumeration",:args]] val --% INSTANTIATORS RecordCategory(:"x") == constructorCategory ["Record",:x] UnionCategory(:"x") == constructorCategory ["Union",:x] constructorCategory (title is [op,:.]) == constructorFunction:= property(op,"makeFunctionList") or systemErrorHere ['"constructorCategory",title] [funlist,.]:= FUNCALL(constructorFunction,"$",title,$CategoryFrame) oplist:= [[[a,b],true,c] for [a,b,c] in funlist] cat:= JoinInner([eval $SetCategory,mkCategory("domain",oplist,nil,nil,nil)], $EmptyEnvironment) canonicalForm(cat) := title cat mkMappingFunList(nam,mapForm,e) == nargs := #rest mapForm dc := gensym() sigFunAlist:= [["=",[$Boolean,nam ,nam], ["ELT",dc,$FirstParamSlot + nargs]], ["~=",[$Boolean,nam,nam],["ELT",dc,0]], ["hash",[$SingleInteger,nam],["ELT",dc,0]], ["coerce",[$OutputForm,nam], ["ELT",dc,$FirstParamSlot + nargs + 1]]] [substitute(nam,dc,substituteDollarIfRepHack sigFunAlist),e] ++ Build an inline function for constructing records of length `n'. mkRecordFun n == args := formalVarList n op := n < 2 => '%list n = 2 => '%pair '%vector ["XLAM",args,[op,:args]] ++ Build expression for selecting the i-th field of a fomal record ++ variable of length `n'. formalRecordField(n,i) == n < 2 => ['%head,"#1"] n = 2 => i = 0 => ['%head,"#1"] ['%tail,"#1"] ['%vref,"#1",i] ++ Build an inline function for selecting field `i' or a ++ record of length `n'. eltRecordFun(n,i) == ["XLAM",["#1","#2"],formalRecordField(n,i)] seteltRecordFun(n,i) == args := formalVarList 3 field := formalRecordField(n,i) body := n > 2 => ['%store,field,"#3"] ['%seq,['%store,field,"#3"],field] ["XLAM",args,body] copyRecordFun n == body := n < 2 => ['%list,['%head,"#1"]] n = 2 => ['%pair,['%head,"#1"],['%tail,"#1"]] ['%vcopy,"#1"] ["XLAM",["#1"],body] mkRecordFunList(nam,["Record",:Alist],e) == len:= #Alist dc := gensym() sigFunAlist:= [["construct",[nam,:[A for [.,a,A] in Alist]],mkRecordFun len], ["=",[$Boolean,nam ,nam],["ELT",dc,$FirstParamSlot + len]], ["~=",[$Boolean,nam,nam],["ELT",dc,0]], ["hash",[$SingleInteger,nam],["ELT",dc,0]], ["coerce",[$OutputForm,nam],["ELT",dc,$FirstParamSlot+len+1]],: [["elt",[A,nam,PNAME a],eltRecordFun(len,i)] for i in 0.. for [.,a,A] in Alist],: [["setelt",[A,nam,PNAME a,A],seteltRecordFun(len,i)] for i in 0.. for [.,a,A] in Alist], ["copy",[nam,nam],copyRecordFun 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,$FirstParamSlot+nargs]], ["~=",[$Boolean,name,name],["ELT",dc,0]], ["hash",[$SingleInteger,name],["ELT",dc,0]], ["coerce",[$OutputForm,name],["ELT",dc,$FirstParamSlot+nargs+1]],: ("append"/ [[["construct",[name,type],["XLAM",["#1"],["%pair",i,"#1"]]], ["elt",[type,name,tag],cdownFun], ["case",[$Boolean,name,tag], ["XLAM",["#1","#2"],['%ieq,['%head,"#1"],i]]]] for [.,tag,type] in listOfEntries for i in 0..])] where cdownFun() == ['XLAM,["#1","#2"],['%pullback,"#1",type,i]] [cList,e] mkEnumerationFunList(dc,["Enumeration",:SL],e) == len := #SL cList := [nil, ["=",[$Boolean,dc,dc],["XLAM",["#1","#2"],['%ieq,"#1","#2"]]], ["~=",[$Boolean,dc,dc],["XLAM",["#1","#2"],['%not,['%ieq,"#1","#2"]]]], ["coerce",[dc,$Symbol],["ELT",dc,$FirstParamSlot+len+1]], ["coerce",[$OutputForm,dc],["ELT",dc,$FirstParamSlot+len+2]], :[[arg,[dc],["XLAM",[],v]] for arg in SL for v in 0..] ] [cList,e] mkUnionFunList(op,form is ["Union",:listOfEntries],e) == first listOfEntries is [":",.,.] => mkNewUnionFunList(op,form,e) nargs := #listOfEntries -- create coercions from subtypes to subUnion g := gensym() cList:= [["=",[$Boolean,g ,g],["ELT",op,$FirstParamSlot + nargs]], ["~=",[$Boolean,g,g],["ELT",op,0]], ["hash",[$SingleInteger,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 t in listOfEntries for n in 0..])] where upFun() == ["XLAM",["#1"],["%pair",n,"#1"]] cdownFun() == ['XLAM,["#1"],['%pullback,"#1",t,n]] downFun() == ["XLAM",["#1"],["%tail","#1"]] typeFun() == ["XLAM",["#1","#2"],['%ieq,['%head,"#1"],n]] cList:= substitute(dollarIfRepHack op,g,cList) [cList,e] --% parentsOfBuiltinInstance form == [op,:args] := form -- builtin categories op in '(RecordCategory UnionCategory) => [[$SetCategory,:['AND,:[['has,t,$SetCategory] for t in stripTags args]]]] op is 'MappingCategory => nil -- [[$Type,:true]] op is 'EnumerationCategory => [[$SetCategory,:true]] -- builtin domains op is 'Mapping => [[['MappingCategory,:args],:true],[$SetCategory,:true]] op is 'Record => [[['RecordCategory,:args],:true]] op is 'Union => [[['UnionCategory,:args],:true]] op is 'Enumeration => [[['EnumerationCategory,:args],:true]] nil $CapitalLetters == '(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z) builtinInstanceForm form == [op,:args] := form op in '(Mapping MappingCategory Enumeration EnumerationCategory) => [op,:take(#args,$CapitalLetters)] op in '(Record RecordCategory Union UnionCategory) => [op,:[T for a in args for t in $CapitalLetters]] where T() == a is [":",x,.] => [":",x,t] t nil --% for x in '((Record mkRecordFunList) (Union mkUnionFunList) (Mapping mkMappingFunList) (Enumeration mkEnumerationFunList)) repeat property(first x, 'makeFunctionList) := second x