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