aboutsummaryrefslogtreecommitdiff
path: root/src/interp/format.boot.pamphlet
diff options
context:
space:
mode:
authordos-reis <gdr@axiomatics.org>2007-08-14 05:14:52 +0000
committerdos-reis <gdr@axiomatics.org>2007-08-14 05:14:52 +0000
commitab8cc85adde879fb963c94d15675783f2cf4b183 (patch)
treec202482327f474583b750b2c45dedfc4e4312b1d /src/interp/format.boot.pamphlet
downloadopen-axiom-ab8cc85adde879fb963c94d15675783f2cf4b183.tar.gz
Initial population.
Diffstat (limited to 'src/interp/format.boot.pamphlet')
-rw-r--r--src/interp/format.boot.pamphlet802
1 files changed, 802 insertions, 0 deletions
diff --git a/src/interp/format.boot.pamphlet b/src/interp/format.boot.pamphlet
new file mode 100644
index 00000000..e4c83a31
--- /dev/null
+++ b/src/interp/format.boot.pamphlet
@@ -0,0 +1,802 @@
+\documentclass{article}
+\usepackage{axiom}
+\begin{document}
+\title{\$SPAD/src/interp format.boot}
+\author{The Axiom Team}
+\maketitle
+\begin{abstract}
+\end{abstract}
+\eject
+\tableofcontents
+\eject
+\section{License}
+<<license>>=
+-- 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.
+
+@
+<<*>>=
+<<license>>
+
+--% 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
+@
+\eject
+\begin{thebibliography}{99}
+\bibitem{1} nothing
+\end{thebibliography}
+\end{document}