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--global hash tables for new compiler
35$docHash  := MAKE_HASHTABLE('EQUAL)
36$conHash  := MAKE_HASHTABLE('EQUAL)
37$opHash   := MAKE_HASHTABLE('EQUAL)
38$asyPrint := false
39
40asList() ==
41  maybe_delete_file('"temp.text")
42  OBEY '"ls as/*.asy > temp.text"
43  instream := OPEN '"temp.text"
44  lines := [read_line instream while not EOFP instream]
45  CLOSE instream
46  lines
47
48astran asyFile ==
49--global hash tables for new compiler
50  $docHash  := MAKE_HASHTABLE('EQUAL)
51  $conHash := MAKE_HASHTABLE('EQUAL)
52  $constantHash := MAKE_HASHTABLE('EQUAL)
53  $niladics : local := nil
54  $asyFile: local := asyFile
55  $asFilename: local := STRCONC(PATHNAME_-NAME asyFile,'".as")
56  asytran asyFile
57  conlist := [x for x in HKEYS $conHash | HGET($conHash,x) isnt [.,.,"function",:.]]
58  $mmAlist : local :=
59    [[con,:asyConstructorModemap con] for con in conlist]
60  $docAlist : local :=
61    [[con,:REMDUP asyDocumentation con] for con in conlist]
62  $parentsHash : local := MAKE_HASHTABLE('EQUAL)
63--$childrenHash: local := MAKE_HASHTABLE('EQUAL)
64  for con in conlist repeat
65    parents := asyParents con
66    HPUT($parentsHash,con,asyParents con)
67--  for [parent,:pred] in parents repeat
68--    parentOp := opOf parent
69--    HPUT($childrenHash,parentOp,insert([con,:pred],HGET($childrenHash,parentOp)))
70  $newConlist := union(conlist, $newConlist)
71  [[x,:asMakeAlist x] for x in HKEYS $conHash]
72
73asyParents(conform) ==
74  acc := nil
75  con:= opOf conform
76--formals := TAKE(#formalParams,$TriangleVariableList)
77  modemap := LASSOC(con,$mmAlist)
78  $constructorCategory :local := asySubstMapping CADAR modemap
79  for x in folks $constructorCategory repeat
80--  x := SUBLISLIS(formalParams,formals,x)
81--  x := SUBLISLIS(IFCDR conform,formalParams,x)
82    acc := [:explodeIfs x,:acc]
83  NREVERSE acc
84
85asySubstMapping u ==
86  u is [op,:r] =>
87    op = "->" =>
88       [s, t] := r
89       args :=
90          s is [op,:u] and asyComma? op => [asySubstMapping y for y in u]
91          [asySubstMapping s]
92       ['Mapping, asySubstMapping t, :args]
93    [asySubstMapping x for x in u]
94  u
95
96asyMkSignature(con,sig) ==
97--  atom sig => ['TYPE,con,sig]
98-- following line converts constants into nullary functions
99  atom sig => ['SIGNATURE,con,[sig]]
100  ['SIGNATURE,con,sig]
101
102asMakeAlist con ==
103  record := HGET($conHash,con)
104  [form,sig,predlist,kind,exposure,comments,typeCode,:filename] := first record
105--TTT in case we put the wrong thing in for niladic catgrs
106--if ATOM(form) and kind='category then form:=[form]
107  if ATOM(form) then form:=[form]
108  kind = 'function => asMakeAlistForFunction con
109  abb := asyAbbreviation(con, #(IFCDR sig))
110  if null IFCDR form then PUT(opOf form, 'NILADIC, 'T)
111  modemap := asySubstMapping LASSOC(con,$mmAlist)
112  $constructorCategory :local := CADAR modemap
113  parents := mySort HGET($parentsHash,con)
114--children:= mySort HGET($childrenHash,con)
115  alists  := HGET($opHash,con)
116  opAlist := SUBLISLIS($FormalMapVariableList, IFCDR form, CDDR alists)
117  ancestorAlist := SUBLISLIS($FormalMapVariableList, IFCDR form, first alists)
118  catAttrs := [[x,:true] for x in getAttributesFromCATEGORY $constructorCategory]
119  attributeAlist := REMDUP [:CADR alists,:catAttrs]
120  documentation :=
121      SUBLISLIS($FormalMapVariableList, IFCDR form, LASSOC(con, $docAlist))
122  filestring := STRCONC(PATHNAME_-NAME STRINGIMAGE filename,'".as")
123  constantPart := HGET($constantHash,con) and [['constant,:true]]
124  niladicPart := MEMQ(con,$niladics) and [['NILADIC,:true]]
125  falist := TAKE(#IFCDR form, $FormalMapVariableList)
126  constructorCategory :=
127    kind = 'category =>
128      talist := TAKE(#IFCDR form, $TriangleVariableList)
129      SUBLISLIS(talist, falist, $constructorCategory)
130    SUBLISLIS(falist, IFCDR form, $constructorCategory)
131  if constructorCategory='Category then kind := 'category
132  exportAlist := asGetExports(kind, form, constructorCategory)
133  constructorModemap  := SUBLISLIS(falist, IFCDR form, modemap)
134--TTT fix a niladic category constructormodemap (remove the joins)
135  if kind = 'category then
136     SETF(CADAR(constructorModemap),['Category])
137  res := [['constructorForm,:form],:constantPart,:niladicPart,
138           ['constructorKind,:kind],
139             ['constructorModemap,:constructorModemap],
140              ['abbreviation,:abb],
141               ['constructorCategory,:constructorCategory],
142                ['parents,:parents],
143                 ['attributes,:attributeAlist],
144                  ['ancestors,:ancestorAlist],
145                   --                ['children,:children],
146                   ['sourceFile,:filestring],
147                    ['operationAlist,:zeroOneConversion opAlist],
148                     ['modemaps,:asGetModemaps(exportAlist,form,kind,modemap)],
149                       ['sourcefile,:$asFilename],
150                         ['typeCode,:typeCode],
151                          ['documentation,:documentation]]
152  if $asyPrint then asyDisplay(con,res)
153  res
154
155asGetExports(kind, conform, catform) ==
156  [., :op_lst] := categoryParts1(kind, conform, catform, false) or return nil
157  -- ensure that signatures are lists
158  [[op, sigpred] for [op,sig,:pred] in op_lst] where
159    sigpred ==
160      pred :=
161        pred = "T" => nil
162        pred
163      [sig, nil, :pred]
164
165asMakeAlistForFunction fn ==
166  record := HGET($conHash,fn)
167  [form,sig,predlist,kind,exposure,comments,typeCode,:filename] := first record
168  modemap := LASSOC(fn,$mmAlist)
169  newsig := asySignature(sig,nil)
170  opAlist := [[fn,[newsig,nil,:predlist]]]
171  res := [['modemaps,:asGetModemaps(opAlist,fn,'function,modemap)],
172            ['typeCode,:typeCode]]
173  if $asyPrint then asyDisplay(fn,res)
174  res
175
176getAttributesFromCATEGORY catform ==
177  catform is ['CATEGORY,.,:r] => [y for x in r | x is ['ATTRIBUTE,y]]
178  catform is ['Join,:m,x]     => getAttributesFromCATEGORY x
179  nil
180
181displayDatabase x == main where
182  main ==
183    for y in
184     '(CONSTRUCTORFORM CONSTRUCTORKIND _
185       CONSTRUCTORMODEMAP _
186       ABBREVIATION _
187       CONSTRUCTORCATEGORY _
188       PARENTS _
189       ANCESTORS _
190       SOURCEFILE _
191       OPERATIONALIST _
192       MODEMAPS _
193       SOURCEFILE _
194       DOCUMENTATION) repeat fn(x,y)
195  fn(x,y) ==
196    sayBrightly ['"----------------- ",y,'" --------------------"]
197    pp GETDATABASE(x,y)
198
199-- For some reason Dick has modified as.boot to convert the
200-- identifier |0| or |1| to an integer in the list of operations.
201-- This is WRONG, all existing code assumes that operation names
202-- are always identifiers not numbers.
203-- This function breaks the ability of the interpreter to find
204-- |0| or |1| as exports of new compiler domains.
205-- Unless someone has a strong reason for keeping the change,
206-- this function should be no-opped, i.e.
207-- zeroOneConversion opAlist == opAlist
208-- If this change is made, then we are able to find asharp constants again.
209--   bmt Mar 26, 1994  and executed by rss
210
211zeroOneConversion opAlist == opAlist
212--   for u in opAlist repeat
213--     [op,:.] := u
214--     DIGITP (PNAME op).0 => RPLACA(u, string2Integer PNAME op)
215--   opAlist
216
217asyDisplay(con,alist) ==
218  banner := '"=============================="
219  sayBrightly [banner,'" ",con,'" ",banner]
220  for [prop,:value] in alist repeat
221    sayBrightlyNT [prop,'": "]
222    pp value
223
224asGetModemaps(opAlist,oform,kind,modemap) ==
225  acc:= nil
226  rpvl:=
227    MEMQ(kind, '(category function)) => rest $PatternVariableList -- *1 is special for $
228    $PatternVariableList
229  form := [opOf oform, :[y for x in IFCDR oform for y in rpvl]]
230  dc :=
231    MEMQ(kind, '(category function)) => "*1"
232    form
233  pred1 :=
234    kind = 'category => [["*1",form]]
235    nil
236  signature  := CDAR modemap
237  domainList :=
238    [[a,m] for a in rest form for m in rest signature |
239       asIsCategoryForm m]
240  catPredList:=
241    kind = 'function => [["isFreeFunction","*1",opOf form]]
242    [['ofCategory,:u] for u in [:pred1,:domainList]]
243--  for [op,:itemlist] in SUBLISLIS(rpvl, $FormalMapVariableList,opAlist) repeat
244--  the code seems to oscillate between generating $FormalMapVariableList
245--  and generating $TriangleVariableList
246  for [op,:itemlist] in SUBLISLIS(rpvl, $FormalMapVariableList,opAlist) repeat
247    for [sig0, pred] in itemlist repeat
248      sig := SUBST(dc,"$",sig0)
249      pred:= SUBST(dc,"$",pred)
250      sig := SUBLISLIS(rpvl, IFCDR oform, sig)
251      pred:= SUBLISLIS(rpvl, IFCDR oform, pred)
252      pred := pred or 'T
253  ----------> Constants change <--------------
254      if IDENTP sig0 then
255          sig := [sig]
256          pred := MKPF([pred,'(isAsConstant)],'AND)
257      pred' := MKPF([pred,:catPredList],'AND)
258      mm := [[dc,:sig],[pred']]
259      acc := [[op,:interactiveModemapForm mm],:acc]
260  NREVERSE acc
261
262asIsCategoryForm m ==
263  m = 'BasicType or GETDATABASE(opOf m,'CONSTRUCTORKIND) = 'category
264
265asyDocumentation con ==
266  docHash := HGET($docHash,con)
267  u := [[op,:[fn(x,op) for x in rec]] for op in HKEYS docHash
268           | rec := HGET(docHash,op)] where fn(x,op) ==
269    [form,sig,pred,origin,where?,comments,:.] := x
270    ----------> Constants change <--------------
271    if IDENTP sig then sig := [sig]
272    [asySignature(sig,nil),trimComments comments]
273  [form,sig,pred,origin,where?,comments] := first HGET($conHash,con)
274  --above "first" assumes only one entry
275  comments := trimComments asyExtractDescription comments
276  [:u,['constructor,[nil,comments]]]
277
278asyExtractDescription str ==
279  k := STRPOS('"Description:",str,0,nil) => asyExtractDescription SUBSTRING(str,k + 12,nil)
280  k := STRPOS('"Author:",str,0,nil) => asyExtractDescription SUBSTRING(str,0,k)
281  str
282
283trimComments str ==
284  null str or str = '"" => '""
285  m := MAXINDEX str
286  str := SUBSTRING(str,0,m)
287  trimString str
288
289asyExportAlist con ==
290--format of 'operationAlist property of LISPLIBS (as returned from koOps):
291--    <sig slotNumberOrNil optPred optELT>
292--!!! asyFile NEED: need to know if function is implemented by domain!!!
293  docHash := HGET($docHash,con)
294  [[op,:[fn(x,op) for x in rec]] for op in HKEYS docHash | rec := HGET(docHash,op)]
295       where fn(x,op) ==
296    [form,sig,pred,origin,where?,comments,:.] := x
297    tail :=
298      pred => [pred]
299      nil
300    newSig := asySignature(sig,nil)
301    [newSig,nil,:tail]
302
303asyMakeOperationAlist(con,proplist, key) ==
304  oplist :=
305    u := LASSOC('domExports,proplist) =>
306      kind := 'domain
307      u
308    u := LASSOC('catExports,proplist) =>
309      kind := 'category
310      u
311    key = 'domain =>
312      kind := 'domain
313      u := NIL
314    return nil
315  ht := MAKE_HASHTABLE('EQUAL)
316  ancestorAlist := nil
317  for ['Declare,id,form,r] in oplist repeat
318    id = "%%" =>
319      opOf form = con => nil
320      y := asyAncestors form
321      if opOf(y)~=con then ancestorAlist := [ [y,:true],:ancestorAlist]
322    idForm   :=
323      form is ['Apply,'_-_>,source,target] => [id,:asyArgs source]
324  ----------> Constants change <--------------
325      id
326    pred :=
327      LASSOC('condition,r) is p => hackToRemoveAnd p
328      nil
329    sig := asySignature(asytranForm(form,[idForm],nil),nil)
330    entry :=
331      --id ~= "%%" and IDENTP idForm => [[sig],nil,nil,'ASCONST]
332      id ~= "%%" and IDENTP idForm =>
333          pred => [[sig],nil,asyPredTran pred,'ASCONST]
334          [[sig],nil,true,'ASCONST]
335      pred => [sig,nil,asyPredTran pred]
336      [sig]
337    HPUT(ht,id,[entry,:HGET(ht,id)])
338  opalist := [[op,:REMDUP HGET(ht,op)] for op in HKEYS ht]
339  HPUT($opHash,con,[ancestorAlist,nil,:opalist])
340
341hackToRemoveAnd p ==
342---remove this as soon as .asy files do not contain forms (And pred) forms
343  p is ['And,q,:r] =>
344    r => ['AND,q,:r]
345    q
346  p
347
348asyAncestors x ==
349  x is ['Apply,:r] => asyAncestorList r
350  x is [op,y,:.] and MEMQ(op, '(PretendTo RestrictTo)) => asyAncestors y
351  atom x =>
352    x = '_% => '_$
353    MEMQ(x, $niladics)       => [x]
354    GETDATABASE(x ,'NILADIC) => [x]
355    x
356  asyAncestorList x
357
358asyAncestorList x == [asyAncestors y for y in x]
359--============================================================================
360--       Build Operation Alist from sig
361--============================================================================
362
363--format of operations as returned from koOps
364--    <sig pred pakOriginOrNil TifPakExposedOrNil>
365--    <sig pred origin         exposed?>
366
367--abb,kind,file,sourcefile,coSig,dbLineNumber,constructorArgs,libfile
368--((sig  where(NIL or #)  condition(T or pred)  ELT) ...
369--expanded lists are: sig, predicate, origin, exposeFlag, comments
370
371--============================================================================
372--       Building Hash Tables for Operations/Constructors
373--============================================================================
374asytran fn ==
375--put operations into table format for browser:
376--    <sig pred origin         exposed? comments>
377  inStream := OPEN fn
378  sayBrightly ['"   Reading ",fn]
379  u := VMREAD inStream
380  $niladics := mkNiladics u
381  for x in $niladics repeat PUT(x,'NILADIC,true)
382  for d in u repeat
383    ['Declare,name,:.] := d
384    name = "%%" => 'skip       --skip over top-level properties
385    $docHashLocal: local := MAKE_HASHTABLE('EQUAL)
386    asytranDeclaration(d,'(top),nil,false)
387    if null name then BREAK()
388    HPUT($docHash,name,$docHashLocal)
389  CLOSE inStream
390  'done
391
392mkNiladics u ==
393  [name for x in u | x is ['Declare,name,y,:.] and y isnt ['Apply,'_-_>,:.]]
394
395asytranDeclaration(dform,levels,predlist,local?) ==
396  ['Declare,id,form,r] := dform
397  id = 'failed => id
398  IFCAR dform ~= 'Declare => systemError '"asytranDeclaration"
399  if levels = '(top) then
400    if form isnt ['Apply,"->",:.] then HPUT($constantHash,id,true)
401  comments := LASSOC('documentation,r) or '""
402  idForm   :=
403    levels is ['top,:.] =>
404      form is ['Apply,'_-_>,source,target] => [id,:asyArgs source]
405      id
406  ----------> Constants change <--------------
407    id
408  newsig  := asytranForm(form,[idForm,:levels],local?)
409  key :=
410    levels is ['top,:.] =>
411      MEMQ(id,'(%% Category Type)) => 'constant
412      asyLooksLikeCatForm? form => 'category
413      form is ['Apply, '_-_>,.,u] =>
414        if u is ['Apply, construc,:.] then u:= construc
415        GETDATABASE(opOf u,'CONSTRUCTORKIND) = 'domain  => 'function
416        asyLooksLikeCatForm? u => 'category
417        'domain
418      'domain
419    first levels
420  typeCode := LASSOC('symeTypeCode,r)
421  record := [idForm,newsig,asyMkpred predlist,key,true,comments,typeCode,:$asyFile]
422  if not local? then
423    ht :=
424      levels = '(top) => $conHash
425      $docHashLocal
426    HPUT(ht,id,[record,:HGET(ht,id)])
427  if levels = '(top) then asyMakeOperationAlist(id,r, key)
428  ['Declare,id,newsig,r]
429
430asyLooksLikeCatForm? x ==
431--TTT don't see a Third in my version ....
432  x is ['Define, ['Declare, ., ['Apply, 'Third,:.],:.],:.] or
433   x is ['Define, ['Declare, ., 'Category ],:.]
434
435asyIsCatForm form ==
436  form is ['Apply,:r] =>
437    r is ['_-_>,.,a] => asyIsCatForm a
438    r is ['Third,'Type,:.] => true
439    false
440  false
441
442asyArgs source ==
443  args :=
444    source is [op,:u] and asyComma? op => u
445    [source]
446  [asyArg x for x in args]
447
448asyArg x ==
449  x is ['Declare,id,:.] => id
450  x
451
452asyMkpred predlist ==
453  null predlist => nil
454  predlist is [p] => p
455  ['AND,:predlist]
456
457asytranForm(form,levels,local?) ==
458  u := asytranForm1(form,levels,local?)
459  null u => hahah()
460  u
461
462asytranForm1(form,levels,local?) ==
463  form is ['With,left,cat] =>
464--  left ~= nil       => error '"WITH cannot take a left argument yet"
465    asytranCategory(form,levels,nil,local?)
466  form is ['Apply,:.]   => asytranApply(form,levels,local?)
467  form is ['Declare,:.] => asytranDeclaration(form,levels,nil,local?)
468  form is ['Comma,:r]  => ['Comma,:[asytranForm(x,levels,local?) for x in r]]
469--form is ['_-_>,:s] => asytranMapping(s,levels,local?)
470  form is [op,a,b] and MEMQ(a,'(PretendTo RestrictTo)) =>
471    asytranForm1(a,levels,local?)
472  form is ['LitInteger,s] =>
473        READ_-FROM_-STRING(s)
474  form is ['Define,:.]  =>
475    form is ['Define,['Declare,.,x,:.],rest] =>
476--TTT i don't know about this one but looks ok
477      x = 'Category => asytranForm1(rest,levels, local?)
478      asytranForm1(x,levels,local?)
479    error '"DEFINE forms are not handled yet"
480  if form = '_% then $hasPerCent := true
481  IDENTP form =>
482    form = "%" => "$"
483    GETL(form,'NILADIC) => [form]
484    form
485  [asytranForm(x,levels,local?) for x in form]
486
487asytranApply(['Apply,name,:arglist],levels,local?) ==
488  MEMQ(name,'(Record Union)) =>
489    [name,:[asytranApplySpecial(x, levels, local?) for x in arglist]]
490  null arglist => [name]
491  name is [ 'RestrictTo, :.] =>
492    asytranApply(['Apply, first rest name, :arglist], levels, local?)
493  name is [ 'Qualify, :.] =>
494    asytranApply(['Apply, first rest name, :arglist], levels, local?)
495  name is 'string => asytranLiteral first arglist
496  name is 'integer => asytranLiteral first arglist
497  name is 'float => asytranLiteral first arglist
498  name = 'Enumeration =>
499    ["Enumeration",:[asytranEnumItem arg for arg in arglist]]
500  [:argl,lastArg] := arglist
501  [name,:[asytranFormSpecial(arg,levels,true) for arg in argl],
502          asytranFormSpecial(lastArg,levels,false)]
503
504asytranLiteral(lit) ==
505  first rest lit
506
507asytranEnumItem arg ==
508  arg is ['Declare, name, :.] => name
509  error '"Bad Enumeration entry"
510
511asytranApplySpecial(x, levels, local?) ==
512  x is ['Declare, name, typ, :.] => [":",name,asytranForm(typ, levels, local?)]
513  asytranForm(x, levels, local?)
514
515asytranFormSpecial(x, levels, local?) ==  --> this throws away variable name (revise later)
516  x is ['Declare, name, typ, :.] => asytranForm(typ, levels, local?)
517  asytranForm(x, levels, local?)
518
519asytranCategory(form,levels,predlist,local?) ==
520  cat :=
521    form is ['With,left,right] =>
522      right is ['Blank,:.] => ['Sequence]
523      right
524    form
525  left :=
526    form is ['With,left,right] =>
527      left is ['Blank,:.] => nil
528      left
529    nil
530  $hasPerCent: local := nil
531  items :=
532    cat is ['Sequence,:s] => s
533    [cat]
534  catTable := MAKE_HASHTABLE('EQUAL)
535  catList  := nil
536  for x in items | x repeat
537    if null x then systemError()
538    dform := asytranCategoryItem(x,levels,predlist,local?)
539    null dform => nil
540    dform is ['Declare,id,record,r] =>
541      HPUT(catTable,id,[asyWrap(record,predlist),:HGET(catTable,id)])
542    catList := [asyWrap(dform,predlist),:catList]
543  keys := listSort(function GLESSEQP,HKEYS catTable)
544  right1 := NREVERSE catList
545  right2 := [[key,:HGET(catTable,key)] for key in keys]
546  right :=
547    right2 => [:right1,['Exports,:right2]]
548    right1
549  res :=
550    left => [left,:right]
551    right
552  res is [x] and x is ['IF,:.] => x
553  ['With,:res]
554
555asyWrap(record,predlist) ==
556  predlist => ['IF,MKPF(predlist,'AND),record]
557  record
558
559asytranCategoryItem(x,levels,predlist,local?) ==
560  x is ['If,predicate,item,:r] =>
561    IFCAR r => error '"ELSE expressions not allowed yet in conditionals"
562    pred :=
563      predicate is ['Test,r] => r
564      predicate
565    asytranCategory(item,levels,[pred,:predlist],local?)
566  MEMQ(IFCAR x, '(Default Foreign)) => nil
567  x is ['Declare,:.] => asytranDeclaration(x,levels,predlist,local?)
568  x
569
570--============================================================================
571--          Extending Constructor Datatable
572--============================================================================
573--FORMAT of $constructorDataTable entry:
574--abb kind libFile sourceFile coSig constructorArgs
575--alist is ((kind . domain) (libFile . MATRIX) (sourceFile . "matrix")
576--         (coSig NIL T) (dbLineNumber . 29187) (constructorArgs R)
577--  (modemap . (
578--    (|Matrix| |#1|)
579--      (Join (MatrixCategory #1 (Vector #1) (Vector #1))
580--        (CATEGORY domain
581--          (SIGNATURE diagonalMatrix ($ (Vector #1)))
582--          (IF (has #1 (Field))
583--            (SIGNATURE inverse ((Union $ "failed") $)) noBranch)))
584--      (Ring))
585--    (T Matrix))   )
586extendConstructorDataTable() ==
587  for x in listSort(function GLESSEQP,HKEYS $conHash) repeat
588     record := HGET($conHash,x)
589     [form,sig,predlist,origin,exposure,comments,typeCode,:filename] := first record
590     abb := asyAbbreviation(x,#(rest sig))
591     kind := 'domain
592     --Note: this "first" assumes that there is ONLY one sig per name
593     cosig := [nil,:asyCosig sig]
594     args  := asyConstructorArgs sig
595     tb :=
596       [[x,abb,
597          ['kind,:kind],
598            ['cosig,:cosig],
599              ['libfile,filename],
600                ['sourceFile,STRINGIMAGE filename],
601                  ['constructorArgs,:args]],:tb]
602  listSort(function GLESSEQP,ASSOCLEFT tb)
603
604asyConstructorArgs sig ==
605  sig is ['With,:.] => nil
606  sig is ['_-_>,source,target] =>
607    source is [op,:argl] and asyComma? op => [asyConstructorArg x for x in argl]
608    [asyConstructorArg source]
609
610asyConstructorArg x ==
611  x is ['Declare,name,t,:.] => name
612  x
613
614asyCosig sig ==    --can be a type or could be a signature
615  atom sig or sig is ['With,:.] => nil
616  sig is ['_-_>,source,target] =>
617    source is [op,:argl] and asyComma? op => [asyCosigType x for x in argl]
618    [asyCosigType source]
619  error false
620
621asyCosigType u ==
622  u is [name,t] =>
623    t is [fn,:.] =>
624      asyComma? fn => fn
625      fn = 'With  => 'T
626      nil
627    t = 'Type => 'T
628    error '"Unknown atomic type"
629  error false
630
631asyAbbreviation(id,n) ==  chk(id,main) where   --> n = number of arguments
632  main ==
633    a := createAbbreviation id => a
634    name := PNAME id
635--  #name < 8 => INTERN UPCASE name
636    parts := asySplit(name,MAXINDEX name)
637    newname := "STRCONC"/[asyShorten x for x in parts]
638    #newname < 8 => INTERN newname
639    tryname := SUBSTRING(name,0,7)
640    not createAbbreviation tryname => INTERN UPCASE tryname
641    nil
642  chk(conname,abb) ==
643    (xx := asyGetAbbrevFromComments conname) => xx
644    con := abbreviation? abb =>
645      conname = con => abb
646      conname
647    abb
648
649asyGetAbbrevFromComments con ==
650  docHash := HGET($docHash,con)
651  u := [[op,:[fn(x,op) for x in rec]] for op in HKEYS docHash
652           | rec := HGET(docHash,op)] where fn(x,op) ==
653    [form,sig,pred,origin,where?,comments,:.] := x
654    ----------> Constants change <--------------
655    if IDENTP sig then sig := [sig]
656    [asySignature(sig,nil),trimComments comments]
657  [form,sig,pred,origin,where?,comments] := first HGET($conHash,con)
658  --above "first" assumes only one entry
659  x := asyExtractAbbreviation comments
660  x => intern x
661  NIL
662
663asyExtractAbbreviation str ==
664        not (k:= STRPOS('"Abbrev: ",str,0,nil)) => NIL
665        str := SUBSTRING(str, k+8, nil)
666        k := STRPOS($stringNewline, str,0,nil)
667        k => SUBSTRING(str, 0, k)
668        str
669
670asyShorten x ==
671  y := createAbbreviation x
672    or LASSOC(x,
673        '(("Small" . "SM") ("Single" ."S") ("Half" . "H")("Point" . "PT")
674            ("Floating" . "F") ("System" . "SYS") ("Number" . "N")
675             ("Inventor" . "IV")
676              ("Finite" . "F") ("Double" . "D") ("Builtin" . "BI"))) => y
677  UPCASE x
678
679asySplit(name,end) ==
680  end < 1 => [name]
681  k := 0
682  for i in 1..end while LOWER_-CASE_-P name.i repeat k := i
683  k := k + 1
684  [SUBSTRING(name,0,k),:asySplit(SUBSTRING(name,k,nil),end-k)]
685
686createAbbreviation s ==
687  if STRINGP s then s := INTERN s
688  a := constructor? s
689  a ~= s => a
690  nil
691
692--============================================================================
693--       extending getConstructorModemap Property
694--============================================================================
695--Note: modemap property is built when getConstructorModemap is called
696
697asyConstructorModemap con ==
698  HGET($conHash,con) isnt [record,:.] => nil   --not there
699  [form,sig,predlist,kind,exposure,comments,typeCode,:filename] := record
700  $kind: local := kind
701  --NOTE: sig has the form (-> source target) or simply (target)
702  $constructorArgs : local := IFCDR form
703  signature := asySignature(sig,false)
704  formals := ['_$,:TAKE(#$constructorArgs,$FormalMapVariableList)]
705  mm := [[[con,:$constructorArgs],:signature],['T,con]]
706  SUBLISLIS(formals,['_%,:$constructorArgs],mm)
707
708asySignature(sig,names?) ==
709  sig is ['Join,:.] => [asySig(sig,nil)]
710  sig is ['With,:.] => [asySig(sig,nil)]
711  sig is ['_-_>,source,target] =>
712    target :=
713      names? => ['dummy,target]
714      target
715    source is [op,:argl] and asyComma? op =>
716      [asySigTarget(target,names?),:[asySig(x,names?) for x in argl]]
717    [asySigTarget(target,names?),asySig(source,names?)]
718  ----------> The following is a hack for constants which are category names<--
719  sig is ['Third,:.] => [asySig(sig,nil)]
720  ----------> Constants change <--------------
721  asySig(sig,nil)
722
723asySigTarget(u,name?) == asySig1(u,name?,true)
724
725asySig(u,name?) == asySig1(u,name?,false)
726
727asySig1(u,name?,target?) ==
728  x :=
729    name? and u is [name,t] => t
730    u
731  x is [fn,:r] =>
732    fn = 'Join => asyTypeJoin r       ---------> jump out to newer code 4/94
733    MEMQ(fn, '(RestrictTo PretendTo)) => asySig(first r,name?)
734    asyComma? fn =>
735      u := [asySig(x,name?) for x in r]
736      target? =>
737        null u => '(Void)
738        -- this implies a multiple value return, not currently supported
739        -- in the interpreter
740        ['Multi,:u]
741      u
742    fn = 'With  => asyCATEGORY r
743    fn = 'Third =>
744      r is [b] =>
745        b is ['With,:s]  => asyCATEGORY s
746        b is ['Blank,:.] => asyCATEGORY nil
747      error x
748    fn = 'Apply and r is ['_-_>,:s] => asyMapping(s,name?)
749    fn = '_-_> => asyMapping(r,name?)
750    fn = 'Declare and r is [name,typ,:.] =>
751        asySig1(typ, name?, target?)
752    x is '(_%) => '(_$)
753    [fn,:[asySig(x,name?) for x in r]]
754--x = 'Type => '(Type)
755  x = '_% => '_$
756  x
757
758asyMapping([a,b],name?) ==
759  newa := asySig(a,name?)
760  b    := asySig(b,name?)
761  args :=
762    a is [op,:r] and asyComma? op => newa
763    [a]
764  ['Mapping,b,:args]
765
766--============================================================================
767--       code for asySignatures of the form (Join,:...)
768--============================================================================
769asyType x ==
770  x is [fn,:r] =>
771    fn = 'Join => asyTypeJoin r
772    MEMQ(fn, '(RestrictTo PretendTo)) => asyType first r
773    asyComma? fn =>
774      u := [asyType x for x in r]
775      u
776    fn = 'With  => asyCATEGORY r
777    fn = '_-_> => asyTypeMapping r
778    fn = 'Apply => r
779--  fn = 'Declare and r is [name,typ,:.] => typ
780    x is '(_%) => '(_$)
781    x
782--x = 'Type => '(Type)
783  x = '_% => '_$
784  x
785
786asyTypeJoin r ==
787  $conStack : local := nil
788  $opStack  : local := nil
789  $predlist : local := nil
790  for x in r repeat asyTypeJoinPart(x,$predlist)
791  catpart :=
792    $opStack => ['CATEGORY,$kind,:asyTypeJoinStack REVERSE $opStack]
793    nil
794  conpart := asyTypeJoinStack REVERSE $conStack
795  conpart =>
796    catpart     => ['Join,:conpart,catpart]
797    rest conpart => ['Join, :conpart]
798    conpart
799  catpart
800
801asyTypeJoinPart(x,$predlist) ==
802  x is ['Join,:y] => for z in y repeat asyTypeJoinPart(z, $predlist)
803  x is ['With,:y] => for p in y repeat asyTypeJoinPartWith p
804  asyTypeJoinPartWith x
805
806asyTypeJoinPartWith x ==
807  x is ['Exports,:y] => for p in y repeat asyTypeJoinPartExport p
808  x is ['Exports,:.] => systemError 'exports
809  x is ['Comma]  => nil
810  x is ['Export,:y]  => nil
811  x is ['IF,:r] => asyTypeJoinPartIf r
812  x is ['Sequence,:x] => for y in x repeat asyTypeJoinItem y
813  asyTypeJoinItem x
814
815asyTypeJoinPartIf [pred,value] ==
816  predlist := [asyTypeJoinPartPred pred,:$predlist]
817  asyTypeJoinPart(value,predlist)
818
819asyTypeJoinPartPred x ==
820  x is ['Test, y] => asyTypeUnit y
821  asyTypeUnit x
822
823asyTypeJoinItem x ==
824  result := asyTypeUnit x
825  isLowerCaseLetter (PNAME opOf result).0 =>
826    $opStack := [[['ATTRIBUTE,result],:$predlist],:$opStack]
827  $conStack := [[result,:$predlist],:$conStack]
828
829asyTypeMapping([a,b]) ==
830  a := asyTypeUnit a
831  b := asyTypeUnit b
832  args :=
833    a is [op,:r] and asyComma? op => r
834    [a]
835  ['Mapping,b,:args]
836
837asyTypeUnit x ==
838  x is [fn,:r] =>
839    fn = 'Join => systemError 'Join ----->asyTypeJoin r
840    MEMQ(fn, '(RestrictTo PretendTo)) => asyTypeUnit first r
841    asyComma? fn =>
842      u := [asyTypeUnit x for x in r]
843      u
844    fn = 'With  => asyCATEGORY r
845    fn = '_-_> => asyTypeMapping r
846    fn = 'Apply => asyTypeUnitList r
847    fn = 'Declare and r is [name,typ,:.] => asyTypeUnitDeclare(name,typ)
848    x is '(_%) => '(_$)
849    [fn,:asyTypeUnitList r]
850  GETL(x,'NILADIC) => [x]
851--x = 'Type => '(Type)
852  x = '_% => '_$
853  x
854
855asyTypeUnitList x == [asyTypeUnit y for y in x]
856
857asyTypeUnitDeclare(op,typ) ==
858  typ is ['Apply, :r] => asyCatSignature(op,r)
859  asyTypeUnit typ
860--============================================================================
861--               Translator for ['With,:.]
862--============================================================================
863asyCATEGORY x ==
864  if x is [join,:y] and join is ['Apply,:s] then
865    exports := y
866    joins :=
867      s is ['Join,:r] => [asyJoinPart u for u in r]
868      [asyJoinPart s]
869  else if x is [id,:y] and IDENTP id then
870    joins := [[id]]
871    exports := y
872  else
873    joins   := nil
874    exports := x
875  cats       := exports
876  operations := nil
877  if exports is [:r,['Exports,:ops]] then
878    cats := r
879    operations := ops
880  exportPart :=
881    ['CATEGORY,'domain,:"APPEND"/[asyCatItem y for y in operations]]
882  cats := "append"/[asyCattran c for c in cats]
883  joins or cats =>
884    ['Join,:joins,:cats, exportPart]
885  exportPart
886
887simpCattran x ==
888  u := asyCattran x
889  u is [y] => y
890  ['Join,:u]
891
892asyCattran x ==
893  x is ['With,:r] => "append"/[asyCattran1 x for x in r]
894  x is ['IF,:.]   => "append"/[asyCattranConstructors(x,nil)]
895  [x]
896
897asyCattran1 x ==
898  x is ['Exports,:y] => "append"/[asyCattranOp u for u in y]
899  x is ['IF,:.]      => "append"/[asyCattranConstructors(x,nil)]
900  systemError nil
901
902asyCattranOp [op,:items] ==
903  "append"/[asyCattranOp1(op,item,nil) for item in items]
904
905asyCattranOp1(op, item, predlist) ==
906  item is ['IF, p, x] =>
907    pred := asyPredTran
908      p is ['Test,t] => t
909      p
910--    x is ['IF,:.] => "append"/[asyCattranOp1('IF, x, [pred,:predlist])]
911--  This line used to call asyCattranOp1 with too few arguments.  Following
912--  fix suggested by RDJ.
913    x is ['IF,:.] => "append"/[asyCattranOp1(op,y,[pred,:predlist]) for y in x]
914    [['IF, asySimpPred(pred,predlist), asyCattranSig(op,x), 'noBranch]]
915  [asyCattranSig(op,item)]
916
917asyPredTran p == asyPredTran1 asyJoinPart p
918
919asyPredTran1 p ==
920  p is ['Has,x,y] => ['has,x, simpCattran y]
921  p is ['Test, q] => asyPredTran1 q
922  p is [op,:r] and MEMQ(op,'(AND OR NOT)) =>
923    [op,:[asyPredTran1 q for q in r]]
924  p
925
926asyCattranConstructors(item, predlist) ==
927  item is ['IF, p, x] =>
928    pred := asyPredTran
929      p is ['Test,t] => t
930      p
931    x is ['IF,:.] => "append"/[asyCattranConstructors(x, [pred,:predlist])]
932    form := ['ATTRIBUTE, asyJoinPart x]
933    [['IF, asySimpPred(pred,predlist), form, 'noBranch]]
934  systemError()
935
936asySimpPred(p, predlist) ==
937  while predlist is [q,:predlist] repeat p := quickAnd(q,p)
938  p
939
940asyCattranSig(op,y) ==
941  y isnt ["->",source,t] =>
942-- following makes constants into nullary functions
943     ['SIGNATURE, op, [asyTypeUnit y]]
944  s :=
945    source is ['Comma,:s] => [asyTypeUnit z for z in s]
946    [asyTypeUnit source]
947  t := asyTypeUnit t
948  null t => ['SIGNATURE,op,s]
949  ['SIGNATURE,op,[t,:s]]
950
951asyJoinPart x ==
952  IDENTP x => [x]
953  asytranForm(x,nil,true)
954
955asyCatItem item ==
956  atom item  => [item]
957  item is ['IF,.,.] => [item]
958  [op,:sigs] := item
959  [asyCatSignature(op,sig) for sig in sigs | sig]
960
961asyCatSignature(op,sig) ==
962  sig is ['_-_>,source,target] =>
963     ['SIGNATURE,op, [asyTypeItem target,:asyUnTuple source]]
964  ----------> Constants change <--------------
965-- following line converts constants into nullary functions
966  ['SIGNATURE,op,[asyTypeItem sig]]
967
968asyUnTuple x ==
969  x is [op,:u] and asyComma? op => [asyTypeItem y for y in u]
970  [asyTypeItem x]
971
972asyTypeItem x ==
973  atom x =>
974    x = '_%         => '_$
975    x
976  x is ['_-_>,a,b] =>
977      ['Mapping,b,:asyUnTuple a]
978  x is ['Apply,:r] =>
979    r is ['_-_>,a,b] =>
980      ['Mapping,b,:asyUnTuple a]
981    r is ['Record,:parts] =>
982      ['Record,:[[":",a,b] for ['Declare,a,b,:.] in parts]]
983    r is ['Segment,:parts] =>
984      ['Segment,:[asyTypeItem x for x in parts]]
985    asytranApply(x,nil,true)
986  x is ['Declare,.,t,:.] => asyTypeItem t
987  x is ['Comma,:args] =>
988    -- this implies a multiple value return, not currently supported
989    -- in the interpreter
990    args => ['Multi,:[asyTypeItem y for y in args]]
991    ['Void]
992  [asyTypeItem y for y in x]
993
994--============================================================================
995--               Utilities
996--============================================================================
997asyComma? op == MEMQ(op,'(Comma Multi))
998
999
1000hput(table,name,value) ==
1001  if null name then systemError()
1002  HPUT(table,name,value)
1003
1004--============================================================================
1005--               Dead Code (for a very odd value of 'dead')
1006--============================================================================
1007asyTypeJoinPartExport x ==
1008  [op,:items] := x
1009  for y in items repeat
1010    y isnt ["->",source,t] =>
1011--       sig := ['TYPE, op, asyTypeUnit y]
1012-- converts constants to nullary functions (this code isn't dead)
1013       sig := ['SIGNATURE, op, [asyTypeUnit y]]
1014       $opStack := [[sig,:$predlist],:$opStack]
1015    s :=
1016      source is ['Comma,:s] => [asyTypeUnit z for z in s]
1017      [asyTypeUnit source]
1018    t := asyTypeUnit t
1019    sig :=
1020      null t => ['SIGNATURE,op,s]
1021      ['SIGNATURE,op,[t,:s]]
1022    $opStack := [[sig,:$predlist],:$opStack]
1023
1024--============================================================================
1025--               Code to create opDead Code
1026--============================================================================
1027asyTypeJoinStack r ==
1028  al := [[[x while r is [[x, :q],:s] and p = q and (r := s; true)],:p]
1029           while r is [[.,:p],:.]]
1030  result := "append"/[fn for [y,:p] in al] where fn ==
1031    p => [['IF,asyTypeMakePred p,:y]]
1032    y
1033  result
1034
1035asyTypeMakePred [p,:u] ==
1036  while u is [q,:u] repeat p := quickAnd(q,p)
1037  p
1038