Edit detail for SandBoxUnparse revision 7 of 12

isBinaryInfix op => BREAK() in appOrParen by

(op = "-" or op = '"-") and #argl = 1 => concat('"(", '"-", appOrParen(first argl), '")")

On Tue, Sep 16, 2008 at 11:11 PM Waldek Hebisch wrote:

The patch below is a first shot at better unparse. The last hunk add parentheses around single argument - this fixes the sin x+1 problem. The rest of the patch is rewritten binop2String. I hope that large class of expressions (including polynomials) will be printed without useless parentheses, however all cases where we are unsure if parenthesis are needed will now get them.

Note: the patch changes only printing of function applications and expressions involving binary operators, other things should be printed as before.

Note2: minimally tested - since almost all types are printed differently differences in testsuite output are quite large and I did not have time to check them.

boot

-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.

All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are -- met: -- -- - Redistributions of source code must retain the above copyright -- notice, this list of conditions and the following disclaimer. -- -- - Redistributions in binary form must reproduce the above copyright -- notice, this list of conditions and the following disclaimer in -- the documentation and/or other materials provided with the -- distribution. -- -- - Neither the name of The Numerical ALgorithms Group Ltd. nor the -- names of its contributors may be used to endorse or promote products -- derived from this software without specific prior written permission. -- -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS -- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A -- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER -- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
--% Functions for display formatting system objects
-- some of these are redundant and should be compacted $formatSigAsTeX := 1
--% Formatting modemaps
sayModemap m == -- sayMSG formatModemap displayTranModemap m sayMSG formatModemap old2NewModemaps displayTranModemap m
sayModemapWithNumber(m,n) == msg := reverse cleanUpSegmentedMsg reverse ["%i","%i",'" ", STRCONC(lbrkSch(),object2String n,rbrkSch()), :formatModemap displayTranModemap m,"%u","%u"] sayMSG flowSegmentedMsg(reverse msg,$LINELENGTH,3)
displayOpModemaps(op,modemaps) == TERPRI() count:= #modemaps phrase:= (count=1 => 'modemap;'modemaps) sayMSG ['%b,count,'%d,phrase,'" for",'%b,op,'%d,'":"] for modemap in modemaps repeat sayModemap modemap
displayTranModemap (mm is [[x,:sig],[pred,:y],:z]) == -- The next 8 lines are a HACK to deal with the "partial" definition -- JHD/RSS if pred is ['partial,:pred'] then [b,:c]:=sig sig:=[['Union,b,'"failed"],:c] mm:=[[x,:sig],[pred',:y],:z] else if pred = 'partial then [b,:c]:=sig sig:=[['Union,b,'"failed"],:c] mm:=[[x,:sig],y,:z] mm' := EQSUBSTLIST('(m n p q r s t i j k l), MSORT listOfPredOfTypePatternIds pred,mm) EQSUBSTLIST('(D D1 D2 D3 D4 D5 D6 D7 D8 D9 D10 D11 D12 D13 D14), MSORT listOfPatternIds [sig,[pred,:y]],mm')
listOfPredOfTypePatternIds p == p is ['AND,:lp] or p is ['OR,:lp] => UNIONQ([:listOfPredOfTypePatternIds p1 for p1 in lp],NIL) p is [op,a,.] and op = 'ofType => isPatternVar a => [a] nil nil
removeIsDomains pred == pred is ['isDomain,a,b] => true pred is ['AND,:predl] => MKPF([x for x in predl | x isnt ['isDomain,:.]],'AND) pred
canRemoveIsDomain? pred == -- returns nil OR an alist for substitutions of domains ordered so that -- after substituting for each pair in turn, no left-hand names remain alist := pred is ['isDomain,a,b] => [[a,:b],:alist] pred is ['AND,:predl] => [[a,:b] for pred in predl | pred is ['isDomain,a,b]] findSubstitutionOrder? alist
findSubstitutionOrder? alist == fn(alist,nil) where -- returns NIL or an appropriate substituion order fn(alist,res) == null alist => NREVERSE res choice := or/[x for (x:=[a,:b]) in alist | null containedRight(a,alist)] => fn(delete(choice,alist),[choice,:res]) nil
containedRight(x,alist)== or/[CONTAINED(x,y) for [.,:y] in alist]
removeIsDomainD pred == pred is ['isDomain,'D,D] => [D,nil] pred is ['AND,:preds] => D := nil for p in preds while not D repeat p is ['isDomain,'D,D1] => D := D1 npreds := delete(['isDomain,'D,D1],preds) D => 1 = #npreds => [D,first npreds] [D,['AND,:npreds]] nil nil
formatModemap modemap == [[dc,target,:sl],pred,:.]:= modemap if alist := canRemoveIsDomain? pred then dc:= substInOrder(alist,dc) pred:= substInOrder(alist,removeIsDomains pred) target:= substInOrder(alist,target) sl:= substInOrder(alist,sl) else if removeIsDomainD pred is [D,npred] then pred := SUBST(D,'D,npred) target := SUBST(D,'D,target) sl := SUBST(D,'D,sl) predPart:= formatIf pred targetPart:= prefix2String target argTypeList:= null sl => nil concat(prefix2String first sl,fn(rest sl)) where fn l == null l => nil concat(",",prefix2String first l,fn rest l) argPart:= #sl<2 => argTypeList ['"_(",:argTypeList,'"_)"] fromPart:= if dc = 'D and D then concat('%b,'"from",'%d,prefix2String D) else concat('%b,'"from",'%d,prefix2String dc) firstPart:= concat('" ",argPart,'" -> ",targetPart) sayWidth firstPart + sayWidth fromPart > 74 => --allow 5 spaces for " [n]" fromPart:= concat('" ",fromPart) secondPart := sayWidth fromPart + sayWidth predPart < 75 => concat(fromPart,predPart) concat(fromPart,'%l,predPart) concat(firstPart,'%l,secondPart) firstPart:= concat(firstPart,fromPart) sayWidth firstPart + sayWidth predPart < 80 => concat(firstPart,predPart) concat(firstPart,'%l,predPart)
substInOrder(alist,x) == alist is [[a,:b],:y] => substInOrder(y,SUBST(b,a,x)) x
reportOpSymbol op1 == op := (STRINGP op1 => INTERN op1; op1) modemaps := getAllModemapsFromDatabase(op,nil) null modemaps => ok := true sayKeyedMsg("S2IF0010",[op1]) if SIZE PNAME op1 < 3 then x := UPCASE queryUserKeyedMsg("S2IZ0060",[op1]) null MEMQ(STRING2ID_-N(x,1),'(Y YES)) => ok := nil sayKeyedMsg("S2IZ0061",[op1]) ok => apropos [op1] sayNewLine() -- filter modemaps on whether they are exposed mmsE := mmsU := NIL for mm in modemaps repeat isFreeFunctionFromMm(mm) or isExposedConstructor getDomainFromMm(mm) => mmsE := [mm,:mmsE] mmsU := [mm,:mmsU] if mmsE then sayMms(op,mmsE,'"exposed") where sayMms(op,mms,label) == m := # mms sayMSG m = 1 => ['"There is one",:bright label,'"function called", :bright op,'":"] ['"There are ",m,:bright label,'"functions called", :bright op,'":"] for mm in mms for i in 1.. repeat sayModemapWithNumber(mm,i) if mmsU then if mmsE then sayNewLine() sayMms(op,mmsU,'"unexposed") nil
formatOpType (form:=[op,:argl]) == null argl => unabbrev op form2String [unabbrev op, :argl]
formatOperationAlistEntry (entry:= [op,:modemaps]) == -- alist has entries of the form: ((op sig) . pred) -- opsig on this list => op is defined only when the predicate is true ans:= nil for [sig,.,:predtail] in modemaps repeat pred := (predtail is [p,:.] => p; 'T) -- operation is always defined ans := [concat(formatOpSignature(op,sig),formatIf pred),:ans] ans
formatOperation([[op,sig],.,[fn,.,n]],domain) == opSigString := formatOpSignature(op,sig) INTEGERP n and Undef = KAR domain.n => if INTEGERP $commentedOps then $commentedOps := $commentedOps + 1 concat(" --",opSigString) opSigString
formatOpSignature(op,sig) == concat('%b,formatOpSymbol(op,sig),'%d,": ",formatSignature sig)
formatOpConstant op == concat('%b,formatOpSymbol(op,'($)),'%d,'": constant")
formatOpSymbol(op,sig) == if op = 'Zero then op := "0" else if op = 'One then op := "1" null sig => op quad := specialChar 'quad n := #sig (op = 'elt) and (n = 3) => (CADR(sig) = '_$) => STRINGP (sel := CADDR(sig)) => [quad,".",sel] [quad,".",quad] op STRINGP op or GETL(op,"Led") or GETL(op,"Nud") => n = 3 =>
if op = 'SEGMENT then op := '".." op = 'in => [quad,'" ",op,'" ",quad] -- stop exquo from being displayed as infix (since it is not accepted -- as such by the interpreter) op = 'exquo => op [quad,op,quad] n = 2 => not GETL(op,"Nud") => [quad,op] [op,quad] op op
formatAttribute x == atom x => [" ",x] x is [op,:argl] => for x in argl repeat argPart:= NCONC(argPart,concat(",",formatAttributeArg x)) argPart => concat(" ",op,"_(",rest argPart,"_)") [" ",op]
formatAttributeArg x == STRINGP x and x ='"*" => "_"*_"" atom x => formatOpSymbol (x,nil) x is [":",op,["Mapping",:sig]] => concat('%b,formatOpSymbol(op,sig),": ",'%d,formatMapping sig) prefix2String0 x
formatMapping sig == "STRCONC"/concat("Mapping(",formatSignature sig,")")
dollarPercentTran x == -- Translate $ to %. We actually return %% so that the message -- printer will display a single % x is [y,:z] => y1 := dollarPercentTran y z1 := dollarPercentTran z EQ(y, y1) and EQ(z, z1) => x [y1, :z1] x = "$" or x = '"$" => "%%" x
formatSignatureAsTeX sig == $formatSigAsTeX: local := 2 formatSignature0 sig
formatSignature sig == $formatSigAsTeX: local := 1 formatSignature0 sig
formatSignatureArgs sml == $formatSigAsTeX: local := 1 formatSignatureArgs0 sml
formatSignature0 sig == null sig => "() -> ()" INTEGERP sig => '"hashcode" [tm,:sml] := sig sourcePart:= formatSignatureArgs0 sml targetPart:= prefix2String0 tm dollarPercentTran concat(sourcePart,concat(" -> ",targetPart))
formatSignatureArgs0(sml) == -- formats the arguments of a signature null sml => ["_(_)"] null rest sml => prefix2String0 first sml argList:= prefix2String0 first sml for m in rest sml repeat argList:= concat(argList,concat(",",prefix2String0 m)) concat("_(",concat(argList,"_)"))
--% Conversions to string form
expr2String x == atom (u:= prefix2String0 x) => u "STRCONC"/[atom2String y for y in u]
-- exports (this is a badly named bit of sillyness) prefix2StringAsTeX form == form2StringAsTeX form
prefix2String form == form2String form
-- local version prefix2String0 form == form2StringLocal form
-- SUBRP form => formWrapId BPINAME form -- atom form => -- form=$EmptyMode or form=$quadSymbol => formWrapId specialChar 'quad -- STRINGP form => formWrapId form -- IDENTP form => -- constructor? form => app2StringWrap(formWrapId form, [form]) -- formWrapId form -- formWrapId STRINGIMAGE form
form2StringWithWhere u == $permitWhere : local := true $whereList: local := nil s:= form2String u $whereList => concat(s,'%b,'"where",'%d,"%i",$whereList,"%u") s
form2StringWithPrens form == null (argl := rest form) => [first form] null rest argl => [first form,"(",first argl,")"] form2String form
formString u == x := form2String u atom x => STRINGIMAGE x "STRCONC"/[STRINGIMAGE y for y in x]
form2String u == $formatSigAsTeX: local := 1 form2StringLocal u
form2StringAsTeX u == $formatSigAsTeX: local := 2 form2StringLocal u
form2StringLocal u == --+ $NRTmonitorIfTrue : local := nil $fortInts2Floats : local := nil form2String1 u
constructorName con == $abbreviateTypes => abbreviate con con
form2String1 u == ATOM u => u=$EmptyMode or u=$quadSymbol => formWrapId specialChar 'quad IDENTP u => constructor? u => app2StringWrap(formWrapId u, [u]) u SUBRP u => formWrapId BPINAME u STRINGP u => formWrapId u WRITE_-TO_-STRING formWrapId u u1 := u op := CAR u argl := CDR u op='Join or op= 'mkCategory => formJoin1(op,argl) $InteractiveMode and (u:= constructor? op) => null argl => app2StringWrap(formWrapId constructorName op, u1) op = "NTuple" => [ form2String1 first argl, "*"] op = "Map" => ["(",:formatSignature0 [argl.1,argl.0],")"] op = 'Record => record2String(argl) null (conSig := getConstructorSignature op) => application2String(constructorName op,[form2String1(a) for a in argl], u1) ml := rest conSig if not freeOfSharpVars ml then ml:=SUBLIS([[pvar,:val] for pvar in $FormalMapVariableList for val in argl], ml) argl:= formArguments2String(argl,ml) -- extra null check to handle mutable domain hack. null argl => constructorName op application2String(constructorName op,argl, u1) op = "Mapping" => ["(",:formatSignature argl,")"] op = "Record" => record2String(argl) op = 'Union => application2String(op,[form2String1 x for x in argl], u1) op = ":" => null argl => [ '":" ] null rest argl => [ '":", form2String1 first argl ] formDecl2String(argl.0,argl.1) op = "#" and PAIRP argl and LISTP CAR argl => STRINGIMAGE SIZE CAR argl op = 'Join => formJoin2String argl op = "ATTRIBUTE" => form2String1 first argl op='Zero => 0 op='One => 1 op = 'AGGLST => tuple2String argl op = 'BRACKET => argl' := form2String1 first argl ["[",:(atom argl' => [argl']; argl'),"]"] op = "SIGNATURE" => [operation,sig] := argl concat(operation,": ",formatSignature sig) op = 'COLLECT => formCollect2String argl op = 'construct => concat(lbrkSch(), tuple2String [form2String1 x for x in argl],rbrkSch()) op = "SEGMENT" => null argl => '".." lo := form2String1 first argl argl := rest argl (null argl) or null (first argl) => [lo, '".."] [lo, '"..", form2String1 first argl] -- op = "MATRIX" => op -- does no work -- fortranCleanUp exp2Fort1 [op,:argl] -- somewhat works, but causes regression -- fortranCleanUp exp2Fort1 exp2FortOptimize [op,:argl] isBinaryInfix op => binop2String [op,:argl] application2String(op,[form2String1 x for x in argl], u1)
binop2String x == x is ["=", arg1, arg2] or x is ['"=", arg1, arg2] => concat(sumOrParen(arg1), '"=", sumOrParen(arg2)) sumOrParen(x) sumOrParen(x)
sumOrParen(x) == x is [op, arg1, arg2] => op = "+" or op = '"+" => concat(sumOrParen(arg1), '"+", productOrParen(arg2)) op = "-" or op = '"-" => concat(sumOrParen(arg1), '"-", productOrParen(arg2)) productOrParen(x) productOrParen(x)
productOrParen(x) == x is [op, arg1, arg2] => op = "*" or op ='"*" => concat(productOrParen(arg1), '"*", powerOrParen(arg2)) op = "/" or op = '"/" => concat(productOrParen(arg1), '"/", powerOrParen(arg2)) powerOrParen(x) powerOrParen(x)
powerOrParen(x) == x is [op, arg1, arg2] => op = "**" or op = '"**" or op = "^" or op = '"^" => concat(appOrParen(arg1), '"^", appOrParen(arg2)) concat('"(", appOrParen(x), '")") appOrParen(x)
appOrParen(x) == SYMBOLP(x) and not(constructor? x) => toString formWrapId x INTEGERP(x) => WRITE_-TO_-STRING x ATOM(x) => form2String0(x) [op, :argl] := x -- Put parenthesis around anything special -- not(SYMBOLP op) or GET(op, 'LED) or GET(op, 'NUD)_ -- Waldek fix: not(SYMBOLP op) or GET(op, "Led") or GET(op, "Nud")_ or op= 'mkCategory or constructor? op or op = "SEGMENT" _ or op = 'construct or op = 'COLLECT or op = "SIGNATURE"_ or op = 'BRACKET or op = 'AGGLST or op = "ATTRIBUTE"_ or op = 'Join or op = "#" => concat('"(", form2String0(x), '")") op = "Zero" => '"0" op = "One" => '"1" toString0(form2String1 x)
form2String0(x) == toString0(form2String1 x)
toString0(x) == ATOM(x) => toString x res := '"" for s in x repeat res := concat(res, toString s) res
toString s == STRINGP(s) => s SYMBOLP(s) => STRING(s) BREAK()
formWrapId id == $formatSigAsTeX = 1 => id $formatSigAsTeX = 2 => sep := '"`" FORMAT(NIL,'"\verb~a~a~a",sep, id, sep) error "Bad formatSigValue"
formArguments2String(argl,ml) == [fn(x,m) for x in argl for m in ml] where fn(x,m) == x=$EmptyMode or x=$quadSymbol => specialChar 'quad STRINGP(x) or IDENTP(x) => x x is [ ='_:,:.] => form2String1 x isValidType(m) and PAIRP(m) and (GETDATABASE(first(m),'CONSTRUCTORKIND) = 'domain) => (x' := coerceInteractive(objNewWrap(x,m),$OutputForm)) => form2String1 objValUnwrap x' form2String1 x form2String1 x
formDecl2String(left,right) == $declVar: local := left whereBefore := $whereList ls:= form2StringLocal left rs:= form2StringLocal right NE($whereList,whereBefore) and $permitWhere => ls concat(form2StringLocal ls,'": ",rs)
formJoin1(op,u) == if op = 'Join then [:argl,last] := u else (argl := nil; last := [op,:u]) last is [id,.,:r] and id in '(mkCategory CATEGORY) => $abbreviateJoin = true => concat(formJoin2 argl,'%b,'"with",'%d,'"...") $permitWhere = true => opList:= formatJoinKey(r,id) $whereList:= concat($whereList,"%l",$declVar,": ", formJoin2 argl,'%b,'"with",'%d,"%i",opList,"%u") formJoin2 argl opList:= formatJoinKey(r,id) suffix := concat('%b,'"with",'%d,"%i",opList,"%u") concat(formJoin2 argl,suffix) formJoin2 u
formatJoinKey(r,key) == key = 'mkCategory => r is [opPart,catPart,:.] => opString := opPart is [='LIST,:u] => "append"/[concat("%l",formatOpSignature(op,sig),formatIf pred) for [='QUOTE,[[op,sig],pred]] in u] nil catString := catPart is [='LIST,:u] => "append"/[concat("%l",'" ",form2StringLocal con,formatIf pred) for [='QUOTE,[con,pred]] in u] nil concat(opString,catString) '"?? unknown mkCategory format ??" -- otherwise we have the CATEGORY form "append"/[fn for x in r] where fn == x is ['SIGNATURE,op,sig] => concat("%l",formatOpSignature(op,sig)) x is ['ATTRIBUTE,a] => concat("%l",formatAttribute a) x
formJoin2 argl == -- argl is a list of categories NOT containing a "with" null argl => '"" 1=#argl => form2StringLocal argl.0 application2String('Join,[form2StringLocal x for x in argl], NIL)
formJoin2String (u:=[:argl,last]) == last is ["CATEGORY",.,:atsigList] => postString:= concat("_(",formTuple2String atsigList,"_)") #argl=1 => concat(first argl,'" with ",postString) concat(application2String('Join,argl, NIL)," with ",postString) application2String('Join,u, NIL)
formCollect2String [:itl,body] == ["_(",body,:"append"/[formIterator2String x for x in itl],"_)"]
formIterator2String x == x is ["STEP",y,s,.,:l] => tail:= (l is [f] => form2StringLocal f; nil) concat("for ",y," in ",s,'"..",tail) x is ["tails",y] => concat("tails ",formatIterator y) x is ["reverse",y] => concat("reverse ",formatIterator y) x is ["|",y,p] => concat(formatIterator y," | ",form2StringLocal p) x is ["until",p] => concat("until ",form2StringLocal p) x is ["while",p] => concat("while ",form2StringLocal p) systemErrorHere "formatIterator"
tuple2String argl == null argl => nil string := first argl if string in '("failed" "nil" "prime" "sqfr" "irred") then string := STRCONC('"_"",string,'"_"") else string := ATOM string => object2String string [f x for x in string] where f x == ATOM x => object2String x -- [f CAR x,:f CDR x] [f y for y in x] for x in rest argl repeat if x in '("failed" "nil" "prime" "sqfr" "irred") then x := STRCONC('"_"",x,'"_"") string:= concat(string,concat(",",f x)) string
script2String s == null s => '"" -- just to be safe if not PAIRP s then s := [s] linearFormatForm(CAR s, CDR s)
linearFormatName x == atom x => x linearFormat x
linearFormat x == atom x => x x is [op,:argl] and atom op => argPart:= argl is [a,:l] => [a,:"append"/[[",",x] for x in l]] nil [op,"(",:argPart,")"] [linearFormat y for y in x]
numOfSpadArguments id == char("*") = (s:= PNAME id).0 => +/[n for i in 1.. while INTEGERP (n:=PARSE_-INTEGER PNAME s.i)] keyedSystemError("S2IF0012",[id])
linearFormatForm(op,argl) == s:= PNAME op indexList:= [PARSE_-INTEGER PNAME d for i in 1.. while (DIGITP (d:= s.(maxIndex:= i)))] cleanOp:= INTERN ("STRCONC"/[PNAME s.i for i in maxIndex..MAXINDEX s]) fnArgs:= indexList.0 > 0 => concat('"(",formatArgList take(-indexList.0,argl),'")") nil if #indexList > 1 then scriptArgs:= formatArgList take(indexList.1,argl) argl := drop(indexList.1,argl) for i in rest rest indexList repeat subArglist:= take(i,argl) argl:= drop(i,argl) scriptArgs:= concat(scriptArgs,";",formatArgList subArglist) scriptArgs:= scriptArgs => concat(specialChar 'lbrk,scriptArgs, specialChar 'rbrk) nil l := [(STRINGP f => f; STRINGIMAGE f) for f in concat(cleanOp,scriptArgs,fnArgs)] "STRCONC"/l
formatArgList l == null l => nil acc:= linearFormat first l for x in rest l repeat acc:= concat(acc,",",linearFormat x) acc
formTuple2String argl == null argl => nil string:= form2StringLocal first argl for x in rest argl repeat string:= concat(string,concat(",",form2StringLocal x)) string
isInternalFunctionName(op) == (not IDENTP(op)) or (op = "*") or (op = "**") => NIL (1 = SIZE(op':= PNAME op)) or (char("*") ^= op'.0) => NIL -- if there is a semicolon in the name then it is the name of -- a compiled spad function null (e := STRPOS('"_;",op',1,NIL)) => NIL (char(" ") = (y := op'.1)) or (char("*") = y) => NIL table := MAKETRTTABLE('"0123456789",NIL) s := STRPOSL(table,op',1,true) null(s) or s > e => NIL SUBSTRING(op',s,e-s)
application2String(op,argl, linkInfo) == null argl => (op' := isInternalFunctionName(op)) => op' app2StringWrap(formWrapId op, linkInfo) 1=#argl => first argl is ["<",:.] => concat(op,first argl) concat(app2StringWrap(formWrapId op, linkInfo), "(", first argl, ")") --op in '(UP SM) => -- newop:= (op = "UP" => "P";"M") -- concat(newop,concat(lbrkSch(),argl.0,rbrkSch(),argl.1)) --op='RM =>concat("M",concat(lbrkSch(), -- argl.0,",",argl.1,rbrkSch(),argl.2)) --op='MP =>concat("P",concat(argl.0,argl.1)) op='SEGMENT => null argl => '".." (null rest argl) or (null first rest argl) => concat(first argl, '"..") concat(first argl, concat('"..", first rest argl)) concat(app2StringWrap(formWrapId op, linkInfo) , concat("_(",concat(tuple2String argl,"_)")))
app2StringConcat0(x,y) == FORMAT(NIL, '"~a ~a", x, y)
app2StringWrap(string, linkInfo) == not linkInfo => string $formatSigAsTeX = 1 => string $formatSigAsTeX = 2 => str2 := "app2StringConcat0"/form2Fence linkInfo sep := '"`" FORMAT(NIL, '"\lispLink{\verb!(|conPage| '~a)!}{~a}", str2, string) error "Bad value for $formatSigAsTeX"
record2String x == argPart := NIL for [":",a,b] in x repeat argPart:= concat(argPart,",",a,": ",form2StringLocal b) null argPart => '"Record()" concat("Record_(",rest argPart,"_)")
plural(n,string) == suffix:= n = 1 => '"" '"s" [:bright n,string,suffix]
formatIf pred == not pred => nil pred in '(T (QUOTE T)) => nil concat('%b,'"if",'%d,pred2English pred)
formatPredParts s == s is ['QUOTE,s1] => formatPredParts s1 s is ['LIST,:s1] => [formatPredParts s2 for s2 in s1] s is ['devaluate,s1] => formatPredParts s1 s is ['getDomainView,s1,.] => formatPredParts s1 s is ['SUBST,a,b,c] => -- this is a signature s1 := formatPredParts SUBST(formatPredParts a,b,c) s1 isnt [fun,sig] => s1 ['SIGNATURE,fun,[formatPredParts(r) for r in sig]] s
pred2English x == x is ['IF,cond,thenClause,elseClause] => c := concat('"if ",pred2English cond) t := concat('" then ",pred2English thenClause) e := concat('" else ",pred2English elseClause) concat(c,t,e) x is ['AND,:l] => tail:="append"/[concat(bright '"and",pred2English x) for x in rest l] concat(pred2English first l,tail) x is ['OR,:l] => tail:= "append"/[concat(bright '"or",pred2English x) for x in rest l] concat(pred2English first l,tail) x is ['NOT,l] => concat('"not ",pred2English l) x is [op,a,b] and op in '(has ofCategory) => concat(pred2English a,'%b,'"has",'%d,form2String abbreviate b) x is [op,a,b] and op in '(HasSignature HasAttribute HasCategory) => concat(prefix2String0 formatPredParts a,'%b,'"has",'%d, prefix2String0 formatPredParts b) x is [op,a,b] and op in '(ofType getDomainView) => if b is ['QUOTE,b'] then b := b' concat(pred2English a,'": ",form2String abbreviate b) x is [op,a,b] and op in '(isDomain domainEqual) => concat(pred2English a,'" = ",form2String abbreviate b) x is [op,:.] and (translation := LASSOC(op,'( (_< . " < ") (_<_= . " <= ") (_> . " > ") (_>_= . " >= ") (_= . " = ") (_^_= . " _^_= ")))) => concat(pred2English a,translation,pred2English b) x is ['ATTRIBUTE,form] => concat("attribute: ",form2String form) form2String x
mathObject2String x == CHARACTERP x => COERCE([x],'STRING) object2String x
object2String x == STRINGP x => x IDENTP x => PNAME x NULL x => '"" PAIRP x => STRCONC(object2String first x, object2String rest x) WRITE_-TO_-STRING x
object2Identifier x == IDENTP x => x STRINGP x => INTERN x INTERN WRITE_-TO_-STRING x
blankList x == "append"/[[BLANK,y] for y in x] --------------------> NEW DEFINITION (see cformat.boot.pamphlet) pkey keyStuff == if not PAIRP keyStuff then keyStuff := [keyStuff] allMsgs := ['" "] while not null keyStuff repeat dbN := NIL argL := NIL key := first keyStuff keyStuff := IFCDR keyStuff next := IFCAR keyStuff while PAIRP next repeat if CAR next = 'dbN then dbN := CADR next else argL := next keyStuff := IFCDR keyStuff next := IFCAR keyStuff oneMsg := returnStLFromKey(key,argL,dbN) allMsgs := ['" ", :NCONC (oneMsg,allMsgs)] allMsgs
string2Float s == -- takes a string, calls the parser on it and returns a float object p := ncParseFromString s p isnt [["$elt", FloatDomain, "float"], x, y, z] => systemError '"string2Float: did not get a float expression" flt := getFunctionFromDomain("float", FloatDomain, [$Integer, $Integer, $PositiveInteger]) SPADCALL(x, y, z, flt)
form2Fence form == -- body of dbMkEvalable [op, :.] := form kind := GETDATABASE(op,'CONSTRUCTORKIND) kind = 'category => form2Fence1 form form2Fence1 mkEvalable form
form2Fence1 x == x is [op,:argl] => op = 'QUOTE => ['"(QUOTE ",:form2FenceQuote first argl,'")"] ['"(", FORMAT(NIL, '"|~a|", op),:"append"/[form2Fence1 y for y in argl],'")"] IDENTP x => FORMAT(NIL, '"|~a|", x) -- [x] ['" ", x]
form2FenceQuote x == NUMBERP x => [STRINGIMAGE x] SYMBOLP x => [FORMAT(NIL, '"|~a|", x)] atom x => '"??" ['"(",:form2FenceQuote first x,:form2FenceQuoteTail rest x]
form2FenceQuoteTail x == null x => ['")"] atom x => ['" . ",:form2FenceQuote x,'")"] ['" ",:form2FenceQuote first x,:form2FenceQuoteTail rest x]
form2StringList u == atom (r := form2String u) => [r] r

boot

Value = T
; (DEFUN |sayModemapWithNumber| ...) is being compiled.
;; The variable $LINELENGTH is undefined.
;; The compiler will assume this variable is a global.
; (DEFUN |formatOperation| ...) is being compiled.
;; The variable |$commentedOps| is undefined.
;; The compiler will assume this variable is a global.
; (DEFUN |constructorName| ...) is being compiled.
;; The variable |$abbreviateTypes| is undefined.
;; The compiler will assume this variable is a global.
; (DEFUN |formWrapId| ...) is being compiled.
;; The variable |$formatSigAsTeX| is undefined.
;; The compiler will assume this variable is a global.
; (DEFUN |formArguments2String,fn| ...) is being compiled.
;; The variable |$OutputForm| is undefined.
;; The compiler will assume this variable is a global.
; (DEFUN |formDecl2String| ...) is being compiled.
;; The variable |$permitWhere| is undefined.
;; The compiler will assume this variable is a global.
; (DEFUN |formJoin1| ...) is being compiled.
;; The variable |$abbreviateJoin| is undefined.
;; The compiler will assume this variable is a global.
;; The variable |$declVar| is undefined.
;; The compiler will assume this variable is a global.
Value = 74272

Tests

I found the following (stolen form fortpak.spad) useful when experimenting with InputForm?:

parse(s:String):InputForm == ncParseFromString(s)$Lisp::InputForm

   Function declaration parse : String -> InputForm has been added to
      workspace.

Here are a few examples:

unparse(sin(x)::InputForm)

(1)

unparse(sin(x+1)::InputForm)

(2)

parse(%)

Compiling function parse with type String -> InputForm

(3)

interpret(%)$InputForm

(4)

integrate(sin(x)^2+cos(x+1)^2,x)

(5)

For some reason this result causes a tex error.

)set output tex off

)set output algebra on

%::InputForm

   (7)
   (/

     (+  (* (* (* 4 (** (tan (/ 1 2)) 2)) (cos (+ x 1))) (sin (+ x 1)))

       (+

         (*  (+ (* - 2 (** (tan (/ 1 2)) 3)) (* 2 (tan (/ 1 2))))
          (** (cos (+ x 1)) 2))

        (+ (+ (* x (** (tan (/ 1 2)) 4)) (* (* 2 x) (** (tan (/ 1
2)) 2))) x))
       )

    (+ (+ (** (tan (/ 1 2)) 4) (* 2 (** (tan (/ 1 2)) 2))) 1))

unparse(%)

   (8)
  "((4*tan(1/2)^2*cos(x+1)*sin(x+1)+((((-2*tan(1/2)^3+2*tan(1/2)))*
;cos(x+1)^2+(
  (x*tan(1/2)^4+2*x*tan(1/2)^2+x))))))/((tan(1/2)^4+2*tan(1/2)^2+1))"

parse(%)

   (9)
   (/

     (+  (* (* (* 4 (^ (tan (/ 1 2)) 2)) (cos (+ x 1))) (sin (+ x 1)))

       (+

         (*  (+ (- (* 2 (^ (tan (/ 1 2)) 3))) (* 2 (tan (/ 1 2))))
          (^ (cos (+ x 1)) 2))

        (+ (+ (* x (^ (tan (/ 1 2)) 4)) (* (* 2 x) (^ (tan (/ 1 2)) 2))) x))
       )

    (+ (+ (^ (tan (/ 1 2)) 4) (* 2 (^ (tan (/ 1 2)) 2))) 1))

)set output tex on

)set output algebra off

interpret(%)$InputForm

(6)

)set output tex off

)set output algebra on

unparse(parse("sin(x)^2"))

   (11)  "sin(x)^2"

parse("a*b/c*d")

   (12)  (* (/ (* a b) c) d)

unparse(%)

   (13)  "a*b/c*d"

parse("a*b/c/d")

   (14)  (/ (/ (* a b) c) d)

unparse(%)

   (15)  "a*b/c/d"

)set output tex on

)set output algebra off