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--====================> WAS b-op1.boot <================================
35
36--=======================================================================
37--                   Operation Page Menu
38--=======================================================================
39--opAlist has form [[op,:alist],:.]  where each alist
40--        has form [sig,pred,origin,exposeFlag,comments]
41
42dbFromConstructor?(htPage) == htpProperty(htPage,'conform)
43
44dbDoesOneOpHaveParameters? opAlist ==
45  or/[(or/[fn for x in items]) for [op,:items] in opAlist] where fn ==
46    STRINGP x => dbPart(x,2,1) ~= '"0"
47    IFCAR x
48--============================================================================
49--               Master Switch Functions for Operation Views
50--============================================================================
51
52dbShowOps(htPage, which, key) ==
53  --NEXT LINE SHOULD BE REMOVED if we are sure that which is a string
54  which := STRINGIMAGE which
55  which ~= '"operation" => BREAK()
56  if MEMQ(key,'(extended basic all)) then
57    $groupChoice := key
58    key := htpProperty(htPage,'key) or 'names
59  opAlist := htpProperty(htPage, 'opAlist)
60  key = 'generalise =>
61    arg  := STRINGIMAGE CAAR opAlist
62    oPage arg
63  key = 'allDomains => dbShowOpAllDomains(htPage,opAlist,which)
64  key = 'filter =>
65    filter := pmTransFilter(dbGetInputString htPage)
66    filter is ['error,:.] => bcErrorPage filter
67    opAlist:= [x for x in opAlist | superMatch?(filter,DOWNCASE STRINGIMAGE opOf x)]
68    null opAlist => emptySearchPage(which, filter, false)
69    htPage := htInitPageNoHeading(htCopyProplist htPage)
70    htpSetProperty(htPage, 'opAlist, opAlist)
71    if not (htpProperty(htPage, 'condition?) = 'no) then
72      dbResetOpAlistCondition(htPage,which,opAlist)
73    dbShowOps(htPage,which,htpProperty(htPage,'exclusion))
74  htpSetProperty(htPage,'key,key)
75  if MEMQ(key,'(exposureOn exposureOff)) then
76    $exposedOnlyIfTrue :=
77       key = 'exposureOn => 'T
78       nil
79    key := htpProperty(htPage,'exclusion)
80  dbShowOp1(htPage,opAlist,which,key)
81
82reduceByGroup(htPage,opAlist) ==
83  not dbFromConstructor?(htPage) or null $groupChoice => opAlist
84  dbExpandOpAlistIfNecessary(htPage,opAlist,'"operation",true,false)
85  bitNumber := HGET($topicHash,$groupChoice)
86  res := [[op,:newItems] for [op,:items] in opAlist | newItems] where
87    newItems ==
88      null bitNumber => items
89      [x for x in items | FIXP (code := LASTATOM x) and LOGBITP(bitNumber,code)]
90  res
91
92dbShowOp1(htPage,opAlist,which,key) ==
93  --set up for filtering below in dbGatherData
94  which ~= '"operation" => BREAK()
95  if INTEGERP key then
96    -- BREAK()
97    opAlist := dbSelectData(htPage,opAlist,key)
98    ------> Jump out for constructor names in file <--------
99  INTEGERP key and opAlist is [[con,:.]] and htpProperty(htPage,'isFile)
100      and constructor? con => return conPageChoose con
101  if INTEGERP key then
102    htPage := htInitPageNoHeading(htCopyProplist htPage)
103    htpSetProperty(htPage, 'opAlist, opAlist)
104    if not (htpProperty(htPage, 'condition?) = 'no) then
105      dbResetOpAlistCondition(htPage,which,opAlist)
106  dbExpandOpAlistIfNecessary(htPage,opAlist,which,true,false)
107  if $exposedOnlyIfTrue and not dbFromConstructor?(htPage) then
108  --opAlist is expanded to form [[op,[sig,pred,origin,exposed,comments],...],...]
109    opAlist:=[item for [op,:items] in opAlist | item] where
110      item ==
111        acc := nil
112        for x in items | x.3 repeat acc:= [x,:acc]
113        null acc => nil
114        [op,:NREVERSE acc]
115  $conformsAreDomains : local := htpProperty(htPage,'domname)
116  opCount := opAlistCount(opAlist, which)
117  branch :=
118    INTEGERP key =>
119      opCount <= $opDescriptionThreshold => 'documentation
120      'names
121    key = 'names and null rest opAlist =>      --means a single op
122      opCount <= $opDescriptionThreshold => 'documentation
123      'names
124    key
125  [what,whats,fn] := LASSOC(branch,$OpViewTable)
126  data := dbGatherData(htPage,opAlist,which,branch)
127  dataCount := +/[1 for x in data | (what = '"Name" and $exposedOnlyIfTrue => atom x; true)]
128  namedPart :=
129    null rest opAlist =>
130      ops := escapeSpecialChars STRINGIMAGE CAAR opAlist
131      ['" {\em ",ops,'"}"]
132    nil
133  if what = '"Condition" and null IFCAR IFCAR data then dataCount := dataCount - 1
134  exposurePart :=
135    $exposedOnlyIfTrue => '(" Exposed ")
136    nil
137  firstPart :=
138    opCount = 0 => ['"No ",:exposurePart, pluralize capitalize which]
139    dataCount = 1 or dataCount = opCount =>
140      opCount = 1 => [:exposurePart, capitalize which,:namedPart]
141      [STRINGIMAGE opCount,'" ",:exposurePart,
142         pluralize capitalize which,:namedPart]
143    prefix := pluralSay(dataCount,what,whats)
144    [:prefix,'" for ",STRINGIMAGE opCount,'" ",pluralize capitalize which,:namedPart]
145  page := htInitPageNoHeading(htCopyProplist htPage)
146  ------------>above line used to call htInitPageHoHeading<----------
147  htAddHeading dbShowOpHeading([:firstPart,:fromHeading page], branch)
148  htpSetProperty(page,'data,data)
149  htpSetProperty(page,'branch,branch)
150  -- the only place where specialMessage property is set seems to be commented. out
151  if u := htpProperty(page,'specialMessage) then APPLY(first u,rest u)
152  htSayStandard('"\beginscroll ")
153  FUNCALL(fn,page,opAlist,which,data) --apply branch function
154  dbOpsExposureMessage()
155  htSayStandard("\endscroll ")
156  dbPresentOps(page,which,branch)
157  htShowPageNoScroll()
158
159opAlistCount(opAlist, which) == +/[foo for [op,:items] in opAlist] where foo ==
160  which = '"attribute" => BREAK()
161  null $exposedOnlyIfTrue => #items
162  +/[1 for w in items | null (p := CDDR w) or p . 1]
163
164dbShowOpHeading(heading, branch) ==
165  suffix :=
166--  branch = 'signatures => '" viewed as signatures"
167    branch = 'parameters => '" viewed with parameters"
168    branch = 'origins    => '" organized by origins"
169    branch = 'conditions => '" organized by conditions"
170    '""
171  [:heading, suffix]
172
173dbOpsExposureMessage() ==
174  $atLeastOneUnexposed => htSay '"{\em *} = unexposed"
175
176fromHeading htPage ==
177  null htPage => '""
178  $pn := [htPage.0,'"}{"]
179  updomain := htpProperty(htPage,'updomain) =>
180    dnForm  := dbExtractUnderlyingDomain updomain
181    dnString:= form2StringList dnForm
182    dnFence := form2Fence  dnForm
183--  upString:= form2StringList updomain
184    upFence := form2Fence  updomain
185    upOp    := PNAME opOf  updomain
186    ['" {\em from} ",:dbConformGen dnForm,'" {\em under} \ops{",upOp,'"}{",:$pn,:upFence,'"}"]
187  domname  := htpProperty(htPage,'domname)
188  numberOfUnderlyingDomains := #[x for x in rest GETDATABASE(opOf domname,'COSIG) | x]
189--  numberOfUnderlyingDomains = 1 and
190--    IFCDR domname and (dn := dbExtractUnderlyingDomain domname) =>
191--      ['" {\em from} ",:pickitForm(domname,dn)]
192  IFCDR domname => ['" {\em from} ", :dbConformGen domname]
193  htpProperty(htPage,'fromHeading)
194
195-- pickitForm(form,uarg) ==
196--   conform2StringList(form,FUNCTION dbConform,FUNCTION conformString,uarg)
197
198conform2StringList(form, opFn, argFn) ==
199  [op1,:args] := form
200  op := IFCAR HGET($lowerCaseConTb,op1) or op1
201  null args => APPLY(opFn,[op])
202  special := MEMQ(op,'(Union Record Mapping))
203  cosig :=
204    special => ['T for x in args]
205    rest GETDATABASE(op,'COSIG)
206  atypes :=
207    special => cosig
208    rest CDAR GETDATABASE(op,'CONSTRUCTORMODEMAP)
209  sargl := [fn for x in args for atype in atypes for pred in cosig] where fn ==
210    keyword :=
211      special and x is [":",y,t] =>
212        x := t
213        y
214      nil
215    res :=
216      pred =>
217        STRINGP x => [x]
218        u := APPLY(argFn,[x])
219        atom u and [u] or u
220      typ := sublisFormal(args,atype)
221      if x is ['QUOTE,a] then x := a
222      u := mathform2HtString algCoerceInteractive(x,typ,'(OutputForm)) => [u]
223      NUMBERP x or STRINGP x => [x]
224      systemError()
225    keyword => [keyword,'": ",:res]
226    res
227  op = 'Mapping => dbMapping2StringList sargl
228  head :=
229    special => [op]
230    APPLY(opFn,[form])
231  [:head,'"(",:first sargl,:"append"/[[",",:y] for y in rest sargl],'")"]
232
233
234dbMapping2StringList [target,:sl] ==
235  null sl => target
236  restPart :=
237    null rest sl => nil
238    "append"/[[",",:y] for y in rest sl]
239  sourcePart :=
240    restPart => ['"(",:first sl,:restPart,'")"]
241    first sl
242  [:sourcePart,'" -> ",:target]
243
244dbOuttran form ==
245  if LISTP form then
246    [op,:args] := form
247  else
248    op := form
249    args := nil
250  cosig := rest GETDATABASE(op,'COSIG)
251  atypes := rest CDAR GETDATABASE(op,'CONSTRUCTORMODEMAP)
252  argl := [fn for x in args for atype in atypes for pred in cosig] where fn ==
253    pred => x
254    typ := sublisFormal(args,atype)
255    arg :=
256      x is ['QUOTE,a] => a
257      x
258    res := mathform2HtString algCoerceInteractive(arg,typ,'(OutputForm))
259    NUMBERP res or STRINGP res => res
260    ['QUOTE,res]
261  [op,:argl]
262
263dbConformGen form == dbConformGen1(form,true)
264--many buttons: one for the type and one for each inner type
265--NOTE: must only be called on types KNOWN to be correct
266
267dbConformGenUnder form == dbConformGen1(form,false)
268--same as above, except buttons only for the inner types
269
270dbConformGen1(form,opButton?) ==
271  opFunction :=
272    opButton? => FUNCTION dbConform
273    FUNCTION conname2StringList
274  originalOp := opOf form
275  op := unAbbreviateIfNecessary opOf form
276  args := IFCDR form
277  form :=
278    originalOp=op => form
279    [op, :args]
280  args => conform2StringList(form, opFunction, FUNCTION dbConformGen)
281  APPLY(opFunction,[form])
282
283unAbbreviateIfNecessary op == IFCAR HGET($lowerCaseConTb, op) or op
284
285conname2StringList form == [PNAME unAbbreviateIfNecessary opOf form]
286
287--===========================================================================
288--               Data Gathering Code
289--============================================================================
290dbGatherData(htPage,opAlist,which,key) ==
291  which ~= '"operation" => BREAK()
292  key = 'implementation => dbGatherDataImplementation(htPage,opAlist)
293  dataFunction := LASSOC(key,table) where
294    table ==
295      $dbDataFunctionAlist or
296        ($dbDataFunctionAlist := [
297          ['signatures,:function dbMakeSignature],
298            ['parameters,:function dbContrivedForm],
299              ['origins,:function dbGetOrigin],
300                ['domains,:function dbGetOrigin],
301                  ['conditions,:function dbGetCondition]])
302  null dataFunction =>
303    --key= names or filter or documentation; do not expand
304    if $exposedOnlyIfTrue and not dbFromConstructor?(htPage) then
305      opAlist := --to get indexing correct
306         which = '"operation" => htpProperty(htPage,'opAlist)
307         htpProperty(htPage,'attrAlist)
308    acc := nil
309    initialExposure :=
310      htPage and htpProperty(htPage,'conform) and which ~= '"package operation"
311        => true
312      --never star ops from a constructor
313      nil
314    for [op,:alist] in opAlist repeat
315      exposureFlag := initialExposure
316      while alist repeat
317        item := first alist
318        isExposed? :=
319          STRINGP item => dbExposed?(item,char 'o)   --unexpanded case
320          null (r := rest rest item) => true      --assume true if unexpanded
321          r . 1                                   --expanded case
322        if isExposed? then return (exposureFlag := true)
323        alist := rest alist
324      node :=
325        exposureFlag => op
326        [op,nil]
327      acc := [node,:acc]
328    NREVERSE acc
329  data := nil
330  dbExpandOpAlistIfNecessary(htPage,opAlist,which,key in '(origins documentation),false)
331  --create data, a list of the form ((entry,exposeFlag,:entries)...)
332  for [op,:alist] in opAlist repeat
333    for item in alist repeat
334      entry := FUNCALL(dataFunction,op,item)--get key item
335      exposeFlag :=                         --is the current op-sig exposed?
336        null (r := rest rest item) => true  --not given, assume yes
337        r . 1                               --is  given, use value
338      tail :=
339        item is [.,'ASCONST,:.] => 'ASCONST
340        nil
341      newEntry :=
342        u := assoc(entry,data) =>           --key seen before? look on DATA
343          RPLACA(rest u, CADR u or exposeFlag)--yes, expose if any 1 is exposed
344          u
345        data := [y := [entry,exposeFlag,:tail],:data]
346        y                                   --no, create new entry in DATA
347      if member(key,'(origins conditions)) then
348        r := CDDR newEntry
349        if atom r then r := nil             --clear out possible 'ASCONST
350        RPLACD(rest newEntry,             --store op/sigs under key if needed
351          insert([dbMakeSignature(op,item),exposeFlag,:tail],r))
352  if member(key,'(origins conditions)) then
353    for entry in data repeat   --sort list of entries (after the 2nd)
354      tail := CDDR entry
355      tail :=
356        atom tail => tail
357        listSort(function LEXLESSEQP,tail)
358      RPLACD(rest entry, tail)
359  data := listSort(function LEXLESSEQP,data)
360  data
361
362dbGatherDataImplementation(htPage,opAlist) ==
363--returns data, of form ((implementor exposed? entry entry...)...
364--  where entry has form ((op sig . implementor) . stuff)
365  conform := htpProperty(htPage,'conform)
366  domainForm  := htpProperty(htPage,'domname)
367  dom     := EVAL domainForm
368  which   := '"operation"
369  [nam, :.] := domainForm
370  $predicateList: local := GETDATABASE(nam,'PREDICATES)
371  predVector := dom.3
372  u := getDomainOpTable2(dom, true, ASSOCLEFT opAlist)
373  --u has form ((op,sig,:implementor)...)
374  --sort into 4 groups: domain exports, unexports, default exports, others
375
376  for (x := [.,.,:key]) in u for i in 0.. repeat
377    key = domainForm => domexports := [x,:domexports]
378    INTEGERP key => unexports := [x,:unexports]
379    isDefaultPackageForm? key => defexports := [x,:defexports]
380    key = 'nowhere => nowheres := [x,:nowheres]
381    key = 'constant =>constants := [x,:constants]
382    others := [x,:others]   --add chain domains go here
383  fn [nowheres,constants,domexports,SORTBY('CDDR,NREVERSE others),SORTBY('CDDR,
384               NREVERSE defexports),SORTBY('CDDR,NREVERSE unexports)] where
385    fn l ==
386      alist := nil
387      for u in l repeat
388        while u repeat
389          key := CDDAR u  --implementor
390          entries :=
391            [[first u, true],
392             :[u and [first u, true] while key = CDDAR(u := rest u)]]
393          alist := [[key,gn key,:entries],:alist]
394      NREVERSE alist
395    gn key ==
396      atom key => true
397      isExposedConstructor first key
398
399dbSelectData(htPage,opAlist,key) ==
400  branch := htpProperty(htPage,'branch)
401  data   := htpProperty(htPage,'data)
402  MEMQ(branch,'(signatures parameters)) =>
403    dbReduceOpAlist(opAlist,data.key,branch)
404  MEMQ(branch,'(origins conditions implementation)) =>
405    key < 8192 => dbReduceOpAlist(opAlist,data.key,branch)
406    [newkey,binkey] := DIVIDE(key,8192)  --newkey is 1 too large
407    innerData := CDDR data.(newkey - 1)
408    dbReduceOpAlist(opAlist,innerData.binkey,'signatures)
409  [opAlist . key]
410
411dbReduceOpAlist(opAlist,data,branch) ==
412  branch = 'signatures => dbReduceBySignature(opAlist,CAAR data,CADAR data)
413  branch = 'origins => dbReduceBySelection(opAlist, first data, function CADDR)
414  branch = 'conditions =>
415      dbReduceBySelection(opAlist, first data, function CADR)
416  branch = 'implementation => dbReduceByOpSignature(opAlist,CDDR data)
417  branch = 'parameters => dbReduceByForm(opAlist, first data)
418  systemError ['"Unexpected branch: ",branch]
419
420dbReduceByOpSignature(opAlist,datalist) ==
421--reduces opAlist by implementation datalist, one of the form
422--    (((op,sig,:implementor),:stuff),...)
423  ops := [CAAR x for x in datalist] --x is [[op,sig,:implementor],:.]
424  acc := nil
425  for [op,:alist] in opAlist | MEMQ(op,ops) repeat
426    entryList := [entry for (entry := [sig,:.]) in alist | test] where test ==
427      or/[x for x in datalist | x is [[=op,=sig,:.],:.]]
428    entryList => acc := [[op,:NREVERSE entryList],:acc]
429  NREVERSE acc
430
431dbReduceBySignature(opAlist,op,sig) ==
432--reduces opAlist to one with a fixed op and sig
433  [[op,:[x for x in LASSOC(op,opAlist) | x is [=sig,:.]]]]
434
435dbReduceByForm(opAlist,form) ==
436  acc := nil
437  for [op,:alist] in opAlist repeat
438    items := [x for x in alist | dbContrivedForm(op,x) = form] =>
439      acc := [[op,:items],:acc]
440  NREVERSE acc
441
442dbReduceBySelection(opAlist,key,fn) ==
443  acc := nil
444  for [op,:alist] in opAlist repeat
445    items := [x for x in alist | FUNCALL(fn,x) = key] =>
446      acc := [[op,:items],:acc]
447  NREVERSE acc
448
449dbContrivedForm(op,[sig,:.]) ==
450  dbMakeContrivedForm(op,sig)
451
452dbMakeSignature(op,[sig,:.]) == [op,sig]  --getDomainOpTable format
453
454dbGetOrigin(op,[.,.,origin,:.]) == origin
455
456dbGetCondition(op,[.,pred,:.]) == pred
457
458--============================================================================
459--               Branches of Views
460--============================================================================
461dbShowOpNames(htPage,opAlist,which,data) ==
462  single? := opAlist and null rest data
463  single? =>
464    ops := escapeSpecialChars STRINGIMAGE CAAR opAlist
465    htSayStandard('"Select a view below")
466  exposedOnly? := $exposedOnlyIfTrue and not dbFromConstructor?(htPage)
467  dbShowOpItems(which,data,exposedOnly?)
468
469dbShowOpItems(which,data,exposedOnly?) ==
470  htBeginTable()
471  for i in 0.. for item in data repeat
472    if atom item then
473      op := item
474      exposeFlag := true
475    else
476      [op,exposeFlag] := item
477    ops := escapeSpecialChars STRINGIMAGE op
478    exposeFlag or not exposedOnly? =>
479      htSay('"{")
480      bcStarSpaceOp(ops,exposeFlag)
481      htMakePage [['bcLinks,[ops,'"",'dbShowOps,which,i]]]
482      htSay('"}")
483  htEndTable()
484
485dbShowOpAllDomains(htPage,opAlist,which) ==
486  SAY("dbShowOpAllDomains")
487  BREAK()
488  dbExpandOpAlistIfNecessary(htPage,opAlist,which,true,false)
489  catOriginAlist := nil --list of category origins
490  domOriginAlist := nil --list of domain origins
491  for [op,:items] in opAlist repeat
492    for [.,predicate,origin,:.] in items repeat
493      conname := first origin
494      GETDATABASE(conname,'CONSTRUCTORKIND) = 'category =>
495        pred := simpOrDumb(predicate, QLASSQ(conname, catOriginAlist) or true)
496        catOriginAlist := insertAlist(conname,pred,catOriginAlist)
497      pred := simpOrDumb(predicate, QLASSQ(conname, domOriginAlist) or true)
498      domOriginAlist := insertAlist(conname,pred,domOriginAlist)
499  --the following is similar to "domainsOf" but do not sort immediately
500  u := [COPY key for key in HKEYS($has_category_hash)
501          | QLASSQ(rest key, catOriginAlist)]
502  for pair in u repeat
503    [dom,:cat] := pair
504    QLASSQ(cat, catOriginAlist) = 'etc => RPLACD(pair, 'etc)
505    RPLACD(pair,simpOrDumb(GETDATABASE(pair,'HASCATEGORY),true))
506  --now add all of the domains
507  for [dom,:pred] in domOriginAlist repeat
508    u := insertAlist(dom, simpOrDumb(pred, QLASSQ(dom, u) or true), u)
509  cAlist := listSort(function GLESSEQP,u)
510  for pair in cAlist repeat RPLACA(pair,getConstructorForm first pair)
511  htpSetProperty(htPage,'cAlist,cAlist)
512  htpSetProperty(htPage,'thing,'"constructor")
513  htpSetProperty(htPage,'specialHeading,'"hoho")
514  dbShowCons(htPage,'names)
515
516simpOrDumb(new,old) ==
517  new = 'etc => 'etc
518  atom new => old
519  'etc
520
521dbShowOpOrigins(htPage,opAlist,which,data) ==
522  dbGatherThenShow(htPage,opAlist,which,data,true,'"from",function bcStarConform)
523
524dbShowOpImplementations(htPage,opAlist,which,data) ==
525    $from_show_implementations : local := true
526    dbGatherThenShow(htPage, opAlist, which, data, true, '"by",
527                     function bcStarConform)
528
529dbShowOpConditions(htPage,opAlist,which,data) ==
530  dbGatherThenShow(htPage,opAlist,which,data,nil,nil,function bcPred)
531
532dbShowKind conform ==
533  conname := first conform
534  kind := GETDATABASE(conname,'CONSTRUCTORKIND)
535  kind = 'domain =>
536    (s := PNAME conname).(MAXINDEX s) = '_& => '"default package"
537    '"domain"
538  PNAME kind
539
540dbShowOpSignatures(htPage,opAlist,which,data) == dbShowOpSigList(which,data,0)
541
542dbShowOpSigList(which,dataItems,count) ==
543--dataItems is (((op,sig,:.),exposureFlag,...)
544  which ~= '"operation" => BREAK()
545  single? := null rest dataItems
546  htBeginTable()
547  for [[op,sig,:.],exposureFlag,:tail] in dataItems repeat
548    ops := escapeSpecialChars STRINGIMAGE op
549    htSay '"{"
550    htSayExpose(ops,exposureFlag)
551    htMakePage [['bcLinks,[ops,'"",'dbShowOps,which,count]]]
552    htSay '": "
553    if tail = 'ASCONST then
554        bcConform(first(sig))
555    else
556        bcConform(['Mapping, :sig])
557    htSay '"}"
558    count := count + 1
559  htEndTable()
560  count
561
562dbShowOpParameters(htPage,opAlist,which,data) ==
563  single? := null rest data
564  count := 0
565  htBeginTable()
566  for item in data repeat
567    [opform,exposeFlag,:tail] := item
568    op := intern IFCAR opform
569    args := IFCDR opform
570    ops := escapeSpecialChars STRINGIMAGE op
571    htSay '"{"
572    htSayExpose(ops,exposeFlag)
573    n := #opform
574    do
575      n = 2 and GETL(op, 'Nud) =>
576        dbShowOpParameterJump(ops,which,count,single?)
577        htSayList(['" {\em ", IFCAR args, '"}"])
578      n = 3 and GETL(op, 'Led) =>
579        htSayList(['"{\em ", IFCAR args, '"} "])
580        dbShowOpParameterJump(ops,which,count,single?)
581        htSayList(['" {\em ", IFCAR IFCDR args, '"}"])
582      dbShowOpParameterJump(ops,which,count,single?)
583      which = '"attribute" => BREAK()
584      tail = 'ASCONST or member(op,'(0 1)) => 'skip
585      htSay('"(")
586      if IFCAR args then htSayList(['"{\em ", IFCAR args, '"}"])
587      for x in IFCDR args repeat
588        htSayList(['", {\em ", x, '"}"])
589      htSay('")")
590    htSay '"}"
591    count := count + 1
592  htEndTable()
593
594dbShowOpParameterJump(ops,which,count,single?) ==
595  single? => htSayList(['"{\em ", ops, '"}"])
596  htMakePage [['bcLinks,[ops,'"",'dbShowOps,which,count]]]
597
598dbShowOpDocumentation(htPage,opAlist,which,data) ==
599  which ~= '"operation" => BREAK()
600  if $exposedOnlyIfTrue and not dbFromConstructor?(htPage) then
601      opAlist := htpProperty(htPage, 'opAlist)
602  conform := htpProperty(htPage, 'domname) or htpProperty(htPage, 'conform)
603  expand := dbExpandOpAlistIfNecessary(htPage,opAlist,which,true,false)
604  if expand then
605    condata := dbGatherData(htPage,opAlist,which,'conditions)
606    htpSetProperty(htPage,'conditionData,condata)
607  base := -8192
608  exactlyOneOpSig := opAlist is [[.,.]] --checked by displayDomainOp
609  for [op,:alist] in opAlist repeat
610    base := 8192 + base
611    for item in alist for j in 0.. repeat
612      [sig,predicate,origin,exposeFlag,comments] := item
613      exposeFlag or not $exposedOnlyIfTrue =>
614        if comments ~= '"" and STRINGP comments and (k := string2Integer comments) then
615          comments :=
616            MEMQ(k,'(0 1)) => '""
617            dbReadComments k
618          tail := CDDDDR item
619          RPLACA(tail,comments)
620        doc := (STRINGP comments and comments ~= '"" => comments; nil)
621        pred := predicate or true
622        index := (exactlyOneOpSig => nil; base + j)
623        displayDomainOp(htPage, '"operation", origin, op, sig, pred,
624                        doc, index, 'dbChooseDomainOp, null(exposeFlag), true)
625
626dbChooseDomainOp(htPage,which,index) ==
627  which ~= '"operation" => BREAK()
628  [opKey,entryKey] := DIVIDE(index,8192)
629  opAlist :=
630    which = '"operation" => htpProperty(htPage,'opAlist)
631    htpProperty(htPage,'attrAlist)
632  [op,:entries] := opAlist . opKey
633  entry := entries . entryKey
634  htPage := htInitPageNoHeading(htCopyProplist(htPage))
635  if which = '"operation"
636    then htpSetProperty(htPage,'opAlist,[[op,entry]])
637    else htpSetProperty(htPage,'attrAlist,[[op,entry]])
638  if not (htpProperty(htPage, 'condition?) = 'no) then
639    dbResetOpAlistCondition(htPage,which,opAlist)
640  dbShowOps(htPage,which,'documentation)
641
642htSayExpose(op, flag) ==
643  $includeUnexposed? =>
644    flag => htBlank()
645    op.0 = char '_* => htSay '"{\em *} "
646    htSayUnexposed()
647  htSay '""
648--============================================================================
649--               Branch-in From Other Places
650--============================================================================
651dbShowOperationsFromConform(htPage,which,opAlist) ==  --branch in with lists
652  which ~= '"operation" => BREAK()
653  $groupChoice := nil
654  conform := htpProperty(htPage,'conform)
655  --prepare opAlist for possible filtering of groups
656  if null BOUNDP '$topicHash then
657    $topicHash := MAKE_HASHTABLE('ID)
658    for [x,:c] in '((extended . 0) (basic . 1) (hidden . 2)) repeat
659      HPUT($topicHash,x,c)
660  domform := htpProperty(htPage,'domname)
661  if htpProperty(htPage, 'kind) = '"category" then
662      domform := false
663  if domform then
664    $conformsAreDomains : local := true
665    opAlist := reduceOpAlistForDomain(opAlist, domform, conform)
666  conform := domform or conform
667  kind := capitalize htpProperty(htPage,'kind)
668  exposePart :=
669    isExposedConstructor opOf conform => '""
670    '" Unexposed "
671  fromPart :=
672    domform => evalableConstructor2HtString domform
673    form2HtString conform
674  heading :=
675    ['" from ",exposePart,kind,'" {\em ",fromPart,'"}"]
676  htpSetProperty(htPage, 'expandOperations, 'lists)
677  htpSetProperty(htPage,'fromHeading,heading)
678  reducedOpAlist := reduceByGroup(htPage, opAlist)
679  htpSetProperty(htPage, 'principalOpAlist, opAlist)
680  htpSetProperty(htPage, 'opAlist, reducedOpAlist)
681  if domform
682   then htpSetProperty(htPage,'condition?,'no)
683   else dbResetOpAlistCondition(htPage,which,opAlist)
684  dbShowOp1(htPage,reducedOpAlist,which,'names)
685
686reduceOpAlistForDomain(opAlist,domform,conform) ==
687--destructively simplify all predicates; filter out any that fail
688  form1 := [domform,:rest domform]
689  form2 := ['$,:rest conform]
690  new_opAlist := []
691  for pair in opAlist repeat
692    n_items := [test for item in rest pair | test] where test ==
693      [head,:tail] := item
694      first tail = true => item
695      pred := simpHasPred SUBLISLIS(form1,form2,QCAR tail)
696      null pred => false
697      RPLACD(item,[pred])
698      item
699    if not(null(n_items)) then
700        n_pair := cons(first(pair), n_items)
701        new_opAlist := cons(n_pair, new_opAlist)
702  NREVERSE(new_opAlist)
703
704dbShowOperationLines(which,linelist) ==  --branch in with lines
705  which ~= '"operation" => BREAK()
706  htPage := htInitPage(nil,nil)  --create empty page
707  opAlist := nil
708  lines := linelist
709  while lines repeat
710    name := dbName (x := first lines)
711    pile := [x]
712    while (lines := rest lines) and name = dbName (x := first lines) repeat
713      pile := [x,:pile]
714    opAlist := [[name,:NREVERSE pile],:opAlist]
715  -- sorting list of pairs (String, List(String))
716  opAlist := listSort(function LEXLESSEQP,NREVERSE opAlist)
717  if which = '"operation"
718    then htpSetProperty(htPage,'opAlist,opAlist)
719    else htpSetProperty(htPage,'attrAlist,opAlist)
720  expandProperty :=
721    which = '"operation" => 'expandOperations
722    'expandAttributes
723  htpSetProperty(htPage,expandProperty,'strings)
724  dbResetOpAlistCondition(htPage,which,opAlist)
725  if which = '"attribute" then BREAK()
726  dbShowOp1(htPage,opAlist,which,'names)
727
728--============================================================================
729--                Code to Expand opAlist
730--============================================================================
731dbResetOpAlistCondition(htPage,which,opAlist) ==
732  which ~= '"operation" => BREAK()
733  value := dbExpandOpAlistIfNecessary(htPage,opAlist,which,false,true)
734  htpSetProperty(htPage,'condition?,(value => 'yes; 'no))
735  value
736
737dbExpandOpAlistIfNecessary(htPage,opAlist,which,needOrigins?,condition?) ==
738--if condition? = true, stop when you find a non-trivial predicate
739--otherwise, expand in full
740--RETURNS:
741--  non-trivial predicate, if condition? = true and it finds one
742--  nil,                   otherwise
743--SIDE-EFFECT: this function references the "expand" property (set elsewhere):
744--  'strings, if not fully expanded and it contains strings
745--            i.e. opAlist is ((op . (string ...))...) if unexpanded
746--  'lists,   if not fully expanded and it contains lists
747--            i.e. opAlist is ((op . ((sig pred) ...))...) if unexpanded
748    which ~= '"operation" => BREAK()
749    condition? := condition? and not $exposedOnlyIfTrue
750    value      := nil  --return value
751    expandProperty :=
752      which = '"operation" => 'expandOperations
753      'expandAttributes
754    expandFlag := htpProperty(htPage,expandProperty)
755    expandFlag = 'fullyExpanded => nil
756    expandFlag = 'strings => --strings are partially expanded
757      for pair in opAlist repeat
758        [op,:lines] := pair
759        acc := nil
760        for line in lines repeat
761        --NOTE: we must expand all lines here for a given op
762        --      since below we will change opAlist
763        --Case 1: Already expanded; just cons it onto ACC
764          null STRINGP line => --already expanded
765            if condition? then --this could have been expanded at a lower level
766              if null atom (pred := CADR line) then value := pred
767            acc := [line,:acc] --this one is already expanded; record it anyway
768        --Case 2: unexpanded; expand it then cons it onto ACC
769          [name,nargs,xflag,sigs,conname,pred,comments] := dbParts(line,7,1)
770          predicate := ncParseFromString pred
771          if condition? and null atom predicate then value := predicate
772          sig := ncParseFromString sigs --is (Mapping,:.)
773          if which = '"operation" then
774            if sig isnt ['Mapping,:.]
775            then sayBrightly ['"Unexpected signature for ",name,'": ",sigs]
776            else sig := rest sig
777          conname := intern dbNewConname line
778          origin := [conname,:getConstructorArgs conname]
779          exposeFlag := dbExposed?(line,char 'o)
780          acc := [[sig,predicate,origin,exposeFlag,comments],:acc]
781        --always store the fruits of our labor:
782        RPLACD(pair,NREVERSE acc)             --at least partially expand it
783        condition? and value => return value  --early exit
784      value => value
785      condition? => nil
786      htpSetProperty(htPage,expandProperty,'fullyExpanded)
787    expandFlag = 'lists => --lists are partially expanded
788      -- entry is [sig, predicate, origin, exposeFlag, comments]
789      $value: local := nil
790      $docTableHash := MAKE_HASHTABLE('EQUAL)
791      packageSymbol := false
792      domform := htpProperty(htPage,'domname) or htpProperty(htPage,'conform)
793      if isDefaultPackageName opOf domform then
794         catname := intern SUBSTRING(s := PNAME opOf domform,0,MAXINDEX s)
795         packageSymbol := first rest domform
796         domform := [catname,:rest rest domform]  --skip first argument ($)
797      docTable:= dbDocTable domform
798      for [op,:alist] in opAlist repeat
799        for [sig,:tail] in alist repeat
800          condition? => --the only purpose here is to find a non-trivial pred
801            null atom (pred := first tail) => return ($value := pred)
802            'skip
803          u :=
804            tail is [.,origin,:.] and origin =>
805--  must change any % into $ otherwise we will not pick up comments properly
806--  delete the SUBLISLIS when we fix on % or $
807              dbGetDocTable(op,SUBLISLIS(['$],['%],sig),dbDocTable origin,which,nil)
808            if packageSymbol then sig := substitute('_$, packageSymbol, sig)
809            dbGetDocTable(op,sig,docTable,which,nil)
810          origin := IFCAR u or origin
811          docCode := IFCDR u   --> (doc . code)
812          which = '"attribute" => BREAK()
813          RPLACD(tail,[origin,isExposedConstructor opOf origin,:docCode])
814        $value => return $value
815      $value => $value
816      condition? => nil
817      htpSetProperty(htPage,expandProperty,'fullyExpanded)
818    'done
819
820getRegistry(op,sig) ==
821  u := GETDATABASE('AttributeRegistry,'DOCUMENTATION)
822  v := LASSOC(op,u)
823  match := or/[y for y in v | y is [['attribute,: =sig],:.]] => CADR match
824  '""
825
826evalableConstructor2HtString domform ==
827  if VECP domform then domform := devaluate domform
828  conname := first domform
829  coSig   := rest GETDATABASE(conname,'COSIG)
830  --entries are T for arguments which are domains; NIL for computational objects
831  and/[x for x in coSig] => form2HtString(domform,nil,true)
832  arglist := [unquote x for x in rest domform] where
833    unquote arg  ==
834      arg is [f,:args] =>
835        f = 'QUOTE => first args
836        [f,:[unquote x for x in args]]
837      arg
838  fargtypes:=CDDAR GETDATABASE(conname,'CONSTRUCTORMODEMAP)
839--argtypes:= sublisFormal(arglist,fargtypes)
840  form2HtString([conname,:[fn for arg in arglist for x in coSig
841                   for ftype in fargtypes]],nil,true) where
842    fn ==
843      x => arg
844      typ := sublisFormal(arglist,ftype)
845      mathform2HtString algCoerceInteractive(arg,typ,'(OutputForm))
846
847fortexp0 x ==
848  e_to_f := getFunctionFromDomain("expression2Fortran", ['FortranCodeTools],
849                                 [$OutputForm])
850  f := SPADCALL(x, e_to_f)
851  p := position('"%l",f)
852  p < 0 => f
853  l := NIL
854  while p < 0 repeat
855    [t,:f] := f
856    l := [t,:l]
857  NREVERSE ['"...",:l]
858
859mathform2HtString form == escapeString
860  form is ['QUOTE,a] => STRCONC('"'","STRCONC"/fortexp0 a)
861  form is ['BRACKET,['AGGLST,:arg]] =>
862    if arg is ['construct,:r] then arg := r
863    arg :=
864      atom arg => [arg]
865      [y for x in arg | y := (x is ['QUOTE,a] => a; x)]
866    tailPart := "STRCONC"/[STRCONC('",",STRINGIMAGE x) for x in rest arg]
867    STRCONC('"[",STRINGIMAGE first arg,tailPart,'"]")
868  form is ['BRACKET,['AGGLST,'QUOTE,arg]] =>
869    if atom arg then arg := [arg]
870    tailPart := "STRCONC"/[STRCONC('",",x) for x in rest arg]
871    STRCONC('"[",first arg,tailPart,'"]")
872  atom form => form
873  "STRCONC"/fortexp0 form
874
875--============================================================================
876--                Getting Operations from Domain
877--============================================================================
878
879getDomainOpTable(dom, fromIfTrue) == getDomainOpTable2(dom, fromIfTrue, [])
880
881getDomainOpTable2(dom, fromIfTrue, ops) ==
882  $predEvalAlist : local := nil
883  $returnNowhereFromGoGet: local := true
884  domname := dom.0
885  conname := first domname
886  abb := getConstructorAbbreviation conname
887  opAlist := getOperationAlistFromLisplib conname
888  "append"/[REMDUP [[op1,:fn] for [sig,slot,pred,key,:.] in u
889              | ((null ops and (op1 := op)) or (op1 := memq(op, ops)))]
890                 for [op,:u] in opAlist] where
891    memq(op,ops) ==   --dirty trick to get 0 and 1 instead of Zero and One
892      MEMQ(op,ops) => op
893      EQ(op,'One)  => MEMQ(1,ops) and 1
894      EQ(op,'Zero) => MEMQ(0,ops) and 0
895      false
896    fn ==
897      sig1 := sublisFormal(rest domname,sig)
898      predValue := evalDomainOpPred(dom,pred)
899      info :=
900        null predValue =>
901          1   -- signifies not exported
902        null fromIfTrue => nil
903        cell := compiledLookup(op,sig1,dom) =>
904          [f,:r] := cell
905          f = 'nowhere => 'nowhere           --see replaceGoGetSlot
906          f = function makeSpadConstant => 'constant
907          f = function IDENTITY => 'constant
908          f = function newGoGet => substitute('_$, domname, devaluate first r)
909          null VECP r => systemError devaluateList r
910          substitute('_$, domname, devaluate r)
911        'nowhere
912      [sig1,:info]
913
914evalDomainOpPred2(dom, pred) ==
915    $predicateList : local := GETDATABASE(first(dom.0), 'PREDICATES)
916    evalDomainOpPred(dom,pred)
917
918evalDomainOpPred(dom,pred) == process(dom,pred) where
919  process(dom,pred) ==
920    u := convert(dom,pred)
921    u = 'T => true
922    evpred(dom,u)
923  convert(dom,pred) ==
924    pred is [op,:argl] =>
925      MEMQ(op,'(AND and)) => ['AND,:[convert(dom,x) for x in argl]]
926      MEMQ(op,'(OR or))   => ['OR,:[convert(dom,x) for x in argl]]
927      MEMQ(op,'(NOT not)) => ['NOT,convert(dom,first argl)]
928      op = 'has =>
929        [arg,p] := argl
930        p is ['ATTRIBUTE,a] => BREAK()
931        ['HasCategory,arg,convertCatArg p]
932      systemError '"unknown predicate form"
933    pred = 'T => true
934    systemError nil
935  convertCatArg p ==
936    atom p or #p = 1 => MKQ p
937    ['LIST,MKQ first p,:[convertCatArg x for x in rest p]]
938  evpred(dom,pred) ==
939    k := POSN1(pred,$predicateList) => testBitVector(dom.3,k + 1)
940    evpred1(dom,pred)
941  evpred1(dom,pred) ==
942    pred is [op,:argl] =>
943      MEMQ(op,'(AND and)) => "and"/[evpred1(dom,x) for x in argl]
944      MEMQ(op,'(OR or))   =>  "or"/[evpred1(dom,x) for x in argl]
945      op = 'NOT => not evpred1(dom,first argl)
946      k := POSN1(pred,$predicateList) => testBitVector(dom.3,k + 1)
947      op = 'HasAttribute => BREAK()
948      nil
949    pred = 'T => true
950    systemError '"unknown atomic predicate form"
951