Initial population.

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}