diff options
Diffstat (limited to 'src/interp/buildom.boot.pamphlet')
| -rw-r--r-- | src/interp/buildom.boot.pamphlet | 386 |
1 files changed, 386 insertions, 0 deletions
diff --git a/src/interp/buildom.boot.pamphlet b/src/interp/buildom.boot.pamphlet new file mode 100644 index 00000000..cbbc7a43 --- /dev/null +++ b/src/interp/buildom.boot.pamphlet @@ -0,0 +1,386 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp buildom.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<<license>>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- 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. + +@ +<<*>>= +<<license>> + +-- 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 + +import '"sys-macros" +)package "BOOT" + +$noCategoryDomains == '(Domain Mode SubDomain) +$nonLisplibDomains == APPEND($Primitives,$noCategoryDomains) + +--% 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",:.] + +RecordInner args == + -- this is old and should be removed wherever it occurs + if $evalDomain then + sayBrightly '"-->> Whoops! RecordInner called from this code." + Record0 VEC2LIST args + +Record0 args == + dom := GETREFV 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",[[$Expression,"_$"],:14]]]] + dom.2 := NIL + dom.3 := ["RecordCategory",:QCDR dom.0] + dom.4 := + [[ '(SetCategory) ],[ '(SetCategory) ]] + 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 GETREFV n + dom + +RecordEqual(x,y,dom) == + 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 + b and + SPADCALL(CDR x, CDR y, CDR (dom.9) or + CDR RPLACD(dom.9,findEqualFun(dom.5.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] + error '"Bug: Silly record representation" + +RecordPrint(x,dom) == coerceRe2E(x,dom.3) + +coerceVal2E(x,m) == + objValUnwrap coerceByFunction(objNewWrap(x,m),$Expression) + +findEqualFun(dom) == + compiledLookup("_=",[$Boolean,"$","$"],dom) + +coerceRe2E(x,source) == + n := # CDR source + n = 1 => + ["construct", + ["_=", source.1.1, coerceVal2E(CAR 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)] ] + VECP 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) == + dom := GETREFV 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",[[$Expression,"_$"],:14]]]] + dom.2 := NIL + dom.3 := + '(SetCategory) + dom.4 := + [[ '(SetCategory) ],[ '(SetCategory) ]] + dom.5 := args + dom.6 := [function UnionEqual, :dom] + dom.7 := [function UnionPrint, :dom] + dom.8 := [function Undef, :dom] + dom + +UnionEqual(x, y, dom) == + ["Union",:branches] := dom.0 + branches := orderUnionEntries branches + predlist := mkPredList branches + same := false + for b in stripUnionTags branches for p in predlist while not same repeat + typeFun := ["LAMBDA", '(_#1), p] + FUNCALL(typeFun,x) and FUNCALL(typeFun,y) => + STRINGP b => same := (x = y) + if p is ["EQCAR", :.] then (x := rest x; y := rest y) + same := SPADCALL(x, y, findEqualFun(evalDomain b)) + same + +UnionPrint(x, dom) == coerceUn2E(x, dom.0) + +coerceUn2E(x,source) == + ["Union",:branches] := source + branches := orderUnionEntries branches + predlist := mkPredList branches + byGeorge := byJane := GENSYM() + for b in stripUnionTags branches for p in predlist repeat + typeFun := ["LAMBDA", '(_#1), p] + if FUNCALL(typeFun,x) then return + if p is ["EQCAR", :.] then x := rest x +-- STRINGP b => return x -- to catch "failed" etc. + STRINGP 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 + +Mapping(:args) == + dom := GETREFV 9 + dom.0 := ["Mapping", :[devaluate a for a in args]] + dom.1 := + [function lookupInTable,dom, + [["_=",[[["Boolean"],"_$","_$"],:12]], + ["coerce",[[$Expression,"_$"],:14]]]] + dom.2 := NIL + dom.3 := + '(SetCategory) + dom.4 := + [[ '(SetCategory) ],[ '(SetCategory) ]] + dom.5 := args + dom.6 := [function MappingEqual, :dom] + dom.7 := [function MappingPrint, :dom] + dom.8 := [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)] + -- aldor + ["theMap", BPINAME CAR x ] + +--% Enumeration + +Enumeration(:"args") == + dom := GETREFV 9 + -- JHD added an extra slot to cache EQUAL methods + dom.0 := ["Enumeration", :args] + dom.1 := + [function lookupInTable,dom, + [["_=",[[["Boolean"],"_$","_$"],:12]], + ["coerce",[[$Expression,"_$"],:14], [["_$", $Symbol], :16]] + ]] + dom.2 := NIL + dom.3 := ["EnumerationCategory",:QCDR dom.0] + dom.4 := + [[ '(SetCategory) ],[ '(SetCategory) ]] + 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 +createEnum(sym, dom) == + args := dom.5 + val := -1 + for v in args for i in 0.. repeat + sym=v => return(val:=i) + val<0 => error ["Cannot coerce",sym,"to",["Enumeration",:args]] + val + +--% INSTANTIATORS + +RecordCategory(:"x") == constructorCategory ["Record",:x] + +EnumerationCategory(:"x") == constructorCategory ["Enumeration",:x] + +UnionCategory(:"x") == constructorCategory ["Union",:x] + +--ListCategory(:"x") == constructorCategory ("List",:x) + +--VectorCategory(:"x") == constructorCategory ("Vector",:x) + --above two now defined in SPAD code. + +constructorCategory (title is [op,:.]) == + constructorFunction:= GETL(op,"makeFunctionList") or + systemErrorHere '"constructorCategory" + [funlist,.]:= FUNCALL(constructorFunction,"$",title,$CategoryFrame) + oplist:= [[[a,b],true,c] for [a,b,c] in funlist] + cat:= + JoinInner([SetCategory(),mkCategory("domain",oplist,nil,nil,nil)], + $EmptyEnvironment) + cat.(0):= title + cat + +--mkMappingFunList(nam,mapForm,e) == [[],e] +mkMappingFunList(nam,mapForm,e) == + dc := GENSYM() + sigFunAlist:= + [["_=",[["Boolean"],nam ,nam],["ELT",dc,6]], + ["coerce",[$Expression,nam],["ELT",dc,7]]] + [substitute(nam,dc,substitute("$",'Rep,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",[$Expression,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]]]]] + [substitute(nam,dc,substitute("$","Rep",sigFunAlist)),e] + +mkNewUnionFunList(name,form is ["Union",:listOfEntries],e) == + dc := name + if name = "Rep" then name := "$" + --2. create coercions from subtypes to subUnion + cList:= + [["_=",[["Boolean"],name ,name],["ELT",dc,6]], + ["coerce",[$Expression,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]]] + [cList,e] + +mkEnumerationFunList(nam,["Enumeration",:SL],e) == + len:= #SL + 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]]] + [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 + --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",[$Expression,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] + op:= + op="Rep" => "$" + op + cList:= substitute(op,g,cList) + [cList,e] + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} |