diff options
Diffstat (limited to 'src/interp/buildom.boot.pamphlet')
| -rw-r--r-- | src/interp/buildom.boot.pamphlet | 384 |
1 files changed, 384 insertions, 0 deletions
diff --git a/src/interp/buildom.boot.pamphlet b/src/interp/buildom.boot.pamphlet new file mode 100644 index 00000000..15196a74 --- /dev/null +++ b/src/interp/buildom.boot.pamphlet @@ -0,0 +1,384 @@ +\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 + +SETANDFILEQ($noCategoryDomains, '(Domain Mode SubDomain)) +SETANDFILEQ($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} |