aboutsummaryrefslogtreecommitdiff
path: root/src/interp/pspad2.boot.pamphlet
diff options
context:
space:
mode:
authordos-reis <gdr@axiomatics.org>2007-09-20 14:50:49 +0000
committerdos-reis <gdr@axiomatics.org>2007-09-20 14:50:49 +0000
commit0850ca5458cb09b2d04cec162558500e9a05cf4a (patch)
treeaa76b50f08c662dab9a49b6ee9f0dc7318139ea1 /src/interp/pspad2.boot.pamphlet
parent6f8caa148526efc14239febdc12f91165389a8ea (diff)
downloadopen-axiom-0850ca5458cb09b2d04cec162558500e9a05cf4a.tar.gz
Revert commits to the wrong tree.
Diffstat (limited to 'src/interp/pspad2.boot.pamphlet')
-rw-r--r--src/interp/pspad2.boot.pamphlet683
1 files changed, 683 insertions, 0 deletions
diff --git a/src/interp/pspad2.boot.pamphlet b/src/interp/pspad2.boot.pamphlet
new file mode 100644
index 00000000..54e9a584
--- /dev/null
+++ b/src/interp/pspad2.boot.pamphlet
@@ -0,0 +1,683 @@
+\documentclass{article}
+\usepackage{axiom}
+\begin{document}
+\title{\$SPAD/src/interp pspad2.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>>
+
+)package "BOOT"
+
+--======================================================================
+-- Constructor Transformation Functions
+--======================================================================
+formatDeftranForm(form,tlist) ==
+ [ttype,:atypeList] := tlist
+ if form is [":",f,t] then
+ form := f
+ ttype := t
+ if form is ['elt,a,b] then ----> a.b ====> apply(b,a)
+ form :=
+ isTypeProbably? a =>
+ atypeList := REVERSE atypeList
+ ["$$", b, a]
+ ["apply",a, b]
+ op := KAR form
+ argl := KDR form
+ if or/[t for t in atypeList] then
+ form := [op,:[(t => [":",a,t]; a) for a in argl for t in atypeList]]
+ if ttype then form := [":",form,ttype]
+ form
+
+formatDeftran(u,SEQflag) ==
+ u is ['Join,:x] => formatDeftranJoin(u,SEQflag)
+ u is ['CATEGORY,kind,:l,x] => formatDeftran(['with,['SEQ,:l,['exit,n,x]]],SEQflag)
+ u is ['CAPSULE,:l,x] => formatDeftranCapsule(l,x,SEQflag)
+ u is [op,:.] and MEMQ(op,'(rep per)) => formatDeftranRepper(u,SEQflag)
+ u is [op,:.] and MEMQ(op,'(_: _:_: _pretend _@)) =>
+ formatDeftranColon(u,SEQflag)
+ u is ['PROGN,:l,x] => formatDeftran(['SEQ,:l,['exit,1,x]],SEQflag)
+ u is ['SEQ,:l,[.,n,x]] =>
+ v := [:l,x]
+ a := "APPEND"/[formatDeftranSEQ(x,true) for x in l]
+ b := formatDeftranSEQ(x,false)
+ if b is [:.,c] and c = '(void) then b := DROP(-1, b)
+ [:m,y] := [:a,:b]
+ ['SEQ,:m,['exit,n,y]]
+-- u is ['not,arg] and (op := LASSOC(KAR arg,'((_= . _^_=) (_< . _>_=)))) =>
+-- formatDeftran([op,:CDR arg],nil)
+ u is ["^",a] => formatDeftran(['not,a],SEQflag)
+ u is ["exquo",a,b] => formatDeftran(['xquo,a,b],SEQflag)
+ u is ['IF,a,b,c] =>
+ a := formatDeftran(a,nil)
+ b := formatDeftran(b,nil)
+ c := formatDeftran(c,nil)
+ null SEQflag and $insideDEF =>
+ [:y,last] := formatDeftranIf(a,b,c)
+ ['SEQ,:y,['exit,1,last]]
+ ['IF,a,b,c]
+ u is ['Union,:argl] =>
+ ['Union,:[x for a in argl
+ | x := (STRINGP a => [":",INTERN a,'Branch]; formatDeftran(a,nil))]]
+ u is [op,:itl,body] and MEMQ(op,'(REPEAT COLLECT)) and
+ ([nitl,:nbody] := formatDeftranREPEAT(itl,body)) =>
+ formatDeftran([op,:nitl,nbody],SEQflag)
+ u is [":",a,b] => [":",formatDeftran(a,nil),formatDeftran(markMacroTran(b),nil)]
+ u is ["DEF",:.] => formatCapsuleFunction(u)
+ u is [op,:argl]=>[formatDeftran(op,nil),:[formatDeftran(x,nil) for x in argl]]
+ u = 'nil => 'empty
+ u
+
+formatCapsuleFunction ["DEF",form,tlist,b,body] ==
+ $insideDEF : local := true
+ ["DEF", formatDeftran(form,nil),tlist,b,formatDeftran(body,nil)]
+
+formatDeftranCapsule(l,x,SEQflag) ==
+ $insideCAPSULE: local := true
+ formatDeftran(['SEQ,:l,['exit,1,x]],SEQflag)
+
+formatDeftranRepper([op,a],SEQflag) ==
+ a is [op1,b] and MEMQ(op1,'(rep per)) =>
+ op = op1 => formatDeftran(a,SEQflag)
+ formatDeftran(b,SEQflag)
+ a is ["::",b,t] =>
+ b := formatDeftran(b,SEQflag)
+ t := formatDeftran(t,SEQflag)
+ a := ["::",b,t]
+ op = 'per and t = "$" or op = 'rep and t = 'Rep => a
+ [op,a]
+ a is ['SEQ,:r] => ['SEQ,:[formatSeqRepper(op,x) for x in r]]
+ a is ['IF,p,b,c] =>
+ formatDeftran(['IF,p,[op,b],[op, c]], SEQflag)
+ a is ['LET,a,b] => formatDeftran(['LET,a,[op,b]],SEQflag)
+ a is ['not,[op,a,b]] and (op1 := LASSOC(op,$pspadRelationAlist)) =>
+ formatDeftran [op1,a,b]
+ a is ['return,n,r] =>
+ MEMQ(opOf r,'(true false)) => a
+ ['return,n,[op,formatDeftran(r,SEQflag)]]
+ a is ['error,:.] => a
+ [op,formatDeftran(a,SEQflag)]
+
+formatDeftranColon([op,a,t],SEQflag) == --op is one of : :: pretend @
+ a := formatDeftran(a,SEQflag)
+ t := formatDeftran(t,SEQflag)
+ a is ["UNCOERCE",b] => b
+ a is [op1,b,t1] and t1 = t and MEMQ(op,'(_: _:_: _pretend _@)) =>
+ op1 = "pretend" or op = "pretend" => ["pretend",b,t]
+ null SEQflag and op1 = ":" or op = ":" => ["pretend",b,t]
+ a
+ a is [=op,b,t1] =>
+ t1 = t => a
+ [op,b,t]
+ t = "$" =>
+ a is ['rep,b] => b
+ a is ['per,b] => a
+ [op,a,t]
+ t = "Rep" =>
+ a is ['per,b] => b
+ a is ['rep,b] => a
+ [op,a,t]
+ [op,a,t]
+
+formatSeqRepper(op,x) ==
+ x is ['exit,n,y] => ['exit,n,[op,formatDeftran(y,nil)]]
+ x is ["=>",a,b] => ["=>",formatDeftran(a,nil),[op,formatDeftran(b,nil)]]
+ atom x => x
+ [formatSeqRepper(op,y) for y in x]
+
+formatDeftranJoin(u,SEQflag) ==
+ ['Join,:cats,lastcat] := u
+ lastcat is ['CATEGORY,kind,:l,x] =>
+ cat :=
+ CDR cats => ['Join,:cats]
+ first cats
+ formatDeftran(['with,cat,['SEQ,:l,['exit,1,x]]],SEQflag)
+ u
+
+formatENUM ['MyENUM, x] == format "'" and format x and format "'"
+
+formatDeftranREPEAT(itl,body) ==
+--do nothing unless "itl" contains UNTIL statements
+ u := [x for x in itl | x is ["UNTIL",p]] or return nil
+ nitl := SETDIFFERENCE(itl,u)
+ pred := MKPF([p for ['UNTIL,p] in u],'or)
+ cond := ['IF,pred,['leave,n,nil],'noBranch]
+ nbody :=
+ body is ['SEQ,:l,[.,n,x]] => ['SEQ,:l,x,['exit,n,cond]]
+ ['SEQ,body,['exit,n,cond]]
+ [nitl,:nbody]
+
+formatDeftranSEQ(x,flag) ==
+ u := formatDeftran(x,flag)
+ u is ['SEQ,:.] => rest u
+ [u]
+
+formatDeftranIf(a,b,c) ==
+ b = 'noBranch =>
+ a is [op,:r] and (al := '((_= . _~_=) (_< . _>_=) (_> . _<_=));
+ iop := LASSOC(op, al) or rassoc(op, al)) =>
+ [["=>",[iop, :r],c]]
+ a is [op,r] and MEMQ(op,'(NOT not NULL null)) =>
+ [["=>", r, c]]
+ [["=>", ['not, a], c]]
+ post :=
+ c = 'noBranch => nil
+ c is ['SEQ,:.] => CDR c
+ [c]
+ [["=>",a,b],:post]
+
+formatWHERE ["where",a,b] ==
+ $insideTypeExpression: local := nil
+ $insideCAPSULE: local := false
+ tryBreak(formatLeft("format",a,"where","Led") and format " where ",b,"where","Led")
+
+--======================================================================
+-- Special Handlers: Categories
+--======================================================================
+formatATTRIBUTE ['ATTRIBUTE,att] == format att
+
+formatDeftranCategory ['CATEGORY,kind,:items,item] == ["SEQ",:items,["exit",1,item]]
+
+formatCategory ['Category] == format " " and format "Category"
+
+formatCATEGORY cat ==
+ con := opOf $form
+ $comments: local := SUBST('_$,'_%,GETDATABASE(con,'DOCUMENTATION))
+ $insideEXPORTS : local := true
+ format ["with",formatDeftranCategory cat]
+
+formatSIGNATURE ['SIGNATURE,op,types,:r] ==
+ MEMQ('constant,r) => format op and format ": " and (u := format first types) and
+ formatSC() and formatComments(u,op,types)
+ format op and format ": " and (u := format ['Mapping,:types]) and formatSC() and
+ formatComments(u,op,types)
+
+formatDefault ["default",a] ==
+ $insideCategoryIfTrue : local := false
+ $insideCAPSULE: local := true
+ $insideTypeExpression: local := false
+ tryBreak(format "default ",a,"with","Nud")
+--======================================================================
+-- Special Handlers: Control Structures
+--======================================================================
+formatUNCOERCE ['UNCOERCE,x] == format x
+
+formatIF ['IF,a,b,c] ==
+ c = 'noBranch => formatIF2(a,b,"if ")
+ b = 'noBranch => formatIF ['IF,['not,a],c,'noBranch]
+ formatIF2(a,b,"if ") and newLine() and formatIF3 c
+
+formatIF2(a,b,prefix) ==
+ tryBreakNB(format prefix and format a and format " then ",b,"then","Nud")
+
+formatIF3 x ==
+ x is ['IF,a,b,c] =>
+ c = 'noBranch => tryBreak(format "else if "
+ and format a and format " then ",b,"then","Nud")
+ formatIF2(a,b,"else if ") and newLine() and formatIF3 c
+ tryBreak(format "else ",x,"else","Nud")
+
+formatBlock(l,x) ==
+ null l => format x
+ $pilesAreOkHere: local
+ format "{ " and format first l and
+ (and/[formatSC() and format y for y in rest l])
+ and formatSC() and format x and format " }"
+
+formatExit ["exit",.,u] == format u
+
+formatvoid ["void"] == format "()"
+
+formatLeave ["leave",.,u] == format "break"
+
+formatCOLLECT u == formatSpill("formatCOLLECT1",u)
+
+formatCOLLECT1 ["COLLECT",:iteratorList,body] ==
+ $pilesAreOkHere: local
+ format "[" and format body and format " " and
+ formatSpill("formatIteratorTail",iteratorList)
+
+formatIteratorTail iteratorList ==
+ formatIterator first iteratorList and
+ (and/[format " " and formatIterator x for x in rest iteratorList]) and format "]"
+
+--======================================================================
+-- Special Handlers: Keywords
+--======================================================================
+
+formatColon [":",a,b] ==
+ b is ['with,c,:d] => formatColonWith(a,c,d)
+ if not $insideTypeExpression then
+ insideCat() => nil
+ format
+ $insideDEF => "local "
+ "default "
+ op :=
+ $insideCAPSULE and not $insideDEF => ": "
+ insideCat() => ": "
+ ":"
+ b := (atom b => b; markMacroTran b)
+ a is ['LISTOF,:c] => formatComma c and format ": " and formatLocal1 b
+ formatInfix(op,[a, b],formatOpBindingPower(":","Led","left"),
+ formatOpBindingPower(":","Led","right"))
+
+formatColonWith(form,a,b) ==
+ con := opOf $form
+ $comments: local := SUBST('_$,'_%,GETDATABASE(con,'DOCUMENTATION))
+ $insideEXPORTS : local := true
+ $pilesAreOkHere: local := true
+ $insideTypeExpression : local := false
+ b => tryBreak(formatDefForm form and format ": "
+ and format a and format " with ",first b,"with","Led")
+ tryBreak(formatDefForm form and format ": with ",a,"with","Nud")
+
+formatCOND ["COND",:l] ==
+ originalC:= $c
+ and/[x is [a,[.,.,b]] for x in l] =>
+ (originalC=$m or indent() and newLine()) and first l is [a,[.,.,b]] and
+ formatIfExit(a,b) and
+ (and/[newLine() and formatIfExit(a,b) for [a,[.,.,b]] in rest l]) and (originalC=$m or undent()) and originalC
+ formatIfThenElse l
+
+formatPROGN ["PROGN",:l] ==
+ l is [:u,x] => formatPiles(u,x)
+ error '"formatPROGN"
+
+formatELT ["ELT",a,b] == formatApplication [a,b]
+
+formatCONS ["CONS",a,b] ==
+ $pilesAreOkHere: local
+ format "[" and formatConstructItem a and formatTail b
+
+formatTail x ==
+ null x => format "]"
+ format "," and formatTail1 x
+
+formatTail1 x ==
+ x is ["CONS",a,b] => formatConstructItem a and formatTail b
+ x is ["APPEND",a,b] =>
+ null b => formatConstructItem a and format "]"
+ format ":" and formatConstructItem a and formatTail b
+ format ":" and formatConstructItem x and format "]"
+
+-- x = "." => format " "
+formatConstructItem x == format x
+
+formatLET ["LET",a,b] ==
+ $insideTypeExpression: local := true
+ a = "Rep" or atom a and constructor? opOf b =>
+ tryBreakNB(formatAtom a and format " == ",b,":=","Led")
+ tryBreakNB((IDENTP a => formatAtom a; format a) and format " := ",b,":=","Led")
+
+formatIfExit(a,b) ==
+ --called from SCOND or COND only
+ $numberOfSpills: local:= 0
+ curMargin:= $m
+ curMarginStack:= $currentMarginStack
+ $doNotResetMarginIfTrue:= true
+ format a and format " => " and formatRight("formatCut",b,"=>","Led") =>
+ ($currentMarginStack:= curMarginStack; $m:= curMargin)
+
+formatIfThenElse x == formatSpill("formatIf1",x)
+
+formatIf1 x ==
+ x is [[a,:r],:c] and null c =>
+ b:=
+ r is [:l,s] and l => ['SEQ,:l,['exit,.,s]]
+ first r
+ isTrue a => format b
+ format "if " and format a and format " then " and format b
+ format "if " and format a and
+ (try
+ (format " then " and format b and format " else "
+ and formatIfThenElse c) or spillLine()
+ and format " then " and format b and
+-- ($c:= $m:= $m+6) and
+ ($numberOfSpills:= $numberOfSpills-1)
+ and spillLine() and format " else " and formatIfThenElse c)
+
+formatQUOTE ["QUOTE",x] == format "('" and format x and format ")"
+
+formatMI ["MI",a,b] == format a
+
+formatMapping ['Mapping,target,:sources] ==
+ $noColonDeclaration: local := true
+ formatTuple ['Tuple,:sources] and format " -> " and format target
+
+formatTuple ['Tuple,:types] ==
+ null types => format "()"
+ null rest types => format first types
+ formatFunctionCallTail types
+
+formatConstruct(['construct,:u]) ==
+ format "[" and (null u or format first u and
+ "and"/[format "," and formatCut x for x in rest u]) and format "]"
+
+formatNextConstructItem x ==
+ try format x or ($m := $m + 2) and newLine() and format x
+
+formatREPEAT ["REPEAT",:iteratorList,body] ==
+ tryBreakNB(null iteratorList or (formatIterator first iteratorList and
+ (and/[format " " and formatIterator x for x in rest iteratorList]) and format " ")
+ and format "repeat ",body,"repeat","Led")
+
+formatFATARROW ["=>",a,b] == tryBreak(format a and format " => ",b,"=>","Led")
+
+formatMap ["+->",a,b] ==
+ $noColonDeclaration: local := true
+ tryBreak(format a and format " +-> ", b, "+->","Led")
+
+formatREDUCE ["REDUCE",op,.,u] == formatReduce1(op,u)
+
+formatreduce ["reduce",op,u] == formatReduce1(op,u)
+
+formatReduce1(op,u) ==
+ if STRINGP op then op := INTERN op
+ id := LASSOC(op,
+ '((_+ Zero)(_* One)(append . NIL)(gcd Zero) (lcm One) (strconc . "")(lcm One)))
+ formatFunctionCall
+ id => ['reduce,op,u,id]
+ ['reduce,op,u]
+
+formatIterator u ==
+ $noColonDeclaration : local := true
+ u is ["IN",x,y] =>
+ format "for " and formatLeft("format",x,"in","Led") and format " in " and
+ formatRight("format",y,"in","Led")
+ u is ["WHILE",x] => format "while " and formatRight("format",x,"while","Nud")
+ u is ["UNTIL",x] => format "until " and formatRight("format",x,"until","Nud")
+ u is ["|",x] => format "| " and formatRight("format",x,"|","Led")
+ u is ["STEP",i,init,step,:v] =>
+ final := IFCAR v
+ format "for " and formatLeft("format",i,"in","Led") and format " in " and
+ (seg := ['SEGMENT,init,final]) and (formatStepOne? step => format seg; formatBy ['by,seg,step])
+ error "formatIterator"
+
+formatStepOne? step ==
+ step = 1 or step = '(One) => true
+ step is [op,n,.] and MEMQ(op,'(_:_: _@)) => n = 1 or n = '(One)
+ false
+
+formatBy ['by,seg,step] == format seg and format " by " and format step
+
+formatSCOND ["SCOND",:l] ==
+ $pilesAreOkHere =>
+ --called from formatPileLine or formatBlock
+ --if from formatPileLine
+ initialC:= $c
+ and/[x is [a,["exit",.,b]] for x in l] =>
+ first l is [a,["exit",.,b]] and formatIfExit(a,b) and
+ (and/[newLine() and formatIfExit(a,b) for [a,["exit",.,b]] in rest l]) and initialC
+ formatIfThenElse l and initialC
+ and/[x is [a,["exit",.,b]] for x in l] =>
+ first l is [a,["exit",.,b]] and formatIfExit(a,b) and
+ (and/[format "; " and formatIfExit(a,b) for [a,["exit",.,b]] in rest l]) and $c
+ --warning: and/(...) returns T if there are no entries
+ formatIfThenElse l
+
+formatSEGMENT ["SEGMENT",a,b] ==
+ $pilesAreOkHere: local
+ (if pspadBindingPowerOf("right",a)<750 then formatPren a else format a) and
+ formatInfixOp ".." and
+ (null b and $c or
+ (if 750>pspadBindingPowerOf("left",b) then formatPren b else format b))
+
+formatSexpr x ==
+ atom x =>
+ null x or IDENTP x => consBuffer ident2PrintImage PNAME x
+ consBuffer x
+ spill("formatNonAtom",x)
+
+formatNonAtom x ==
+ format "_(" and formatSexpr first x and
+ (and/[format " " and formatSexpr y for y in rest x])
+ and (y:= LASTATOM x => format " . "
+ and formatSexpr y; true) and format "_)"
+
+formatCAPSULE ['CAPSULE,:l,x] ==
+ $insideCAPSULE: local := true
+ try formatBlock(l,x) or formatPiles(l,x) or spillLine() and formatBlock(l,x)
+
+formatPAREN [.,:argl] == formatFunctionCallTail argl
+
+formatSEQ ["SEQ",:l,[.,.,x]] ==
+ try formatBlock(l,x) or formatPiles(l,x) or spillLine() and formatBlock(l,x)
+
+--======================================================================
+-- Comment Handlers
+--======================================================================
+formatCOMMENT ["COMMENT",x,marg,startXY,endXY,commentStack] ==
+ $commentsToPrint:= [[marg,startXY,endXY,commentStack],:$commentsToPrint]
+ format x
+
+formatComments(u,op,types) ==
+ $numberOfSpills :local := $commentIndentation/2 - 1
+ not $insideEXPORTS => u
+ alist := LASSOC(op,$comments) or
+ sayBrightly ['"No documentation for ",op]
+ return u
+ ftypes := SUBLISLIS($FormalMapVariableList,rest $form,types)
+ consComments(LASSOC(ftypes,alist),'"++ ")
+ u
+
+consComments(s,plusPlus) ==
+ s is [word,:r] and null atom r => consComments(r, plusPlus)
+ s := first s
+ null s => nil
+ s := consCommentsTran s
+ indent() and newLine() or return nil
+ columnsLeft := $lineLength - $m - 2
+ while (m := MAXINDEX s) >= columnsLeft repeat
+ k := or/[i for i in (columnsLeft - 1)..1 by -1 | s.i = $charBlank]
+ k := (k => k + 1; columnsLeft)
+ piece := SUBSTRING(s,0,k)
+ formatDoCommentLine [plusPlus,piece]
+ s := SUBSTRING(s,k,nil)
+ formatDoCommentLine [plusPlus,s]
+ undent()
+ $m
+
+consCommentsTran s ==
+ m := MAXINDEX s
+ k := or/[i for i in 0..(m - 7) | substring?('"\spad{",s,i)] =>
+ r := charPosition(char '_},s,k + 6)
+ r = m + 1 => s
+ STRCONC(SUBSTRING(s,0,k),'"`",SUBSTRING(s,k+6,r-k-6),'"'",consCommentsTran SUBSTRING(s,r+1,nil))
+ s
+
+formatDoCommentLine line ==
+ $lineBuffer := consLineBuffer [nBlanks $c,:line]
+ $c := $m+2*$numberOfSpills
+
+--======================================================================
+-- Pile Handlers
+--======================================================================
+formatPreferPile y ==
+ y is ["SEQ",:l,[.,.,x]] =>
+ (u:= formatPiles(l,x)) => u
+ formatSpill("format",y)
+ formatSpill("format",y)
+
+formatPiles(l,x) ==
+ $insideTypeExpression : local := false
+ not $pilesAreOkHere => nil
+ originalC:= $c
+ lines:= [:l,x]
+ --piles must begin at margin
+ originalC=$m or indent() and newLine() or return nil
+ null (formatPileLine($m,first lines,false)) => nil
+ not (and/[formatPileLine($m,y,true) for y in rest lines]) => nil
+ (originalC=$m or undent()) and originalC --==> brace
+
+formatPileLine($m,x,newLineIfTrue) ==
+ if newLineIfTrue then newLine() or return nil
+ $numberOfSpills: local:= 0
+ $newLineWritten := nil
+ format x and (x is ['SIGNATURE,:.] or $rightBraceFlag => $c; formatSC())
+ and (x is ['DEF,:.] and optNewLine() or $c)
+
+--======================================================================
+-- Utility Functions
+--======================================================================
+nBlanks m == "STRCONC"/[char('_ ) for i in 1..m]
+
+isNewspadOperator op == GET(op,"Led") or GET(op,"Nud")
+
+isTrue x == x="true" or x is '(QUOTE T)
+
+nary2Binary(u,op) ==
+ u is [a,b,:t] => (t => nary2Binary([[op,a,b],:t],op); [op,a,b])
+ errhuh()
+
+string2PrintImage s ==
+ u:= GETSTR (2*SIZE s)
+ for i in 0..MAXINDEX s repeat
+ (if MEMQ(s.i,'(_( _{ _) _} _! _")) then
+ SUFFIX('__,u); u:= SUFFIX(s.i,u))
+ u
+
+ident2PrintImage s ==
+ m := MAXINDEX s
+ if m > 1 and s.(m - 1) = $underScore then s := STRCONC(SUBSTRING(s,0,m-1),s.m)
+ u:= GETSTR (2*SIZE s)
+ if not (ALPHA_-CHAR_-P s.(0) or s.(0)=char '"$") then SUFFIX('__,u)
+ u:= SUFFIX(s.(0),u)
+ for i in 1..MAXINDEX s repeat
+ if not (DIGITP s.i or ALPHA_-CHAR_-P s.i or ((c := s.i) = char '?)
+ or (c = char '_!)) then SUFFIX('__,u)
+ u:= SUFFIX(s.i,u)
+ INTERN u
+
+isIdentifier x ==
+ IDENTP x =>
+ s:= PNAME x
+ #s = 0 => nil
+ ALPHA_-CHAR_-P s.(0) => and/[s.i^=char '" " for i in 1..MAXINDEX s]
+ #s>1 =>
+ or/[ALPHA_-CHAR_-P s.i for i in 1..(m:= MAXINDEX s)] =>
+ and/[s.i^=char '" " for i in 1..m] => true
+
+isGensym x ==
+ s := STRINGIMAGE x
+ n := MAXINDEX s
+ s.0 = char '_G and and/[DIGITP s.i for i in 1..n]
+
+--======================================================================
+-- Macro Helpers
+--======================================================================
+tryToFit(s,x) ==
+--% try to format on current line; see macro try in file PSPADAUX LISP
+ --returns nil if unable to format stuff in x on a single line
+ x => ($back:= rest $back; $c)
+ restoreState()
+ nil
+
+restoreState(:options) ==
+ back := IFCAR options or $back
+ [
+ [$lineBuffer, $lineFragmentBuffer,$comments,$marginStack,$braceStack,$DEFdepth,
+ $bc,$c,$m,$commentsToPrint,$numberOfSpills,flags], :back]
+ := back
+ if null options then $back := back
+ [$newLineWritten, $autoLine, $rightBraceFlag,
+ $semicolonFlag,$insideDEF,$insideTypeExpression,$pilesAreOkHere,
+ $insideEXPORTS, $insideCAPSULE, $insideCategoryIfTrue,
+ $doNotResetMarginIfTrue,$noColonDeclaration]
+ := flags
+ nil
+
+saveState(:options) ==
+ flags :=
+ [$newLineWritten, $autoLine, $rightBraceFlag,
+ $semicolonFlag,$insideDEF,$insideTypeExpression,$pilesAreOkHere,
+ $insideEXPORTS, $insideCAPSULE, $insideCategoryIfTrue,
+ $doNotResetMarginIfTrue,$noColonDeclaration]
+ newState :=
+ [
+ [$lineBuffer, $lineFragmentBuffer,$comments,$marginStack,$braceStack,$DEFdepth,
+ $bc,$c,$m,$commentsToPrint,$numberOfSpills,flags], :$back]
+ if not KAR options then $back := newState
+ newState
+
+formatSC() ==
+ $pileStyle or $semicolonFlag => $c
+ format "; "
+
+wrapBraces(x,y,z) == y
+
+formatLB() ==
+ $pileStyle => $c
+ $numberOfSpills :=
+ $c > $lineLength / 2 => $braceIndentation/3 - 1
+ $braceIndentation/2 - 1
+ format "{"
+
+restoreC() == --used by macro "embrace"
+ originalC := CAR $braceStack
+ $braceStack := CDR $braceStack
+ formatRB originalC
+
+saveC() == --used by macro "embrace"
+ $braceStack := [$c,:$braceStack]
+
+saveD() == --used by macro "embrace"
+ $braceStack := [$c,:$braceStack]
+
+restoreD() == --used by macro "indentNB"
+ originalC := CAR $braceStack
+ $braceStack := CDR $braceStack
+ originalC
+
+formatRB(originalC) == --called only by restoreC
+ while $marginStack and $m > originalC repeat undent()
+ if $m < originalC then $marginStack := [originalC,:$marginStack]
+ $m := originalC
+ $pileStyle => $m
+ newLine() and format "}" and $m --==> brace
+
+@
+\eject
+\begin{thebibliography}{99}
+\bibitem{1} nothing
+\end{thebibliography}
+\end{document}