From 0850ca5458cb09b2d04cec162558500e9a05cf4a Mon Sep 17 00:00:00 2001 From: dos-reis Date: Thu, 20 Sep 2007 14:50:49 +0000 Subject: Revert commits to the wrong tree. --- src/interp/format.boot | 780 ------------------------------------------------- 1 file changed, 780 deletions(-) delete mode 100644 src/interp/format.boot (limited to 'src/interp/format.boot') diff --git a/src/interp/format.boot b/src/interp/format.boot deleted file mode 100644 index fee60054..00000000 --- a/src/interp/format.boot +++ /dev/null @@ -1,780 +0,0 @@ --- 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 GET(op,"Led") or GET(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 GET(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] - isBinaryInfix op => fortexp0 [op,:argl] - -- COMPILED_-FUNCTION_-P(op) => form2String1 coerceMap2E(u1,NIL) - application2String(op,[form2String1 x for x in argl], u1) - -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 - -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 -- cgit v1.2.3