1-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
2-- All rights reserved.
3--
4-- Redistribution and use in source and binary forms, with or without
5-- modification, are permitted provided that the following conditions are
6-- met:
7--
8--     - Redistributions of source code must retain the above copyright
9--       notice, this list of conditions and the following disclaimer.
10--
11--     - Redistributions in binary form must reproduce the above copyright
12--       notice, this list of conditions and the following disclaimer in
13--       the documentation and/or other materials provided with the
14--       distribution.
15--
16--     - Neither the name of The Numerical ALgorithms Group Ltd. nor the
17--       names of its contributors may be used to endorse or promote products
18--       derived from this software without specific prior written permission.
19--
20-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
21-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
22-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
23-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
24-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
25-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
26-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
27-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
28-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
29-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
30-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31
32)package "BOOT"
33
34-- This file contains the constructors for the domains that cannot
35-- be written in ScratchpadII yet.  They are not cached because they
36-- are very cheap to instantiate.
37-- SMW and SCM July 86
38
39DEFPARAMETER($noCategoryDomains, '(Mode))
40DEFPARAMETER($nonLisplibDomains,
41  APPEND($Primitives,$noCategoryDomains))
42
43--% Record
44--  Want to eventually have the elts and setelts.
45--  Record is a macro in BUILDOM LISP. It takes out the colons.
46
47isRecord type == type is ['Record,:.]
48
49Record0 args ==
50    dom := GETREFV 11
51    -- JHD added an extra slot to cache EQUAL methods
52    dom.0 := ['Record, :[['_:, first a, devaluate rest a] for a in args]]
53    dom.1 :=
54           [function lookupInTable,dom,
55               [['_=,[[['Boolean],'_$,'_$],:6]],
56                ['_~_=,[[['Boolean],'_$,'_$],:10]],
57                 ['coerce, [[$OutputForm, '_$], :7]]]]
58    dom.2 := NIL
59    dom.3 := ['RecordCategory,:QCDR dom.0]
60    dom.4 :=
61          [[ '(SetCategory) ], [ '(BasicType),
62             '(CoercibleTo (OutputForm)), '(SetCategory) ]]
63    dom.5 := [rest a for a in args]
64    dom.6 := [function RecordEqual, :dom]
65    dom.7 := [function RecordPrint, :dom]
66    dom.8 := [function Undef, :dom]
67  -- following is cache for equality functions
68    dom.9 := if (n:= LENGTH args) <= 2
69              then [NIL,:NIL]
70              else GETREFV n
71    dom.10 := [function RecordUnEqual, :dom]
72    dom
73
74RecordEqual(x,y,dom) ==
75  PAIRP x =>
76    b:=
77       SPADCALL(first x, first y, first(dom.9) or
78                           first RPLACA(dom.9, findEqualFun(dom.5.0)))
79    NULL rest(dom.5) => b
80    b and
81       SPADCALL(rest x, rest y, rest(dom.9) or
82                           rest RPLACD(dom.9, findEqualFun(dom.5.1)))
83  VECP x =>
84    equalfuns := dom.9
85    and/[SPADCALL(x.i,y.i,equalfuns.i or (equalfuns.i:=findEqualFun(fdom)))
86         for i in 0.. for fdom in dom.5]
87  error '"Bug: Silly record representation"
88
89RecordUnEqual(x,y,dom) == not(RecordEqual(x,y,dom))
90
91RecordPrint(x,dom) == coerceRe2E(x,dom.3)
92
93coerceVal2E(x,m) ==
94   -- first catch "failed" etc.
95   STRINGP m and (x = m) => STRCONC('"_"", x, '"_"")
96   objValUnwrap coerceByFunction(objNewWrap(x, m), $OutputForm)
97
98findEqualFun(dom) ==
99  compiledLookup('_=,[$Boolean,'$,'$],dom)
100
101coerceRe2E(x,source) ==
102  n := #rest(source)
103  n = 1 =>
104    ['construct,
105     ['_=, source.1.1, coerceVal2E(first x, source.1.2)] ]
106  n = 2 =>
107    ['construct,
108     ['_=, source.1.1, coerceVal2E(first x, source.1.2)], _
109     ['_=, source.2.1, coerceVal2E(rest x, source.2.2)] ]
110  VECP x =>
111    ['construct,
112     :[['_=,tag,coerceVal2E(x.i, fdom)]
113       for i in 0.. for [.,tag,fdom] in rest source]]
114  error '"Bug: ridiculous record representation"
115
116
117--% Union
118--  Want to eventually have the coerce to and from branch types.
119
120Union(:args) ==
121    dom := GETREFV 10
122    dom.0 := ['Union, :[(if a is ['_:,tag,domval] then ['_:,tag,devaluate domval]
123                          else devaluate a) for a in args]]
124    dom.1 :=
125            [function lookupInTable,dom,
126               [['_=,[[['Boolean],'_$,'_$],:6]],
127                ['_~_=, [[['Boolean],'_$,'_$],:9]],
128                 ['coerce,[[$OutputForm, '_$],:7]]]]
129    dom.2 := NIL
130    dom.3 :=
131      '(SetCategory)
132    dom.4 :=
133          [[ '(SetCategory) ],[ '(BasicType),
134             '(CoercibleTo (OutputForm)),  '(SetCategory) ]]
135    dom.5 := args
136    dom.6 := [function UnionEqual, :dom]
137    dom.7 := [function UnionPrint, :dom]
138    dom.8 := [function Undef, :dom]
139    dom.9 := [function UnionUnEqual, :dom]
140    dom
141
142UnionEqual(x, y, dom) ==
143  ['Union,:branches] := dom.0
144  predlist := mkPredList branches
145  same := false
146  res := false
147  for b in stripUnionTags branches for p in predlist while not same repeat
148    p is ["EQCAR", "#1", n] =>
149        EQCAR(x, n) and EQCAR(y, n) =>
150            same := true
151            STRINGP b => res := (x = y)
152            x := rest x
153            y := rest y
154            res := SPADCALL(x, y, findEqualFun(evalDomain b))
155    typeFun := COERCE(['LAMBDA, '(_#1), p], 'FUNCTION)
156    FUNCALL(typeFun,x) and FUNCALL(typeFun,y) =>
157        same := true
158        STRINGP b => res := (x = y)
159        res := SPADCALL(x, y, findEqualFun(evalDomain b))
160  res
161
162UnionUnEqual(x, y, dom) == not(UnionEqual(x, y, dom))
163
164UnionPrint(x, dom) == coerceUn2E(x, dom.0)
165
166coerceUn2E(x,source) ==
167  ['Union,:branches] := source
168  predlist := mkPredList branches
169  found := false
170  for b in stripUnionTags branches for p in predlist while not(found) repeat
171      found :=
172          p is ["EQCAR", "#1", n] => EQCAR(x, n)
173          typeFun := COERCE(['LAMBDA, '(_#1), p], 'FUNCTION)
174          FUNCALL(typeFun,x)
175      if found then
176          if p is ['EQCAR, :.] then x := rest x
177          res := coerceVal2E(x,b)
178  not(found) =>
179    error '"Union bug: Cannot find appropriate branch for coerce to E"
180  res
181
182mkPredList listOfEntries ==
183     [['EQCAR,"#1",i] for arg in listOfEntries for i in 0..]
184
185--% Mapping
186--  Want to eventually have elt: ($, args) -> target
187
188Mapping(:args) ==
189    dom := GETREFV 10
190    dom.0 := ['Mapping, :[devaluate a for a in args]]
191    dom.1 :=
192            [function lookupInTable,dom,
193               [['_=,[[['Boolean],'_$,'_$],:6]],
194                 ['coerce,[[$OutputForm, '_$],:7]]]]
195    dom.2 := NIL
196    dom.3 :=
197      '(SetCategory)
198    dom.4 :=
199          [[ '(SetCategory) ],[ '(BasicType),
200             '(CoercibleTo (OutputForm)), '(SetCategory) ]]
201    dom.5 := args
202    dom.6 := [function MappingEqual, :dom]
203    dom.7 := [function MappingPrint, :dom]
204    dom.8 := [function Undef, :dom]
205    dom.9 := [function MappingUnEqual, :dom]
206    dom
207
208MappingEqual(x, y, dom) == EQ(x,y)
209
210MappingUnEqual(x, y, dom) == not(EQ(x,y))
211
212MappingPrint(x, dom) == coerceMap2E(x)
213
214coerceMap2E(x) ==
215  -- nrlib domain
216  ARRAYP rest x => ['theMap, BPINAME first x,
217    if $testingSystem then 0 else REMAINDER(HASHEQ rest x, 1000)]
218  -- aldor
219  ['theMap, BPINAME first x]
220
221--% Enumeration
222-- Enumeration is a Lisp macro since it wants unevaluated arguments
223-- Enumeration0 below is a function, so it needs explicit quotes for
224-- arguments
225
226Enumeration0(:args) ==
227    dom := GETREFV 10
228    -- JHD added an extra slot to cache EQUAL methods
229    dom.0 := ['Enumeration, :args]
230    dom.1 :=
231           [function lookupInTable,dom,
232               [['_=,[[['Boolean],'_$,'_$],:6]],
233                 ['coerce,[[$OutputForm, '_$],:7], [['_$, $Symbol], :8]]
234                         ]]
235    dom.2 := NIL
236    dom.3 := ['EnumerationCategory,:QCDR dom.0]
237    dom.4 :=
238          [[ '(SetCategory) ], [ '(BasicType),
239             '(CoercibleTo (OutputForm)), '(SetCategory) ]]
240    dom.5 := args
241    dom.6 := [function EnumEqual, :dom]
242    dom.7 := [function EnumPrint, :dom]
243    dom.8 := [function createEnum, :dom]
244    dom.9 := [function EnumUnEqual, :dom]
245    dom
246
247EnumEqual(e1,e2,dom) == e1=e2
248EnumUnEqual(e1,e2,dom) == not(EnumEqual(e1,e2,dom))
249EnumPrint(enum, dom) == dom.5.enum
250createEnum(sym, dom) ==
251  args := dom.5
252  val := -1
253  for v in args for i in 0.. repeat
254     sym=v => return(val:=i)
255  val<0 => error ["Cannot coerce",sym,"to",["Enumeration",:args]]
256  val
257
258--% INSTANTIATORS
259
260get_oplist_maker(op) ==
261    op = "Record" => "mkRecordFunList"
262    op = "Union" => "mkUnionFunList"
263    op = "Mapping" => "mkMappingFunList"
264    op = "Enumeration" => "mkEnumerationFunList"
265    false
266
267RecordCategory(:x) == constructorCategory ['Record,:x]
268
269EnumerationCategory(:x) == constructorCategory ["Enumeration",:x]
270
271UnionCategory(:x) == constructorCategory ["Union",:x]
272
273
274constructorCategory (title is [op,:.]) ==
275  constructorFunction := get_oplist_maker(op) or
276              systemErrorHere '"constructorCategory"
277  [funlist,.]:= FUNCALL(constructorFunction,"$",title,$CategoryFrame)
278  oplist:= [[[a,b],true,c] for [a,b,c] in funlist]
279  cat:=
280      JoinInner([SetCategory(), mkCategory(oplist, nil, nil, nil)])
281  cat.(0):= title
282  cat
283
284--mkMappingFunList(nam,mapForm,e) == [[],e]
285mkMappingFunList(nam,mapForm,e) ==
286  dc := GENSYM()
287  sigFunAlist:=
288    [['_=,[['Boolean],nam ,nam],['ELT,dc,6]],
289     ['_~_=, [['Boolean], nam, nam], ['ELT, dc, 9]],
290       ['coerce, [$OutputForm, nam], ['ELT, dc, 7]]]
291  [substitute(nam,dc,substitute("$",'Rep,sigFunAlist)),e]
292
293mkRecordFunList(nam,['Record,:Alist],e) ==
294  len:= #Alist
295
296--  for (.,a,.) in Alist do
297--    if getmode(a,e) then MOAN("Symbol: ",a,
298--        " must not be both a variable and literal")
299--    e:= put(a,"isLiteral","true",e)
300  dc := GENSYM()
301  sigFunAlist:=
302     --:((a,(A,nam),('XLAM,("$1","$2"),('RECORDELT,"$1",i,len)))
303     --       for i in 0..,(.,a,A) in Alist),
304
305    [['construct,[nam,:[A for [.,a,A] in Alist]],'mkRecord],
306     ['_=, [['Boolean], nam, nam], ['ELT, dc, 6]],
307      ['_~_=, [['Boolean], nam, nam], ['ELT, dc, 10]],
308       ['coerce, [$OutputForm, nam], ['ELT, dc, 7]],:
309        [['elt,[A,nam,PNAME a],['XLAM,["$1","$2"],['RECORDELT,"$1",i,len]]]
310            for i in 0.. for [.,a,A] in Alist],:
311          [["setelt!", [A, nam, PNAME a, A], ['XLAM, ["$1", "$2", "$3"],
312            ['SETRECORDELT,"$1",i, len,"$3"]]]
313              for i in 0.. for [.,a,A] in Alist],:
314                [['copy,[nam,nam],['XLAM,["$1"],['RECORDCOPY,
315                  "$1",len]]]]]
316  [substitute(nam,dc,substitute("$",'Rep,sigFunAlist)),e]
317
318mkNewUnionFunList(name,form is ['Union,:listOfEntries],e) ==
319  dc := name
320  if name = 'Rep then name := '$
321  --2. create coercions from subtypes to subUnion
322  cList:=
323    [['_=,[['Boolean],name ,name],['ELT,dc,6]],
324     ['_~_=, [['Boolean], name, name], ['ELT, dc, 9]],
325     ['coerce, [$OutputForm, name], ['ELT, dc, 7]],:
326       ("append"/
327        [[['construct,[name,type],['XLAM,["#1"],['CONS,i,"#1"]]],
328          ['elt,[type,name,tag],cdownFun],
329            ["case", ['(Boolean), name, tag],
330               ['XLAM,["#1"],['QEQCAR,"#1",i]]]]
331                 for [.,tag,type] in listOfEntries for i in 0..])] where
332                   cdownFun() ==
333                    gg:=GENSYM()
334                    $InteractiveMode =>
335                      ['XLAM,["#1"],['PROG1,['QCDR,"#1"],
336                        ['check_union2, ['QEQCAR, "#1", i], type, form, "#1"]]]
337                    ['XLAM,["#1"],['PROG2,['LET,gg,"#1"],['QCDR,gg],
338                      ['check_union2, ['QEQCAR, gg, i], type, form, gg]]]
339  [cList,e]
340
341mkEnumerationFunList(nam,['Enumeration,:SL],e) ==
342  len:= #SL
343  dc := nam
344  cList :=
345    [nil,
346      ['_=,[['Boolean],nam ,nam],['ELT,dc,6]],
347       ['_~_=, [['Boolean], nam, nam], ['ELT, dc, 9]],
348        ['_^_=,[['Boolean],nam ,nam],['ELT,dc,7]],
349          ['coerce,[nam, ['Symbol]], ['ELT, dc, 8]],
350            ['coerce,[['OutputForm],nam],['ELT,dc, 9]]]
351  [substitute(nam, dc, cList),e]
352
353mkUnionFunList(op,form is ['Union,:listOfEntries],e) ==
354  first listOfEntries is [":",.,.] => mkNewUnionFunList(op,form,e)
355  --1. create representations of subtypes
356  predList:= mkPredList listOfEntries
357  g:=GENSYM()
358  --2. create coercions from subtypes to subUnion
359  cList:=
360   [['_=,[['Boolean],g ,g],['ELT,op,6]],
361    ['_~_=, [['Boolean], g, g], ['ELT,op,9]],
362    ['coerce, [$OutputForm, g], ['ELT, op, 7]],:
363     ("append"/
364      [[['autoCoerce,[g,t],upFun],
365        ['coerce,[t,g],cdownFun],
366        ['autoCoerce,[t,g],downFun], --this should be removed eventually
367        ["case", ['(Boolean), g, t], typeFun]]
368          for p in predList for t in listOfEntries])] where
369             upFun() ==
370               p is ['EQCAR,x,n] => ['XLAM,["#1"],['CONS,n,"#1"]]
371               ['XLAM,["#1"],"#1"]
372             cdownFun() ==
373               gg:=GENSYM()
374               if p is ['EQCAR,x,n] then
375                  ref:=['QCDR,gg]
376                  q:= ['QEQCAR, gg, n]
377               else
378                  ref:=gg
379                  q:= substitute(gg,"#1",p)
380               ['XLAM,["#1"],['PROG2,['LET,gg,"#1"],ref,
381                    ['check_union2, q, t, form, gg]]]
382             downFun() ==
383                p is ['EQCAR,x,.] =>
384                  ['XLAM,["#1"],['QCDR,"#1"]]
385                ['XLAM,["#1"],"#1"]
386             typeFun() ==
387                p is ['EQCAR,x,n] =>
388                  ['XLAM,["#1"],['QEQCAR,x,n]]
389                ['XLAM,["#1"],p]
390  op:=
391    op='Rep => '$
392    op
393  cList:= substitute(op,g,cList)
394  [cList,e]
395