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--% Functions for display formatting system objects
35
36--% Formatting modemaps
37
38sayModemap m ==
39  -- sayMSG formatModemap displayTranModemap m
40  sayMSG formatModemap old2NewModemaps displayTranModemap m
41
42sayModemapWithNumber(m,n) ==
43  msg := reverse cleanUpSegmentedMsg reverse ["%i","%i",'" ",
44    STRCONC(lbrkSch(),object2String n,rbrkSch()),
45      :formatModemap displayTranModemap m,"%u","%u"]
46  sayMSG flowSegmentedMsg(reverse msg,$LINELENGTH,3)
47
48displayOpModemaps(op,modemaps) ==
49  TERPRI()
50  count:= #modemaps
51  phrase:= (count=1 => 'modemap;'modemaps)
52  sayMSG ['%b,count,'%d,phrase,'" for",'%b,op,'%d,'":"]
53  for modemap in modemaps repeat sayModemap modemap
54
55displayTranModemap (mm is [[x,:sig],[pred,:y],:z]) ==
56  -- The next 8 lines are a HACK to deal with the "partial" definition
57  -- JHD/RSS
58  if pred is ['partial,:pred'] then
59    [b,:c]:=sig
60    sig:=[['Union,b,'"failed"],:c]
61    mm:=[[x,:sig],[pred',:y],:z]
62  else if pred = 'partial then
63    [b,:c]:=sig
64    sig:=[['Union,b,'"failed"],:c]
65    mm:=[[x,:sig],y,:z]
66  mm' := EQSUBSTLIST('(m n p q r s t i j k l),
67    MSORT listOfPredOfTypePatternIds pred,mm)
68  EQSUBSTLIST('(D D1 D2 D3 D4 D5 D6 D7 D8 D9 D10 D11 D12 D13 D14),
69    MSORT listOfPatternIds [sig,[pred,:y]],mm')
70
71listOfPredOfTypePatternIds p ==
72  p is ['AND,:lp] or p is ['OR,:lp] =>
73    UNIONQ([:listOfPredOfTypePatternIds p1 for p1 in lp],NIL)
74  p is [op,a,.] and op = 'ofType =>
75    isPatternVar a => [a]
76    nil
77  nil
78
79removeIsDomains pred ==
80  pred is ['isDomain,a,b] => true
81  pred is ['AND,:predl] =>
82    MKPF([x for x in predl | x isnt ['isDomain,:.]],'AND)
83  pred
84
85canRemoveIsDomain? pred ==
86  -- returns nil OR an alist for substitutions of domains ordered so that
87  -- after substituting for each pair in turn, no left-hand names remain
88  alist :=
89    pred is ['isDomain,a,b] => [[a,:b],:alist]
90    pred is ['AND,:predl] =>
91      [[a,:b] for pred in predl | pred is ['isDomain,a,b]]
92  findSubstitutionOrder? alist
93
94findSubstitutionOrder? alist == fn(alist,nil) where
95  -- returns NIL or an appropriate substitution order
96  fn(alist,res) ==
97    null alist => NREVERSE res
98    choice := or/[x for (x:=[a,:b]) in alist | null containedRight(a,alist)] =>
99      fn(delete(choice,alist),[choice,:res])
100    nil
101
102containedRight(x,alist)== or/[CONTAINED(x,y) for [.,:y] in alist]
103
104DEFPARAMETER($Dmarker, "<Dmarker>")
105
106removeIsDomainD pred ==
107  pred is ['isDomain, =$Dmarker, D] =>
108    [D,nil]
109  pred is ['AND,:preds] =>
110    D := nil
111    for p in preds while not D repeat
112      p is ['isDomain, =$Dmarker, D1] =>
113        D := D1
114        npreds := delete(['isDomain, $Dmarker, D1], preds)
115    D =>
116      1 = #npreds => [D,first npreds]
117      [D,['AND,:npreds]]
118    nil
119  nil
120
121formatModemap modemap ==
122  [[dc,target,:sl],pred,:.]:= modemap
123  if alist := canRemoveIsDomain? pred then
124    dc:= substInOrder(alist,dc)
125    pred:= substInOrder(alist,removeIsDomains pred)
126    target:= substInOrder(alist,target)
127    sl:= substInOrder(alist,sl)
128  else if removeIsDomainD pred is [D,npred] then
129    pred := SUBST(D, $Dmarker, npred)
130    target := SUBST(D, $Dmarker, target)
131    sl := SUBST(D, $Dmarker, sl)
132  predPart:= formatIf pred
133  targetPart:= prefix2String target
134  argTypeList:=
135    null sl => nil
136    concat(prefix2String first sl,fn(rest sl)) where
137      fn l ==
138        null l => nil
139        concat(",",prefix2String first l,fn rest l)
140  argPart:=
141    #sl<2 => argTypeList
142    ['"_(",:argTypeList,'"_)"]
143  fromPart:=
144    if dc = $Dmarker and D
145      then concat('%b,'"from",'%d,prefix2String D)
146      else concat('%b,'"from",'%d,prefix2String dc)
147  firstPart:= concat('" ",argPart,'" -> ",targetPart)
148  sayWidth firstPart + sayWidth fromPart > 74 => --allow 5 spaces for " [n]"
149    fromPart:= concat('" ",fromPart)
150    secondPart :=
151      sayWidth fromPart + sayWidth predPart < 75 =>
152        concat(fromPart,predPart)
153      concat(fromPart,'%l,predPart)
154    concat(firstPart,'%l,secondPart)
155  firstPart:= concat(firstPart,fromPart)
156  sayWidth firstPart + sayWidth predPart < 80 =>
157    concat(firstPart,predPart)
158  concat(firstPart,'%l,predPart)
159
160substInOrder(alist,x) ==
161  alist is [[a, :b], :y] => substInOrder(y, substitute(b, a, x))
162  x
163
164sayMms(op, mms, label) ==
165    m := # mms
166    sayMSG
167        m = 1 =>
168            ['"There is one", :bright label, '"function called",
169              :bright op, '":"]
170        ['"There are ", m, :bright label, '"functions called",
171            :bright op, '":"]
172    for mm in mms for i in 1.. repeat
173        sayModemapWithNumber(mm, i)
174
175reportOpSymbol op1 ==
176  op := (STRINGP op1 => INTERN op1; op1)
177  modemaps := getAllModemapsFromDatabase(op,nil)
178  null modemaps =>
179    ok := true
180    sayKeyedMsg("S2IF0010",[op1])
181    if SIZE PNAME op1 < 3 then
182      x := UPCASE queryUserKeyedMsg("S2IZ0060",[op1])
183      null MEMQ(STRING2ID_N(x, 1),'(Y YES)) =>
184        ok := nil
185        sayKeyedMsg("S2IZ0061",[op1])
186    ok => apropos [op1]
187  sayNewLine()
188  -- filter modemaps on whether they are exposed
189  mmsE := mmsU := NIL
190  for mm in modemaps repeat
191    isFreeFunctionFromMm(mm) or isExposedConstructor getDomainFromMm(mm) => mmsE := [mm,:mmsE]
192    mmsU := [mm,:mmsU]
193  if mmsE then
194    sayMms(op, mmsE, '"exposed")
195  if mmsU then
196    if mmsE then sayNewLine()
197    sayMms(op,mmsU,'"unexposed")
198  nil
199
200formatOpType (form:=[op,:argl]) ==
201  null argl => unabbrev op
202  form2String [unabbrev op, :argl]
203
204formatOperationAlistEntry (entry:= [op,:modemaps]) ==
205  -- alist has entries of the form: ((op sig) . pred)
206  -- opsig on this list => op is defined only when the predicate is true
207  ans:= nil
208  for [sig,.,:predtail] in modemaps repeat
209    pred := (predtail is [p,:.] => p; 'T)
210    -- operation is always defined
211    ans :=
212      [concat(formatOpSignature(op,sig),formatIf pred),:ans]
213  ans
214
215formatOperation([[op,sig],.,[fn,.,n]],domain) ==
216    formatOpSignature(op,sig)
217
218formatOperationWithPred([[op,sig],pred,.]) ==
219    concat(formatOpSignature(op, sig), formatIf pred)
220
221formatOpSignature(op,sig) ==
222  concat('%b,formatOpSymbol(op,sig),'%d,": ",formatSignature sig)
223
224formatOpConstant op ==
225  concat('%b,formatOpSymbol(op,'($)),'%d,'": constant")
226
227formatOpSymbol(op,sig) ==
228  if op = 'Zero then op := "0"
229  else if op = 'One then op := "1"
230  null sig => op
231  quad := specialChar 'quad
232  n := #sig
233  (op = 'elt) and (n = 3) =>
234    (CADR(sig) = '_$) =>
235      STRINGP (sel := CADDR(sig)) =>
236        [quad,".",sel]
237      [quad,".",quad]
238    op
239  STRINGP op or GETL(op,"Led") or GETL(op,"Nud") =>
240    n = 3 =>
241      if op = 'SEGMENT then op := '".."
242      op = "in" => [quad, '" ", op, '" ", quad]
243-- stop exquo from being displayed as infix (since it is not accepted
244-- as such by the interpreter)
245      op = 'exquo => op
246      [quad,op,quad]
247    n = 2 =>
248      not GETL(op,"Nud") => [quad,op]
249      [op,quad]
250    op
251  op
252
253dollarPercentTran x ==
254    -- Translate $ to %. We actually return %% so that the message
255    -- printer will display a single %
256    x is [y,:z] =>
257        y1 := dollarPercentTran y
258        z1 := dollarPercentTran z
259        EQ(y, y1) and EQ(z, z1) => x
260        [y1, :z1]
261    x = "$" or x = '"$" => "%%"
262    x
263
264formatSignature sig ==
265  formatSignature0 sig
266
267formatSignatureArgs sml ==
268  formatSignatureArgs0 sml
269
270formatSignature0 sig ==
271  null sig => "() -> ()"
272  INTEGERP sig => '"hashcode"
273  [tm,:sml] := sig
274  sourcePart:= formatSignatureArgs0 sml
275  targetPart:= prefix2String0 tm
276  dollarPercentTran concat(sourcePart,concat(" -> ",targetPart))
277
278formatSignatureArgs0(sml) ==
279-- formats the arguments of a signature
280  null sml => ["_(_)"]
281  null rest sml => prefix2String0 first sml
282  argList:= prefix2String0 first sml
283  for m in rest sml repeat
284    argList:= concat(argList,concat(", ",prefix2String0 m))
285  concat("_(",concat(argList,"_)"))
286
287--% Conversions to string form
288
289expr2String x ==
290  atom (u:= prefix2String0 x) => u
291  "STRCONC"/[atom2String y for y in u]
292
293prefix2String form ==
294  form2StringLocal form
295
296-- local version
297prefix2String0 form ==
298  form2StringLocal form
299
300form2StringWithWhere u ==
301  $permitWhere : local := true
302  $whereList: local := nil
303  s:= form2String u
304  $whereList => concat(s,'%b,'"where",'%d,"%i",$whereList,"%u")
305  s
306
307form2StringWithPrens form ==
308  null (argl := rest form) => [first form]
309  null rest argl => [first form,"(",first argl,")"]
310  form2String form
311
312formString u ==
313  x := form2String u
314  atom x => STRINGIMAGE x
315  "STRCONC"/[STRINGIMAGE y for y in x]
316
317DEFPARAMETER($from_unparse, false)
318
319unparseInputForm u ==
320  $InteractiveMode: local := false
321  $from_unparse : local := true
322  form2StringLocal u
323
324form2String u ==
325  form2StringLocal u
326
327form2StringLocal u ==
328  $NRTmonitorIfTrue : local := nil
329  form2String1 u
330
331constructorName con ==
332  $abbreviateTypes => abbreviate con
333  con
334
335DEFPARAMETER($justUnparseType, false)
336
337form2String1 u ==
338  ATOM u =>
339    u=$EmptyMode or u=$quadSymbol => formWrapId specialChar 'quad
340    IDENTP u =>
341      constructor? u => app2StringWrap(formWrapId u, [u])
342      u
343    SUBRP u => formWrapId BPINAME u
344    STRINGP u => formWrapId u
345    WRITE_-TO_-STRING formWrapId u
346  u1 := u
347  op := first u
348  argl := rest u
349  op='Join or op= 'mkCategory => formJoin1(op,argl)
350  $InteractiveMode and (u:= constructor? op) =>
351    null argl => app2StringWrap(formWrapId constructorName op, u1)
352    op = "NTuple"  => [ form2String1 first argl, "*"]
353    op = "Map"     => ["(",:formatSignature0 [argl.1,argl.0],")"]
354    op = 'Record => record2String(argl)
355    $justUnparseType or null(conSig := getConstructorSignature op) =>
356      application2String(constructorName op,[form2String1(a) for a in argl], u1)
357    ml := rest conSig
358    if not freeOfSharpVars ml then
359      ml:=SUBLIS([[pvar,:val] for pvar in $FormalMapVariableList
360        for val in argl], ml)
361    argl:= formArguments2String(argl,ml)
362      -- extra null check to handle mutable domain hack.
363    null argl => constructorName op
364    application2String(constructorName op,argl, u1)
365  op = "Mapping" => ["(",:formatSignature argl,")"]
366  op = "Record" => record2String(argl)
367  op = 'Union  =>
368    application2String(op,[form2String1 x for x in argl], u1)
369  op = ":" =>
370      null argl => [ '":" ]
371      null rest argl => [ '":", form2String1 first argl ]
372      formDecl2String(argl.0,argl.1)
373  op = "#" and PAIRP argl and LISTP first argl =>
374    STRINGIMAGE SIZE first argl
375  op = 'Join => formJoin2String argl
376  op = "ATTRIBUTE" => form2String1 first argl
377  op='Zero => 0
378  op='One => 1
379  op = 'AGGLST => tuple2String [form2String1 x for x in argl]
380  op = 'BRACKET =>
381    argl' := form2String1 first argl
382    ["[",:(atom argl' => [argl']; argl'),"]"]
383  op = 'SUB => sub_to_string(argl)
384  op = 'SUPERSUB => sub_to_string(argl)
385  op = "SIGNATURE" =>
386     [operation,sig] := argl
387     concat(operation,": ",formatSignature sig)
388  op = 'COLLECT => formCollect2String argl
389  op = 'construct =>
390    concat(lbrkSch(),
391           tuple2String [form2String1 x for x in argl],rbrkSch())
392  op = "MATRIX" => matrix2String argl
393  u1 is ["ROOT", arg1] =>
394     concat("sqrt(", appOrParen(arg1),")")
395  u1 is ["ROOT", arg1, arg2] =>
396     concat("nthRoot(", appOrParen(arg1),",",appOrParen(arg2),")")
397     --concat(appOrParen(arg1), '"^", appOrParen(["OVER",1,arg2]))
398  u1 is ["$elt", t, f] =>
399     concat(form2String1 f, '"$", form2String1 t)
400  #argl = 2 and (isBinaryInfix op or op = "::" or op = '"::"_
401     or op = "@" or op = '"@" or op = "pretend" or op = '"pretend"_
402     or op = "OVER" or op = '"OVER") =>
403          binop2String [op,:argl]
404  application2String(op,[form2String1 x for x in argl], u1)
405
406matrix2String x ==
407  concat(lbrkSch(),
408    tuple2String [outtranRow ri for ri in rest(x)],rbrkSch()) where
409      outtranRow x ==
410        concat(lbrkSch(),
411          tuple2String [form2String1 ei for ei in rest(x)], rbrkSch())
412
413binop2String x ==
414    $curExpr : local := x
415    x is ["=", arg1, arg2] or x is ['"=", arg1, arg2] =>
416        concat(sumOrParen(arg1), '"=", sumOrParen(arg2))
417    sumOrParen(x)
418
419sumOrParen(x) ==
420   x is [op, arg1, arg2] =>
421       op = "+" or op = '"+" =>
422           concat(sumOrParen(arg1), '"+", productOrParen(arg2))
423       op = "-" or op = '"-" =>
424           concat(sumOrParen(arg1), '"-", productOrParen(arg2))
425       op = "/" or op = '"/" or op = "OVER" or op = '"OVER" =>
426           concat(appOrParen(arg1), '"/", appOrParen(arg2))
427       productOrParen(x)
428   productOrParen(x)
429
430productOrParen(x) ==
431   x is [op, arg1, arg2] =>
432       op = "*" or op ='"*" =>
433           concat(productOrParen(arg1), '"*",  powerOrParen(arg2))
434       powerOrParen(x)
435   powerOrParen(x)
436
437powerOrParen(x) ==
438   x is [op, arg1, arg2] =>
439      op = "**" or op = '"**" or op = "^" or op = '"^"  =>
440           concat(coerceOrParen(arg1), '"^", coerceOrParen(arg2))
441      coerceOrParen(x)
442   coerceOrParen(x)
443
444coerceOrParen(x) ==
445   x is [op, arg1, arg2] =>
446      op = "::" or op = '"::" =>
447           concat(coerceOrParen(arg1), '"::", appOrParen(arg2))
448      op = "@" or op = '"@" =>
449           concat(coerceOrParen(arg1), '"@", appOrParen(arg2))
450      op = "pretend" or op = '"pretend" =>
451           concat(coerceOrParen(arg1), '" ", '"pretend", '" ",_
452                   appOrParen(arg2))
453      appOrParen(x)
454   appOrParen(x)
455
456appOrParen(x) ==
457   SYMBOLP(x) => formWrapId x
458   INTEGERP(x) =>
459       x >=0 => WRITE_-TO_-STRING x
460       concat('"(",WRITE_-TO_-STRING x,'")")
461   -- Kludge to avoid extra parentheses printing a SparseUnivariatePolynomial
462   x = '"?" => formWrapId x
463   ATOM(x) => concat('"(", form2String1(x), '")")
464   [op, :argl] := x
465   (op = "-" or op = '"-") and #argl = 1 =>
466       concat('"(", '"-", appOrParen(first argl), '")")
467   EQ(x, $curExpr) => BREAK()
468   op is ["$elt", f, t] =>
469       form2String1 x
470   -- Put parenthesis around anything special
471   not(SYMBOLP op) or GET(op, "Led") or GET(op, "Nud")_
472     or op= 'mkCategory or op = "SEGMENT" _
473     or op = 'construct or op = 'COLLECT or op = "SIGNATURE"_
474     or op = 'BRACKET or op = 'AGGLST or op = "ATTRIBUTE"_
475     or op = "#" =>
476        concat('"(", form2String1(x), '")")
477   op = "Zero" => '"0"
478   op = "One" => '"1"
479   form2String1 x
480
481
482formWrapId id == id
483
484formArguments2String(argl,ml) == [fn(x,m) for x in argl for m in ml] where
485  fn(x,m) ==
486    x=$EmptyMode or x=$quadSymbol => specialChar 'quad
487    STRINGP(x) or IDENTP(x) => x
488    x is [ ='_:,:.] => form2String1 x
489    x is ["QUOTE", y] =>
490        m = $Symbol and SYMBOLP(y) => y
491        form2String1 x
492    isValidType(m) and PAIRP(m) and
493      (GETDATABASE(first(m),'CONSTRUCTORKIND) = 'domain) =>
494        (x' := coerceInteractive(objNewWrap(x,m),$OutputForm)) =>
495          form2String1 objValUnwrap x'
496        form2String1 x
497    form2String1 x
498
499formDecl2String(left,right) ==
500  $declVar: local := left
501  whereBefore := $whereList
502  ls:= form2StringLocal left
503  rs:= form2StringLocal right
504  $whereList ~= whereBefore and $permitWhere => ls
505  concat(form2StringLocal ls,'": ",rs)
506
507formJoin1(op,u) ==
508  if op = 'Join then [:argl,last] := u else (argl := nil; last := [op,:u])
509  last is [id, :r] and id in '(mkCategory CATEGORY) =>
510    if id = "CATEGORY" then r := rest(r)
511    $abbreviateJoin = true => concat(formJoin2 argl,'%b,'"with",'%d,'"...")
512    $permitWhere = true =>
513      opList:= formatJoinKey(r,id)
514      $whereList:= concat($whereList,"%l",$declVar,": ",
515        formJoin2 argl,'%b,'"with",'%d,"%i",opList,"%u")
516      formJoin2 argl
517    opList:= formatJoinKey(r,id)
518    suffix := concat('%b,'"with",'%d,"%i",opList,"%u")
519    concat(formJoin2 argl,suffix)
520  formJoin2 u
521
522formatJoinKey(r,key) ==
523  key = 'mkCategory =>
524    r is [opPart,catPart,:.] =>
525      opString :=
526        opPart is [='LIST,:u] =>
527          "append"/[concat("%l",formatOpSignature(op,sig),formatIf pred)
528            for [='QUOTE,[[op,sig],pred]] in u]
529        nil
530      catString :=
531        catPart is [='LIST,:u] =>
532          "append"/[concat("%l",'" ",form2StringLocal con,formatIf pred)
533            for [='QUOTE,[con,pred]] in u]
534        nil
535      concat(opString,catString)
536    '"?? unknown mkCategory format ??"
537  -- otherwise we have the CATEGORY form
538  "append"/[fn for x in r] where fn ==
539    x is ['SIGNATURE,op,sig] => concat("%l",formatOpSignature(op,sig))
540    x is ['ATTRIBUTE,a] => concat("%l",formatAttribute a)
541    x
542
543formJoin2 argl ==
544-- argl is a list of categories NOT containing a "with"
545  null argl => '""
546  1=#argl => form2StringLocal argl.0
547  application2String('Join,[form2StringLocal x for x in argl], NIL)
548
549formJoin2String (u:=[:argl,last]) ==
550  last is ["CATEGORY",.,:atsigList] =>
551    postString:= concat("_(",formTuple2String atsigList,"_)")
552    #argl=1 => concat(first argl,'" with ",postString)
553    concat(application2String('Join,argl, NIL)," with ",postString)
554  application2String('Join,u, NIL)
555
556sub_to_string(u) ==
557    [op, :argl] := u
558    fo := form2String1(op)
559    if atom(fo) then fo := [fo];
560    rargl := REVERSE(argl)
561    resl := []
562    for arg in rargl repeat
563        resl = [] and arg = [] => "iterate"
564        if resl then resl := cons(";", resl)
565        fa := form2String1(arg)
566        if atom(fa) then fa := [fa]
567        resl := [:fa, :resl]
568    [:fo, "[", :resl, "]"]
569
570formCollect2String [:itl,body] ==
571  ["_(",body,:"append"/[formIterator2String x for x in itl],"_)"]
572
573formIterator2String x ==
574  x is ["STEP",y,s,.,:l] =>
575    tail:= (l is [f] => form2StringLocal f; nil)
576    concat("for ",y," in ",s,'"..",tail)
577  x is ["tails",y] => concat("tails ",formatIterator y)
578  x is ["reverse",y] => concat("reverse ",formatIterator y)
579  x is ["|",y,p] => concat(formatIterator y," | ",form2StringLocal p)
580  x is ["until",p] => concat("until ",form2StringLocal p)
581  x is ["while",p] => concat("while ",form2StringLocal p)
582  systemErrorHere "formatIterator"
583
584tuple2String argl ==
585  fn1 argl where
586    fn1 argl ==
587        null argl => nil
588        string := first argl
589        if member(string, '("failed" "nil" "prime" "sqfr" "irred"))
590            then string := STRCONC('"_"", string, '"_"")
591            else string :=
592                ATOM string => object2String string
593                [fn2 x for x in string]
594        for x in rest argl repeat
595            if member(x, '("failed" "nil" "prime" "sqfr" "irred")) then
596                x := STRCONC('"_"", x, '"_"")
597            string := concat(string, concat(",", fn2 x))
598        string
599    fn2 x ==
600      ATOM x => object2String x
601      -- [fn2 first x, :f rest x]
602      [fn2 y for y in x]
603
604linearFormatName x ==
605  atom x => x
606  linearFormat x
607
608linearFormat x ==
609  atom x => x
610  x is [op,:argl] and atom op =>
611    argPart:=
612      argl is [a,:l] => [a,:"append"/[[",",x] for x in l]]
613      nil
614    [op,"(",:argPart,")"]
615  [linearFormat y for y in x]
616
617formTuple2String argl ==
618  null argl => nil
619  string:= form2StringLocal first argl
620  for x in rest argl repeat
621    string:= concat(string,concat(",",form2StringLocal x))
622  string
623
624isInternalFunctionName(op) ==
625  (not IDENTP(op)) or (op = "*") or (op = "**") => NIL
626  (1 = SIZE(op':= PNAME op)) or (char("*") ~= op'.0) => NIL
627  -- if there is a semicolon in the name then it is the name of
628  -- a compiled spad function
629  null (e := STRPOS('"_;",op',1,NIL)) => NIL
630  (char(" ") = (y := op'.1)) or (char("*") = y) => NIL
631  table := MAKETRTTABLE('"0123456789",NIL)
632  s := STRPOSL(table,op',1,true)
633  null(s) or s > e => NIL
634  SUBSTRING(op',s,e-s)
635
636application2String(op,argl, linkInfo) ==
637  op is ["$elt", t, f] =>
638      concat(application2String(f, argl, linkInfo), '"$", _
639             form2String1 t)
640  null argl =>
641    res1 :=
642       (op' := isInternalFunctionName(op)) => op'
643       app2StringWrap(formWrapId op, linkInfo)
644    $from_unparse => concat(res1,'"()")
645    res1
646  1=#argl =>
647    first argl is ["<",:.] => concat(op,first argl)
648    concat(app2StringWrap(formWrapId op, linkInfo), '"(", first argl, '")")
649  op='SEGMENT =>
650    null argl => '".."
651    (null rest argl) or (null first rest argl) =>
652      concat(first argl, '"..")
653    concat('"(", first argl, concat('"..", first rest argl), '")")
654  concat(app2StringWrap(formWrapId op, linkInfo) ,
655                        concat("_(",concat(tuple2String argl,"_)")))
656
657app2StringConcat0(x,y) ==
658  FORMAT(NIL, '"~a ~a", x, y)
659
660app2StringWrap(string, linkInfo) == string
661
662record2String x ==
663  argPart := NIL
664  for [":",a,b] in x repeat argPart:=
665    concat(argPart,",",a,": ",form2StringLocal b)
666  null argPart => '"Record()"
667  concat("Record_(",rest argPart,"_)")
668
669plural(n,string) ==
670  suffix:=
671    n = 1 => '""
672    '"s"
673  [:bright n,string,suffix]
674
675formatIf pred ==
676  not pred => nil
677  pred in '(T (QUOTE T)) => nil
678  concat('%b,'"if",'%d,pred2English pred)
679
680formatPredParts s ==
681  s is ['QUOTE,s1] => formatPredParts s1
682  s is ['LIST,:s1] => [formatPredParts s2 for s2 in s1]
683  s is ['devaluate,s1] => formatPredParts s1
684  s is ['getDomainView,s1,.] => formatPredParts s1
685  s is ['SUBST,a,b,c] =>    -- this is a signature
686    BREAK()
687    s1 := formatPredParts substitute(formatPredParts a,b,c)
688    s1 isnt [fun,sig] => s1
689    ['SIGNATURE,fun,[formatPredParts(r) for r in sig]]
690  s
691
692form_to_abbrev(x) ==
693    $abbreviateTypes : local := true
694    form2String(x)
695
696pred2English x ==
697  x is ['IF,cond,thenClause,elseClause] =>
698    c := concat('"if ",pred2English cond)
699    t := concat('" then ",pred2English thenClause)
700    e := concat('" else ",pred2English elseClause)
701    concat(c,t,e)
702  x is ['AND,:l] =>
703    tail:="append"/[concat(bright '"and",pred2English x) for x in rest l]
704    concat(pred2English first l,tail)
705  x is ['OR,:l] =>
706    tail:= "append"/[concat(bright '"or",pred2English x) for x in rest l]
707    concat(pred2English first l,tail)
708  x is ['not, l] =>
709    concat('"not ",pred2English l)
710  x is [op,a,b] and op in '(has ofCategory) =>
711    concat(pred2English a, '%b, '"has",'%d, form_to_abbrev b)
712  x is [op,a,b] and op in '(HasSignature HasCategory) =>
713    concat(prefix2String0 formatPredParts a,'%b,'"has",'%d,
714      prefix2String0 formatPredParts b)
715  x is [op,a,b] and op in '(ofType getDomainView) =>
716    if b is ['QUOTE,b'] then b := b'
717    concat(pred2English a, '": ", form_to_abbrev b)
718  x is [op,a,b] and op in '(isDomain domainEqual) =>
719    concat(pred2English a, '" = ", form_to_abbrev b)
720  x is [op,:.] and (translation := LASSOC(op,'(
721    (_< . " < ") (_<_= . " <= ")
722      (_> . " > ") (_>_= . " >= ") (_=  . " = ") (_^_= . " _^_= ")))) =>
723        concat(pred2English a,translation,pred2English b)
724  x is ['ATTRIBUTE, form] => BREAK()
725  x is '$ => '"%%"
726  form2String x
727
728mathObject2String x ==
729  CHARACTERP x => COERCE([x],'STRING)
730  object2String x
731
732object2String x ==
733  STRINGP x => x
734  IDENTP x  => PNAME x
735  NULL x    => '""
736  PAIRP  x  => STRCONC(object2String first x, object2String rest x)
737  WRITE_-TO_-STRING x
738
739object2Identifier x ==
740  IDENTP x  => x
741  STRINGP x => INTERN x
742  INTERN WRITE_-TO_-STRING x
743
744blankList x == "append"/[[BLANK,y] for y in x]
745
746
747string2Float s ==
748  -- takes a string, calls the parser on it and returns a float object
749  p := ncParseFromString s
750  p isnt [["$elt", FloatDomain, "float"], x, y, z] =>
751    systemError '"string2Float: did not get a float expression"
752  flt := getFunctionFromDomain("float", FloatDomain,
753    [$Integer, $Integer, $PositiveInteger])
754  SPADCALL(x, y, z, flt)
755
756
757
758form2Fence form ==
759  -- body of dbMkEvalable
760  [op, :.] := form
761  kind := GETDATABASE(op,'CONSTRUCTORKIND)
762  kind = 'category => form2Fence1 form
763  form2Fence1 mkEvalable form
764
765form2Fence1 x ==
766  x is [op,:argl] =>
767    op = 'QUOTE => ['"(QUOTE ",:form2FenceQuote first argl,'")"]
768    ['"(", FORMAT(NIL, '"|~a|", op),:"append"/[form2Fence1 y for y in argl],'")"]
769  x = "$" => ["%"]
770  IDENTP x => [FORMAT(NIL, '"|~a|", x)]
771--  [x]
772  ['"  ", x]
773
774form2FenceQuote x ==
775  NUMBERP x => [STRINGIMAGE x]
776  SYMBOLP x => [FORMAT(NIL, '"|~a|", x)]
777  atom    x => ['"??"]
778  ['"(",:form2FenceQuote first x,:form2FenceQuoteTail rest x]
779
780form2FenceQuoteTail x ==
781  null x => ['")"]
782  atom x => ['" . ",:form2FenceQuote x,'")"]
783  ['" ",:form2FenceQuote first x,:form2FenceQuoteTail rest x]
784
785form2StringList u ==
786  atom (r := form2String u) => [r]
787  r
788