aboutsummaryrefslogtreecommitdiff
path: root/src/interp/c-doc.boot.pamphlet
diff options
context:
space:
mode:
authordos-reis <gdr@axiomatics.org>2007-09-20 03:47:46 +0000
committerdos-reis <gdr@axiomatics.org>2007-09-20 03:47:46 +0000
commit9b71e0a1f285fc207709cf8e90721160af299127 (patch)
tree3e64539a50da8370ac70d3556a34b4ddb67627bc /src/interp/c-doc.boot.pamphlet
parenta0ea803003aecec7b3dfa8a0c1126fc439519d8f (diff)
downloadopen-axiom-9b71e0a1f285fc207709cf8e90721160af299127.tar.gz
remove pamphlets - part 3
Diffstat (limited to 'src/interp/c-doc.boot.pamphlet')
-rw-r--r--src/interp/c-doc.boot.pamphlet1298
1 files changed, 0 insertions, 1298 deletions
diff --git a/src/interp/c-doc.boot.pamphlet b/src/interp/c-doc.boot.pamphlet
deleted file mode 100644
index d1d0949c..00000000
--- a/src/interp/c-doc.boot.pamphlet
+++ /dev/null
@@ -1,1298 +0,0 @@
-\documentclass{article}
-\usepackage{axiom}
-
-\title{\File{src/interp/c-doc.boot} Pamphlet}
-\author{The Axiom Team}
-
-\begin{document}
-\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>>
-
-batchExecute() ==
- _/RF_-1 '(GENCON INPUT)
-
-getDoc(conName,op,modemap) ==
- [dc,target,sl,pred,D] := simplifyModemap modemap
- sig := [target,:sl]
- null atom dc =>
- sig := SUBST('$,dc,sig)
- sig := SUBLISLIS($FormalMapVariableList,rest dc,sig)
- getDocForDomain(conName,op,sig)
- if argList := IFCDR getOfCategoryArgument pred then
- SUBLISLIS($FormalMapArgumentList,argList,sig)
- sig := SUBST('$,dc,sig)
- getDocForCategory(conName,op,sig)
-
-getOfCategoryArgument pred ==
- pred is [fn,:.] and MEMQ(fn,'(AND OR NOT)) =>
- or/[getOfCategoryArgument x for x in rest pred]
- pred is ['ofCategory,'_*1,form] => form
- nil
-
-getDocForCategory(name,op,sig) ==
- getOpDoc(constructor? name,op,sig) or
- or/[getOpDoc(constructor? x,op,sig) for x in whatCatCategories name]
-
-getDocForDomain(name,op,sig) ==
- getOpDoc(constructor? name,op,sig) or
- or/[getOpDoc(constructor? x,op,sig) for x in whatCatExtDom name]
-
-getOpDoc(abb,op,:sigPart) ==
- u := LASSOC(op,GETDATABASE(abb,'DOCUMENTATION))
- $argList : local := $FormalMapVariableList
- _$: local := '_$
- sigPart is [sig] => or/[d for [s,:d] in u | sig = s]
- u
-
-readForDoc fn ==
- $bootStrapMode: local:= true
- _/RQ_-LIB_-1 [fn,'SPAD]
-
-recordSignatureDocumentation(opSig,lineno) ==
- recordDocumentation(rest postTransform opSig,lineno)
-
-recordAttributeDocumentation(['Attribute,att],lineno) ==
- name := opOf att
- UPPER_-CASE_-P (PNAME name).0 => nil
- recordDocumentation([name,['attribute,:IFCDR postTransform att]],lineno)
-
-recordDocumentation(key,lineno) ==
- recordHeaderDocumentation lineno
- u:= collectComBlock lineno
- --record NIL to mean "there was no documentation"
- $maxSignatureLineNumber := lineno
- $docList := [[key,:u],:$docList]
- -- leave CAR of $docList alone as required by collectAndDeleteAssoc
-
-recordHeaderDocumentation lineno ==
- if $maxSignatureLineNumber = 0 then
- al := [p for (p := [n,:u]) in $COMBLOCKLIST
- | NULL n or NULL lineno or n < lineno]
- $COMBLOCKLIST := SETDIFFERENCE($COMBLOCKLIST,al)
- $headerDocumentation := ASSOCRIGHT al
- if $headerDocumentation then $maxSignatureLineNumber := 1 --see postDef
- $headerDocumentation
-
-collectComBlock x ==
- $COMBLOCKLIST is [[=x,:val],:.] =>
- u := [:val,:collectAndDeleteAssoc x]
- $COMBLOCKLIST := rest $COMBLOCKLIST
- u
- collectAndDeleteAssoc x
-
-collectAndDeleteAssoc x ==
---u is (.. (x . a) .. (x . b) .. ) ==> (a b ..) deleting entries from u
---assumes that the first element is useless
- for y in tails $COMBLOCKLIST | (s := rest y) repeat
- while s and first s is [=x,:r] repeat
- res := [:res,:r]
- s := rest s
- RPLACD(y,s)
- res
-
-finalizeDocumentation() ==
- unusedCommentLineNumbers := [x for (x := [n,:r]) in $COMBLOCKLIST | r]
- docList := SUBST("$","%",transDocList($op,$docList))
- if u := [sig for [sig,:doc] in docList | null doc] then
- for y in u repeat
- y = 'constructor => noHeading := true
- y is [x,b] and b is [='attribute,:r] =>
- attributes := [[x,:r],:attributes]
- signatures := [y,:signatures]
- name := CAR $lisplibForm
- if noHeading or signatures or attributes or unusedCommentLineNumbers then
- sayKeyedMsg("S2CD0001",NIL)
- bigcnt := 1
- if noHeading or signatures or attributes then
- sayKeyedMsg("S2CD0002",[STRCONC(STRINGIMAGE bigcnt,'"."),name])
- bigcnt := bigcnt + 1
- litcnt := 1
- if noHeading then
- sayKeyedMsg("S2CD0003",
- [STRCONC('"(",STRINGIMAGE litcnt,'")"),name])
- litcnt := litcnt + 1
- if signatures then
- sayKeyedMsg("S2CD0004",
- [STRCONC('"(",STRINGIMAGE litcnt,'")")])
- litcnt := litcnt + 1
- for [op,sig] in signatures repeat
- s := formatOpSignature(op,sig)
- sayMSG
- atom s => ['%x9,s]
- ['%x9,:s]
- if attributes then
- sayKeyedMsg("S2CD0005",
- [STRCONC('"(",STRINGIMAGE litcnt,'")")])
- litcnt := litcnt + 1
- for x in attributes repeat
- a := form2String x
- sayMSG
- atom a => ['%x9,a]
- ['%x9,:a]
- if unusedCommentLineNumbers then
- sayKeyedMsg("S2CD0006",[STRCONC(STRINGIMAGE bigcnt,'"."),name])
- for [n,r] in unusedCommentLineNumbers repeat
- sayMSG ['" ",:bright n,'" ",r]
- hn [[:fn(sig,$e),:doc] for [sig,:doc] in docList] where
- fn(x,e) ==
- atom x => [x,nil]
- if #x > 2 then x := TAKE(2,x)
- SUBLISLIS($FormalMapVariableList,rest $lisplibForm,
- macroExpand(x,e))
- hn u ==
- -- ((op,sig,doc), ...) --> ((op ((sig doc) ...)) ...)
- opList := REMDUP ASSOCLEFT u
- [[op,:[[sig,doc] for [op1,sig,doc] in u | op = op1]] for op in opList]
-
---=======================================================================
--- Transformation of ++ comments
---=======================================================================
-transDocList($constructorName,doclist) == --returns ((key line)...)
---called ONLY by finalizeDocumentation
---if $exposeFlag then messages go to file $outStream; flag=nil by default
- sayBrightly ['" Processing ",$constructorName,'" for Browser database:"]
- commentList := transDoc($constructorName,doclist)
- acc := nil
- for entry in commentList repeat
- entry is ['constructor,x] =>
- conEntry => checkDocError ['"Spurious comments: ",x]
- conEntry := entry
- acc := [entry,:acc]
- conEntry => [conEntry,:acc]
- checkDocError1 ['"Missing Description"]
- acc
-
-transDoc(conname,doclist) ==
---$exposeFlag and not isExposedConstructor conname => nil
---skip over unexposed constructors when checking system files
- $x: local
- rlist := REVERSE doclist
- for [$x,:lines] in rlist repeat
- $attribute? : local := $x is [.,[key]] and key = 'attribute
- null lines =>
- $attribute? => nil
- checkDocError1 ['"Not documented!!!!"]
- u := checkTrim($x,(STRINGP lines => [lines]; $x = 'constructor => first lines; lines))
- $argl : local := nil --set by checkGetArgs
--- tpd: related domain information doesn't exist
--- if v := checkExtract('"Related Domains:",u) then
--- $lisplibRelatedDomains:=[w for x in gn(v) | w := fn(x)] where
--- gn(v) == --note: unabbrev checks for correct number of arguments
--- s := checkExtractItemList v
--- parse := ncParseFromString s --is a single conform or a tuple
--- null parse => nil
--- parse is ['Tuple,:r] => r
--- [parse]
--- fn(x) ==
--- expectedNumOfArgs := checkNumOfArgs x
--- null expectedNumOfArgs =>
--- checkDocError ['"Unknown constructor name?: ",opOf x]
--- x
--- expectedNumOfArgs ^= (n := #(IFCDR x)) =>
--- n = 0 => checkDocError1
--- ['"You must give arguments to the _"Related Domain_": ",x]
--- checkDocError
--- ['"_"Related Domain_" has wrong number of arguments: ",x]
--- nil
--- n=0 and atom x => [x]
--- x
- longline :=
- $x = 'constructor =>
- v :=checkExtract('"Description:",u) or u and
- checkExtract('"Description:",
- [STRCONC('"Description: ",first u),:rest u])
- transformAndRecheckComments('constructor,v or u)
- transformAndRecheckComments($x,u)
- acc := [[$x,longline],:acc] --processor assumes a list of lines
- NREVERSE acc
-
-checkExtractItemList l == --items are separated by commas or end of line
- acc := nil --l is list of remaining lines
- while l repeat --stop when you get to a line with a colon
- m := MAXINDEX first l
- k := charPosition(char '_:,first l,0)
- k <= m => return nil
- acc := [first l,:acc]
- l := rest l
- "STRCONC"/[x for x in NREVERSE acc]
-
---NREVERSE("append"/[fn string for string in acc]) where
--- fn(string) ==
--- m := MAXINDEX string
--- acc := nil
--- i := 0
--- while i < m and (k := charPosition(char '_,,string,i)) < m repeat
--- if (t := trimString SUBSTRING(string,i,k-i)) ^= '"" then acc := [t,:acc]
--- i := k + 1
--- if i < m then
--- if (t := trimString SUBSTRING(string,i,k-i)) ^= '"" then acc := [t,:acc]
--- acc
-
-transformAndRecheckComments(name,lines) ==
- $checkingXmptex? := false
- $x : local := name
- $name : local := 'GlossaryPage
- $origin : local := 'gloss
- $recheckingFlag : local := false
- $exposeFlagHeading : local := ['"--------",name,'"---------"]
- if null $exposeFlag then sayBrightly $exposeFlagHeading
- u := checkComments(name,lines)
- $recheckingFlag := true
- checkRewrite(name,[u])
- $recheckingFlag := false
- u
-
-checkRewrite(name,lines) == main where --similar to checkComments from c-doc
- main ==
- $checkErrorFlag: local := true
- margin := 0
- lines := checkRemoveComments lines
- u := lines
- if $checkingXmptex? then
- u := [checkAddIndented(x,margin) for x in u]
- $argl := checkGetArgs first u --set $argl
- u2 := nil
- verbatim := nil
- for x in u repeat
- w := newString2Words x
- verbatim =>
- w and first w = '"\end{verbatim}" =>
- verbatim := false
- u2 := append(u2, w)
- u2 := append(u2, [x])
- w and first w = '"\begin{verbatim}" =>
- verbatim := true
- u2 := append(u2, w)
- u2 := append(u2, w)
- u := u2
- u := checkAddSpaces u
- u := checkSplit2Words u
- u := checkAddMacros u
- u := checkTexht u
--- checkBalance u
- okBefore := null $checkErrorFlag
- checkArguments u
- if $checkErrorFlag then u := checkFixCommonProblem u
- checkRecordHash u
--- u := checkTranVerbatim u
- checkDecorateForHt u
-
-checkTexht u ==
- count := 0
- acc := nil
- while u repeat
- x := first u
- if x = '"\texht" and (u := IFCDR u) then
- if not (IFCAR u = $charLbrace) then
- checkDocError '"First left brace after \texht missing"
- count := 1 -- drop first argument including braces of \texht
- while ((y := IFCAR (u := rest u))^= $charRbrace or count > 1) repeat
- if y = $charLbrace then count := count + 1
- if y = $charRbrace then count := count - 1
- x := IFCAR (u := rest u) -- drop first right brace of 1st arg
- if x = '"\httex" and (u := IFCDR u) and (IFCAR u = $charLbrace) then
- acc := [IFCAR u,:acc] --left brace: add it
- while (y := IFCAR (u := rest u)) ^= $charRbrace repeat (acc := [y,:acc])
- acc := [IFCAR u,:acc] --right brace: add it
- x := IFCAR (u := rest u) --left brace: forget it
- while IFCAR (u := rest u) ^= $charRbrace repeat 'skip
- x := IFCAR (u := rest u) --forget right brace: move to next char
- acc := [x,:acc]
- u := rest u
- NREVERSE acc
-
-checkRecordHash u ==
- while u repeat
- x := first u
- if STRINGP x and x.0 = $charBack then
- if member(x,$HTlinks) and (u := checkLookForLeftBrace IFCDR u)
- and (u := checkLookForRightBrace IFCDR u)
- and (u := checkLookForLeftBrace IFCDR u) and (u := IFCDR u) then
- htname := intern IFCAR u
- entry := HGET($htHash,htname) or [nil]
- HPUT($htHash,htname,[first entry,:[[$name,:$origin],:rest entry]])
- else if member(x,$HTlisplinks) and (u := checkLookForLeftBrace IFCDR u)
- and (u := checkLookForRightBrace IFCDR u)
- and (u := checkLookForLeftBrace IFCDR u) and (u := IFCDR u) then
- htname := intern checkGetLispFunctionName checkGetStringBeforeRightBrace u
- entry := HGET($lispHash,htname) or [nil]
- HPUT($lispHash,htname,[first entry,:[[$name,:$origin],:rest entry]])
- else if ((p := member(x,'("\gloss" "\spadglos")))
- or (q := member(x,'("\glossSee" "\spadglosSee"))))
- and (u := checkLookForLeftBrace IFCDR u)
- and (u := IFCDR u) then
- if q then
- u := checkLookForRightBrace u
- u := checkLookForLeftBrace IFCDR u
- u := IFCDR u
- htname := intern checkGetStringBeforeRightBrace u
- entry := HGET($glossHash,htname) or [nil]
- HPUT($glossHash,htname,[first entry,:[[$name,:$origin],:rest entry]])
- else if x = '"\spadsys" and (u := checkLookForLeftBrace IFCDR u) and (u := IFCDR u) then
- s := checkGetStringBeforeRightBrace u
- if s.0 = char '_) then s := SUBSTRING(s,1,nil)
- parse := checkGetParse s
- null parse => checkDocError ['"Unparseable \spadtype: ",s]
- not member(opOf parse,$currentSysList) =>
- checkDocError ['"Bad system command: ",s]
- atom parse or not (parse is ['set,arg]) => 'ok ---assume ok
- not spadSysChoose($setOptions,arg) =>
- checkDocError ['"Incorrect \spadsys: ",s]
- entry := HGET($sysHash,htname) or [nil]
- HPUT($sysHash,htname,[first entry,:[[$name,:$origin],:rest entry]])
- else if x = '"\spadtype" and (u := checkLookForLeftBrace IFCDR u) and (u := IFCDR u) then
- s := checkGetStringBeforeRightBrace u
- parse := checkGetParse s
- null parse => checkDocError ['"Unparseable \spadtype: ",s]
- n := checkNumOfArgs parse
- null n => checkDocError ['"Unknown \spadtype: ", s]
- atom parse and n > 0 => 'skip
- null (key := checkIsValidType parse) =>
- checkDocError ['"Unknown \spadtype: ", s]
- atom key => 'ok
- checkDocError ['"Wrong number of arguments: ",form2HtString key]
- else if member(x,'("\spadop" "\keyword")) and (u := checkLookForLeftBrace IFCDR u) and (u := IFCDR u) then
- x := intern checkGetStringBeforeRightBrace u
- not (GET(x,'Led) or GET(x,'Nud)) =>
- checkDocError ['"Unknown \spadop: ",x]
- u := rest u
- 'done
-
-checkGetParse s == ncParseFromString removeBackslashes s
-
-removeBackslashes s ==
- s = '"" => '""
- (k := charPosition($charBack,s,0)) < #s =>
- k = 0 => removeBackslashes SUBSTRING(s,1,nil)
- STRCONC(SUBSTRING(s,0,k),removeBackslashes SUBSTRING(s,k + 1,nil))
- s
-
-checkNumOfArgs conform ==
- conname := opOf conform
- constructor? conname or (conname := abbreviation? conname) =>
- #GETDATABASE(conname,'CONSTRUCTORARGS)
- nil --signals error
-
-checkIsValidType form == main where
---returns ok if correct, form is wrong number of arguments, nil if unknown
- main ==
- atom form => 'ok
- [op,:args] := form
- conname := (constructor? op => op; abbreviation? op)
- null conname => nil
- fn(form,GETDATABASE(conname,'COSIG))
- fn(form,coSig) ==
- #form ^= #coSig => form
- or/[null checkIsValidType x for x in rest form for flag in rest coSig | flag]
- => nil
- 'ok
-
-checkGetLispFunctionName s ==
- n := #s
- (k := charPosition(char '_|,s,1)) and k < n and
- (j := charPosition(char '_|,s,k + 1)) and j < n => SUBSTRING(s,k + 1,j-k-1)
- checkDocError ['"Ill-formed lisp expression : ",s]
- 'illformed
-
-checkGetStringBeforeRightBrace u ==
- acc := nil
- while u repeat
- x := first u
- x = $charRbrace => return "STRCONC"/(NREVERSE acc)
- acc := [x,:acc]
- u := rest u
-
--- checkTranVerbatim u ==
--- acc := nil
--- while u repeat
--- x := first u
--- x = '"\begin" and checkTranVerbatimMiddle u is [middle,:r] =>
--- acc := [$charRbrace,:middle,$charLbrace,'"\spadpaste",:acc]
--- u := r
--- if x = '"\spadcommand" then x := '"\spadpaste"
--- acc := [x,:acc]
--- u := rest u
--- NREVERSE acc
---
--- checkTranVerbatimMiddle u ==
--- (y := IFCAR (v := IFCDR u)) = $charLbrace and
--- (y := IFCAR (v := IFCDR v)) = '"verbatim" and
--- (y := IFCAR (v := IFCDR v)) = $charRbrace =>
--- w := IFCDR v
--- middle := nil
--- while w and (z := first w) ^= '"\end" repeat
--- middle := [z,:middle]
--- w := rest w
--- if (y := IFCAR (w := IFCDR w)) = $charLbrace and
--- (y := IFCAR (w := IFCDR w)) = '"verbatim" and
--- (y := IFCAR (w := IFCDR w)) = $charRbrace then
--- u := IFCDR w
--- else
--- checkDocError '"Missing \end{verbatim}"
--- u := w
--- [middle,:u]
---
--- checkTranVerbatim1 u ==
--- acc := nil
--- while u repeat
--- x := first u
--- x = '"\begin" and (y := IFCAR (v := IFCDR u)) = $charLbrace and
--- (y := IFCAR (v := IFCDR v)) = '"verbatim" and
--- (y := IFCAR (v := IFCDR v)) = $charRbrace =>
--- w := IFCDR v
--- middle := nil
--- while w and (z := first w) ^= '"\end" repeat
--- middle := [z,:middle]
--- w := rest w
--- if (y := IFCAR (w := IFCDR w)) = $charLbrace and
--- (y := IFCAR (w := IFCDR w)) = '"verbatim" and
--- (y := IFCAR (w := IFCDR w)) = $charRbrace then
--- u := IFCDR w
--- acc := [$charRbrace,:middle,$charLbrace,'"\spadpaste",:acc]
--- if x = '"\spadcommand" then x := '"\spadpaste"
--- acc := [x,:acc]
--- u := rest u
--- NREVERSE acc
-
-appendOver [head,:tail] ==
- acc := LASTNODE head
- for x in tail repeat
- end := LASTNODE x
- RPLACD(acc,x)
- acc := end
- head
-
-checkRemoveComments lines ==
- while lines repeat
- do
- line := checkTrimCommented first lines
- if firstNonBlankPosition line >= 0 then acc := [line,:acc]
- lines := rest lines
- NREVERSE acc
-
-checkTrimCommented line ==
- n := #line
- k := htcharPosition(char '_%,line,0)
- --line beginning with % is a comment
- k = 0 => '""
- --remarks beginning with %% are comments
- k >= n - 1 or line.(k + 1) ^= char '_% => line
- k < #line => SUBSTRING(line,0,k)
- line
-
-htcharPosition(char,line,i) ==
- m := #line
- k := charPosition(char,line,i)
- k = m => k
- k > 0 =>
- line.(k - 1) ^= $charBack => k
- htcharPosition(char,line,k + 1)
- 0
-
-checkAddMacros u ==
- acc := nil
- verbatim := false
- while u repeat
- x := first u
- acc :=
- x = '"\end{verbatim}" =>
- verbatim := false
- [x, :acc]
- verbatim => [x, :acc]
- x = '"\begin{verbatim}" =>
- verbatim := true
- [x, :acc]
- y := LASSOC(x,$HTmacs) => [:y,:acc]
- [x,:acc]
- u := rest u
- NREVERSE acc
-
-checkComments(nameSig,lines) == main where
- main ==
- $checkErrorFlag: local := false
- margin := checkGetMargin lines
- if (null BOUNDP '$attribute? or null $attribute?)
- and nameSig ^= 'constructor then lines :=
- [checkTransformFirsts(first nameSig,first lines,margin),:rest lines]
- u := checkIndentedLines(lines, margin)
- $argl := checkGetArgs first u --set $argl
- u2 := nil
- verbatim := nil
- for x in u repeat
- w := newString2Words x
- verbatim =>
- w and first w = '"\end{verbatim}" =>
- verbatim := false
- u2 := append(u2, w)
- u2 := append(u2, [x])
- w and first w = '"\begin{verbatim}" =>
- verbatim := true
- u2 := append(u2, w)
- u2 := append(u2, w)
- u := u2
- u := checkAddSpaces u
- u := checkIeEg u
- u := checkSplit2Words u
- checkBalance u
- okBefore := null $checkErrorFlag
- checkArguments u
- if $checkErrorFlag then u := checkFixCommonProblem u
- v := checkDecorate u
- res := "STRCONC"/[y for y in v]
- res := checkAddPeriod res
- if $checkErrorFlag then pp res
- res
-
-checkIndentedLines(u, margin) ==
- verbatim := false
- u2 := nil
- for x in u repeat
- k := firstNonBlankPosition x
- k = -1 =>
- verbatim => u2 := [:u2, $charFauxNewline]
- u2 := [:u2, '"\blankline "]
- s := SUBSTRING(x, k, nil)
- s = '"\begin{verbatim}" =>
- verbatim := true
- u2 := [:u2, s]
- s = '"\end{verbatim}" =>
- verbatim := false
- u2 := [:u2, s]
- verbatim => u2 := [:u2, SUBSTRING(x, margin, nil)]
- margin = k => u2 := [:u2, s]
- u2 := [:u2, STRCONC('"\indented{",STRINGIMAGE(k-margin),'"}{",checkAddSpaceSegments(s,0),'"}")]
- u2
-
-newString2Words l ==
- not STRINGP l => [l]
- m := MAXINDEX l
- m = -1 => NIL
- i := 0
- [w while newWordFrom(l,i,m) is [w,i]]
-
-newWordFrom(l,i,m) ==
- while i <= m and l.i = " " repeat i := i + 1
- i > m => NIL
- buf := '""
- ch := l.i
- ch = $charFauxNewline => [$stringFauxNewline, i+ 1]
- done := false
- while i <= m and not done repeat
- ch := l.i
- ch = $charBlank or ch = $charFauxNewline => done := true
- buf := STRCONC(buf,ch)
- i := i + 1
- [buf,i]
-
-checkAddPeriod s == --No, just leave blank at the end (rdj: 10/18/91)
- m := MAXINDEX s
- lastChar := s . m
- lastChar = char '_! or lastChar = char '_? or lastChar = char '_. => s
- lastChar = char '_, or lastChar = char '_; =>
- s . m := (char '_.)
- s
- s
-
-checkGetArgs u ==
- NOT STRINGP u => nil
- m := MAXINDEX u
- k := firstNonBlankPosition(u)
- k > 0 => checkGetArgs SUBSTRING(u,k,nil)
- stringPrefix?('"\spad{",u) =>
- k := getMatchingRightPren(u,6,char '_{,char '_}) or m
- checkGetArgs SUBSTRING(u,6,k-6)
- (i := charPosition(char '_(,u,0)) > m => nil
- (u . m) ^= char '_) => nil
- while (k := charPosition($charComma,u,i + 1)) < m repeat
- acc := [trimString SUBSTRING(u,i + 1,k - i - 1),:acc]
- i := k
- NREVERSE [SUBSTRING(u,i + 1,m - i - 1),:acc]
-
-checkGetMargin lines ==
- while lines repeat
- do
- x := first lines
- k := firstNonBlankPosition x
- k = -1 => nil
- margin := (margin => MIN(margin,k); k)
- lines := rest lines
- margin or 0
-
-firstNonBlankPosition(x,:options) ==
- start := IFCAR options or 0
- k := -1
- for i in start..MAXINDEX x repeat
- if x.i ^= $charBlank then return (k := i)
- k
-
-checkAddIndented(x,margin) ==
- k := firstNonBlankPosition x
- k = -1 => '"\blankline "
- margin = k => x
- STRCONC('"\indented{",STRINGIMAGE(k-margin),'"}{",checkAddSpaceSegments(SUBSTRING(x,k,nil),0),'"}")
-
-checkAddSpaceSegments(u,k) ==
- m := MAXINDEX u
- i := charPosition($charBlank,u,k)
- m < i => u
- j := i
- while (j := j + 1) < m and u.j = (char '_ ) repeat 'continue
- n := j - i --number of blanks
- n > 1 => STRCONC(SUBSTRING(u,0,i),'"\space{",
- STRINGIMAGE n,'"}",checkAddSpaceSegments(SUBSTRING(u,i + n,nil),0))
- checkAddSpaceSegments(u,j)
-
-checkTrim($x,lines) == main where
- main ==
- s := [wherePP first lines]
- for x in rest lines repeat
- j := wherePP x
- if not MEMQ(j,s) then
- checkDocError [$x,'" has varying indentation levels"]
- s := [j,:s]
- [trim y for y in lines]
- wherePP(u) ==
- k := charPosition($charPlus,u,0)
- k = #u or charPosition($charPlus,u,k + 1) ^= k + 1 =>
- systemError '" Improper comment found"
- k
- trim(s) ==
- k := wherePP(s)
- return SUBSTRING(s,k + 2,nil)
- m := MAXINDEX s
- n := k + 2
- for j in (k + 2)..m while s.j = $charBlank repeat (n := n + 1)
- SUBSTRING(s,n,nil)
-
-checkExtract(header,lines) ==
- while lines repeat
- line := first lines
- k := firstNonBlankPosition line --k gives margin of Description:
- substring?(header,line,k) => return nil
- lines := rest lines
- null lines => nil
- u := first lines
- j := charPosition(char '_:,u,k)
- margin := k
- firstLines :=
- (k := firstNonBlankPosition(u,j + 1)) ^= -1 =>
- [SUBSTRING(u,j + 1,nil),:rest lines]
- rest lines
- --now look for another header; if found skip all rest of these lines
- acc := nil
- for line in firstLines repeat
- do
- m := #line
- (k := firstNonBlankPosition line) = -1 => 'skip --include if blank
- k > margin => 'skip --include if idented
- not UPPER_-CASE_-P line.k => 'skip --also if not upcased
- (j := charPosition(char '_:,line,k)) = m => 'skip --or if not colon, or
- (i := charPosition(char '_ ,line,k+1)) < j => 'skip --blank before colon
- return nil
- acc := [line,:acc]
- NREVERSE acc
-
-checkFixCommonProblem u ==
- acc := nil
- while u repeat
- x := first u
- x = $charLbrace and member(next := IFCAR rest u,$HTspadmacros) and
- (IFCAR IFCDR rest u ^= $charLbrace) =>
- checkDocError ['"Reversing ",next,'" and left brace"]
- acc := [$charLbrace,next,:acc] --reverse order of brace and command
- u := rest rest u
- acc := [x,:acc]
- u := rest u
- NREVERSE acc
-
-checkDecorate u ==
- count := 0
- spadflag := false --means OK to wrap single letter words with \s{}
- mathSymbolsOk := false
- acc := nil
- verbatim := false
- while u repeat
- x := first u
-
- if not verbatim then
- if x = '"\em" then
- if count > 0 then
- mathSymbolsOk := count - 1
- spadflag := count - 1
- else checkDocError ['"\em must be enclosed in braces"]
- if member(x,'("\spadpaste" "\spad" "\spadop")) then mathSymbolsOk := count
- if member(x,'("\s" "\spadtype" "\spadsys" "\example" "\andexample" "\spadop" "\spad" "\spadignore" "\spadpaste" "\spadcommand" "\footnote")) then spadflag := count
- else if x = $charLbrace then
- count := count + 1
- else if x = $charRbrace then
- count := count - 1
- if mathSymbolsOk = count then mathSymbolsOk := false
- if spadflag = count then spadflag := false
- else if not mathSymbolsOk and member(x,'("+" "*" "=" "==" "->")) then
- if $checkingXmptex? then
- checkDocError ["Symbol ",x,'" appearing outside \spad{}"]
-
- acc :=
- x = '"\end{verbatim}" =>
- verbatim := false
- [x, :acc]
- verbatim => [x, :acc]
- x = '"\begin{verbatim}" =>
- verbatim := true
- [x, :acc]
-
- x = '"\begin" and first (v := IFCDR u) = $charLbrace and
- first (v := IFCDR v) = '"detail" and first (v := IFCDR v) = $charRbrace
- =>
- u := v
- ['"\blankline ",:acc]
- x = '"\end" and first (v := IFCDR u) = $charLbrace and
- first (v := IFCDR v) = '"detail" and first (v := IFCDR v) = $charRbrace
- =>
- u := v
- acc
- x = char '_$ or x = '"$" => ['"\$",:acc]
- x = char '_% or x = '"%" => ['"\%",:acc]
- x = char '_, or x = '"," => ['",{}",:acc]
- x = '"\spad" => ['"\spad",:acc]
- STRINGP x and DIGITP x.0 => [x,:acc]
- null spadflag and
- (CHARP x and ALPHA_-CHAR_-P x and not MEMQ(x,$charExclusions) or
- member(x,$argl)) => [$charRbrace,x,$charLbrace,'"\spad",:acc]
- null spadflag and ((STRINGP x and not x.0 = $charBack and DIGITP(x.(MAXINDEX x))) or member(x,'("true" "false"))) =>
- [$charRbrace,x,$charLbrace,'"\spad",:acc] --wrap x1, alpha3, etc
- xcount := #x
- xcount = 3 and x.1 = char 't and x.2 = char 'h =>
- ['"th",$charRbrace,x.0,$charLbrace,'"\spad",:acc]
- xcount = 4 and x.1 = char '_- and x.2 = char 't and x.3 = char 'h =>
- ['"-th",$charRbrace,x.0,$charLbrace,'"\spad",:acc]
- xcount = 2 and x.1 = char 'i or --wrap ei, xi, hi
- null spadflag and xcount > 0 and xcount < 4 and not member(x,'("th" "rd" "st")) and
- hasNoVowels x => --wrap words with no vowels
- [$charRbrace,x,$charLbrace,'"\spad",:acc]
- [checkAddBackSlashes x,:acc]
- u := rest u
- NREVERSE acc
-
-hasNoVowels x ==
- max := MAXINDEX x
- x.max = char 'y => false
- and/[not isVowel(x.i) for i in 0..max]
-
-isVowel c ==
- EQ(c,char 'a) or EQ(c,char 'e) or EQ(c,char 'i) or EQ(c,char 'o) or EQ(c,char 'u) or
- EQ(c,char 'A) or EQ(c,char 'E) or EQ(c,char 'I) or EQ(c,char 'O) or EQ(c,char 'U)
-
-
-checkAddBackSlashes s ==
- (CHARP s and (c := s)) or (#s = 1 and (c := s.0)) =>
- MEMQ(s,$charEscapeList) => STRCONC($charBack,c)
- s
- k := 0
- m := MAXINDEX s
- insertIndex := nil
- while k <= m repeat
- do
- char := s.k
- char = $charBack => k := k + 2
- MEMQ(char,$charEscapeList) => return (insertIndex := k)
- k := k + 1
- insertIndex => checkAddBackSlashes STRCONC(SUBSTRING(s,0,insertIndex),$charBack,s.k,SUBSTRING(s,insertIndex + 1,nil))
- s
-
-checkAddSpaces u ==
- null u => nil
- null rest u => u
- space := $charBlank
- u2 := nil
- for i in 1.. for f in u repeat
- -- want newlines before and after begin/end verbatim and between lines
- -- since this might be written to a file, we can't really use
- -- newline characters. The Browser and HD will do the translation
- -- later.
- if f = '"\begin{verbatim}" then
- space := $charFauxNewline
- if null u2 then u2 := [space]
-
- if i > 1 then u2 := [:u2, space, f]
- else u2 := [:u2, f]
-
- if f = '"\end{verbatim}" then
- u2 := [:u2, space]
- space := $charBlank
- u2
-
-checkIeEg u ==
- acc := nil
- verbatim := false
- while u repeat
- x := first u
- acc :=
- x = '"\end{verbatim}" =>
- verbatim := false
- [x, :acc]
- verbatim => [x, :acc]
- x = '"\begin{verbatim}" =>
- verbatim := true
- [x, :acc]
- z := checkIeEgfun x => [:NREVERSE z,:acc]
- [x,:acc]
- u := rest u
- NREVERSE acc
-
-checkIeEgfun x ==
- CHARP x => nil
- x = '"" => nil
- m := MAXINDEX x
- for k in 0..(m - 3) repeat
- x.(k + 1) = $charPeriod and x.(k + 3) = $charPeriod and
- (x.k = char 'i and x.(k + 2) = char 'e and (key := '"that is")
- or x.k = char 'e and x.(k + 2) = char 'g and (key := '"for example")) =>
- firstPart := (k > 0 => [SUBSTRING(x,0,k)]; nil)
- result := [:firstPart,'"\spadignore{",SUBSTRING(x,k,4),'"}",
- :checkIeEgfun SUBSTRING(x,k+4,nil)]
- result
-
-checkSplit2Words u ==
- acc := nil
- while u repeat
- x := first u
- acc :=
- x = '"\end{verbatim}" =>
- verbatim := false
- [x, :acc]
- verbatim => [x, :acc]
- x = '"\begin{verbatim}" =>
- verbatim := true
- [x, :acc]
- z := checkSplitBrace x => [:NREVERSE z,:acc]
- [x,:acc]
- u := rest u
- NREVERSE acc
-
-checkSplitBrace x ==
- CHARP x => [x]
- #x = 1 => [x.0]
- (u := checkSplitBackslash x)
- and rest u => "append"/[checkSplitBrace y for y in u]
- m := MAXINDEX x
- (u := checkSplitOn x)
- and rest u => "append"/[checkSplitBrace y for y in u]
- (u := checkSplitPunctuation x)
- and rest u => "append"/[checkSplitBrace y for y in u]
- [x]
-
-checkSplitBackslash x ==
- not STRINGP x => [x]
- m := MAXINDEX x
- (k := charPosition($charBack,x,0)) < m =>
- m = 1 or ALPHA_-CHAR_-P(x . (k + 1)) => --starts with a backslash so..
- (k := charPosition($charBack,x,1)) < m => --..see if there is another
- [SUBSTRING(x,0,k),:checkSplitBackslash SUBSTRING(x,k,nil)] -- yup
- [x] --no, just return line
- k = 0 => --starts with backspace but x.1 is not a letter; break it up
- [SUBSTRING(x,0,2),:checkSplitBackslash SUBSTRING(x,2,nil)]
- u := SUBSTRING(x,0,k)
- v := SUBSTRING(x,k,2)
- k + 1 = m => [u,v]
- [u,v,:checkSplitBackslash SUBSTRING(x,k + 2,nil)]
- [x]
-
-checkSplitPunctuation x ==
- CHARP x => [x]
- m := MAXINDEX x
- m < 1 => [x]
- lastchar := x.m
- lastchar = $charPeriod and x.(m - 1) = $charPeriod =>
- m = 1 => [x]
- m > 3 and x.(m-2) = $charPeriod =>
- [:checkSplitPunctuation SUBSTRING(x,0,m-2),'"..."]
- [:checkSplitPunctuation SUBSTRING(x,0,m-1),'".."]
- lastchar = $charPeriod or lastchar = $charSemiColon or lastchar = $charComma
- => [SUBSTRING(x,0,m),lastchar]
- m > 1 and x.(m - 1) = $charQuote => [SUBSTRING(x,0,m - 1),SUBSTRING(x,m-1,nil)]
- (k := charPosition($charBack,x,0)) < m =>
- k = 0 =>
- m = 1 or HGET($htMacroTable,x) or ALPHA_-CHAR_-P x.1 => [x]
- v := SUBSTRING(x,2,nil)
- [SUBSTRING(x,0,2),:checkSplitPunctuation v]
- u := SUBSTRING(x,0,k)
- v := SUBSTRING(x,k,nil)
- [:checkSplitPunctuation u,:checkSplitPunctuation v]
- (k := charPosition($charDash,x,1)) < m =>
- u := SUBSTRING(x,k + 1,nil)
- [SUBSTRING(x,0,k),$charDash,:checkSplitPunctuation u]
- [x]
-
-checkSplitOn(x) ==
- CHARP x => [x]
- l := $charSplitList
- m := MAXINDEX x
- while l repeat
- char := first l
- do
- m = 0 and x.0 = char => return (k := -1) --special exit
- k := charPosition(char,x,0)
- k > 0 and x.(k - 1) = $charBack => [x]
- k <= m => return k
- l := rest l
- null l => [x]
- k = -1 => [char]
- k = 0 => [char,SUBSTRING(x,1,nil)]
- k = MAXINDEX x => [SUBSTRING(x,0,k),char]
- [SUBSTRING(x,0,k),char,:checkSplitOn SUBSTRING(x,k + 1,nil)]
-
-
-checkBalance u ==
- checkBeginEnd u
- stack := nil
- while u repeat
- do
- x := first u
- openClose := ASSOC(x,$checkPrenAlist) --is it an open bracket?
- => stack := [CAR openClose,:stack] --yes, push the open bracket
- open := rassoc(x,$checkPrenAlist) => --it is a close bracket!
- stack is [top,:restStack] => --does corresponding open bracket match?
- if open ^= top then --yes: just pop the stack
- checkDocError
- ['"Mismatch: left ",checkSayBracket top,'" matches right ",checkSayBracket open]
- stack := restStack
- checkDocError ['"Missing left ",checkSayBracket open]
- u := rest u
- if stack then
- for x in NREVERSE stack repeat
- checkDocError ['"Missing right ",checkSayBracket x]
- u
-
-checkSayBracket x ==
- x = char '_( or x = char '_) => '"pren"
- x = char '_{ or x = char '_} => '"brace"
- '"bracket"
-
-checkBeginEnd u ==
- beginEndStack := nil
- while u repeat
- IDENTITY
- x := first u
- STRINGP x and x.0 = $charBack and #x > 2 and not HGET($htMacroTable,x)
- and not (x = '"\spadignore") and IFCAR IFCDR u = $charLbrace
- and not
- (substring?('"\radiobox",x,0) or substring?('"\inputbox",x,0))=>
- --allow 0 argument guys to pass through
- checkDocError ["Unexpected HT command: ",x]
- x = '"\beginitems" =>
- beginEndStack := ["items",:beginEndStack]
- x = '"\begin" =>
- u is [.,=$charLbrace,y,:r] and CAR r = $charRbrace =>
- if not member(y,$beginEndList) then
- checkDocError ['"Unknown begin type: \begin{",y,'"}"]
- beginEndStack := [y,:beginEndStack]
- u := r
- checkDocError ['"Improper \begin command"]
- x = '"\item" =>
- member(IFCAR beginEndStack,'("items" "menu")) => nil
- null beginEndStack =>
- checkDocError ['"\item appears outside a \begin-\end"]
- checkDocError ['"\item appears within a \begin{",IFCAR beginEndStack,'"}.."]
- x = '"\end" =>
- u is [.,=$charLbrace,y,:r] and CAR r = $charRbrace =>
- y = IFCAR beginEndStack =>
- beginEndStack := rest beginEndStack
- u := r
- checkDocError ['"Trying to match \begin{",IFCAR beginEndStack,'"} with \end{",y,"}"]
- checkDocError ['"Improper \end command"]
- u := rest u
- beginEndStack => checkDocError ['"Missing \end{",first beginEndStack,'"}"]
- 'ok
-
-checkArguments u ==
- while u repeat
- do
- x := first u
- null (k := HGET($htMacroTable,x)) => 'skip
- k = 0 => 'skip
- k > 0 => checkHTargs(x,rest u,k,nil)
- checkHTargs(x,rest u,-k,true)
- u := rest u
- u
-
-checkHTargs(keyword,u,nargs,integerValue?) ==
---u should start with an open brace ...
- nargs = 0 => 'ok
- if not (u := checkLookForLeftBrace u) then
- return checkDocError ['"Missing argument for ",keyword]
- if not (u := checkLookForRightBrace IFCDR u) then
- return checkDocError ['"Missing right brace for ",keyword]
- checkHTargs(keyword,rest u,nargs - 1,integerValue?)
-
-checkLookForLeftBrace(u) == --return line beginning with left brace
- while u repeat
- x := first u
- if x = $charLbrace then return u
- x ^= $charBlank => return nil
- u := rest u
- u
-
-checkLookForRightBrace(u) == --return line beginning with right brace
- count := 0
- while u repeat
- x := first u
- do
- x = $charRbrace =>
- count = 0 => return (found := u)
- count := count - 1
- x = $charLbrace => count := count + 1
- u := rest u
- found
-
-checkInteger s ==
- CHARP s => false
- s = '"" => false
- and/[DIGIT_-CHAR_-P s.i for i in 0..MAXINDEX s]
-
-checkTransformFirsts(opname,u,margin) ==
---case 1: \spad{...
---case 2: form(args)
---case 3: form arg
---case 4: op arg
---case 5: arg op arg
- namestring := PNAME opname
- if namestring = '"Zero" then namestring := '"0"
- else if namestring = '"One" then namestring := '"1"
- margin > 0 =>
- s := leftTrim u
- STRCONC(fillerSpaces margin,checkTransformFirsts(opname,s,0))
- m := MAXINDEX u
- m < 2 => u
- u.0 = $charBack => u
- ALPHA_-CHAR_-P u.0 =>
- i := checkSkipToken(u,0,m) or return u
- j := checkSkipBlanks(u,i,m) or return u
- open := u.j
- open = char '_[ and (close := char '_]) or
- open = char '_( and (close := char '_)) =>
- k := getMatchingRightPren(u,j + 1,open,close)
- namestring ^= (firstWord := SUBSTRING(u,0,i)) =>
- checkDocError ['"Improper first word in comments: ",firstWord]
- u
- null k =>
- if open = char '_[
- then checkDocError ['"Missing close bracket on first line: ", u]
- else checkDocError ['"Missing close parenthesis on first line: ", u]
- u
- STRCONC('"\spad{",SUBSTRING(u,0,k + 1),'"}",SUBSTRING(u,k + 1,nil))
- k := checkSkipToken(u,j,m) or return u
- infixOp := INTERN SUBSTRING(u,j,k - j)
- not GET(infixOp,'Led) => --case 3
- namestring ^= (firstWord := SUBSTRING(u,0,i)) =>
- checkDocError ['"Improper first word in comments: ",firstWord]
- u
- #(p := PNAME infixOp) = 1 and (open := p.0) and
- (close := LASSOC(open,$checkPrenAlist)) => --have an open bracket
- l := getMatchingRightPren(u,k + 1,open,close)
- if l > MAXINDEX u then l := k - 1
- STRCONC('"\spad{",SUBSTRING(u,0,l + 1),'"}",SUBSTRING(u,l + 1,nil))
- STRCONC('"\spad{",SUBSTRING(u,0,k),'"}",SUBSTRING(u,k,nil))
- l := checkSkipBlanks(u,k,m) or return u
- n := checkSkipToken(u,l,m) or return u
- namestring ^= PNAME infixOp =>
- checkDocError ['"Improper initial operator in comments: ",infixOp]
- u
- STRCONC('"\spad{",SUBSTRING(u,0,n),'"}",SUBSTRING(u,n,nil)) --case 5
- true => -- not ALPHA_-CHAR_-P u.0 =>
- i := checkSkipToken(u,0,m) or return u
- namestring ^= (firstWord := SUBSTRING(u,0,i)) =>
- checkDocError ['"Improper first word in comments: ",firstWord]
- u
- prefixOp := INTERN SUBSTRING(u,0,i)
- not GET(prefixOp,'Nud) =>
- u ---what could this be?
- j := checkSkipBlanks(u,i,m) or return u
- u.j = char '_( => --case 4
- j := getMatchingRightPren(u,j + 1,char '_(,char '_))
- j > m => u
- STRCONC('"\spad{",SUBSTRING(u,0,j + 1),'"}",SUBSTRING(u,j + 1,nil))
- k := checkSkipToken(u,j,m) or return u
- namestring ^= (firstWord := SUBSTRING(u,0,i)) =>
- checkDocError ['"Improper first word in comments: ",firstWord]
- u
- STRCONC('"\spad{",SUBSTRING(u,0,k),'"}",SUBSTRING(u,k,nil))
-
-getMatchingRightPren(u,j,open,close) ==
- count := 0
- m := MAXINDEX u
- for i in j..m repeat
- c := u . i
- do
- c = close =>
- count = 0 => return (found := i)
- count := count - 1
- c = open => count := count + 1
- found
-
-checkSkipBlanks(u,i,m) ==
- while i < m and u.i = $charBlank repeat i := i + 1
- i = m => nil
- i
-
-checkSkipToken(u,i,m) ==
- ALPHA_-CHAR_-P(u.i) => checkSkipIdentifierToken(u,i,m)
- checkSkipOpToken(u,i,m)
-
-checkSkipOpToken(u,i,m) ==
- while i < m and
- (not(checkAlphabetic(u.i)) and not(member(u.i,$charDelimiters))) repeat
- i := i + 1
- i = m => nil
- i
-
-checkSkipIdentifierToken(u,i,m) ==
- while i < m and checkAlphabetic u.i repeat i := i + 1
- i = m => nil
- i
-
-checkAlphabetic c ==
- ALPHA_-CHAR_-P c or DIGITP c or MEMQ(c,$charIdentifierEndings)
-
---=======================================================================
--- Code for creating a personalized report for ++ comments
---=======================================================================
-docreport(nam) ==
---creates a report for person "nam" using file "whofiles"
- OBEY '"rm docreport.input"
- OBEY STRCONC('"echo _")bo setOutStream('",STRINGIMAGE nam,'")_" > temp.input")
- OBEY '"cat docreport.header temp.input > docreport.input"
- OBEY STRCONC('"awk '/",STRINGIMAGE nam,'"/ {printf(_")co %s.spad\n_",$2)}' whofiles > temp.input")
- OBEY '"cat docreport.input temp.input > temp1.input"
- OBEY '"cat temp1.input docreport.trailer > docreport.input"
- OBEY '"rm temp.input"
- OBEY '"rm temp1.input"
- SETQ(_/EDITFILE,'"docreport.input")
- _/RQ()
-
-setOutStream nam ==
- filename := STRCONC('"/tmp/",STRINGIMAGE nam,".docreport")
- $outStream := MAKE_-OUTSTREAM filename
-
-whoOwns(con) ==
- null $exposeFlag => nil
---con=constructor name (id beginning with a capital), returns owner as a string
- filename := GETDATABASE(con,'SOURCEFILE)
- quoteChar := char '_"
- OBEY STRCONC('"awk '$2 == ",quoteChar,filename,quoteChar,'" {print $1}' whofiles > /tmp/temp")
- instream := MAKE_-INSTREAM '"/tmp/temp"
- value :=
- EOFP instream => nil
- READLINE instream
- SHUT instream
- value
-
---=======================================================================
--- Report Documentation Error
---=======================================================================
-checkDocError1 u ==
---when compiling for documentation, ignore certain errors
- BOUNDP '$compileDocumentation and $compileDocumentation => nil
- checkDocError u
-
-checkDocError u ==
- $checkErrorFlag := true
- msg :=
- $recheckingFlag =>
- $constructorName => checkDocMessage u
- concat('"> ",u)
- $constructorName => checkDocMessage u
- u
- if $exposeFlag and $exposeFlagHeading then
- SAYBRIGHTLY1($exposeFlagHeading,$outStream)
- sayBrightly $exposeFlagHeading
- $exposeFlagHeading := nil
- sayBrightly msg
- if $exposeFlag then SAYBRIGHTLY1(msg,$outStream)
- --if called by checkDocFile (see file checkdoc.boot)
-
-checkDocMessage u ==
- sourcefile := GETDATABASE($constructorName,'SOURCEFILE)
- person := whoOwns $constructorName or '"---"
- middle :=
- BOUNDP '$x => ['"(",$x,'"): "]
- ['": "]
- concat(person,'">",sourcefile,'"-->",$constructorName,middle,u)
-
-checkDecorateForHt u ==
- count := 0
- spadflag := false --means OK to wrap single letter words with \s{}
- while u repeat
- x := first u
- do
- if x = '"\em" then
- if count > 0 then spadflag := count - 1
- else checkDocError ['"\em must be enclosed in braces"]
- if member(x,'("\s" "\spadop" "\spadtype" "\spad" "\spadpaste" "\spadcommand" "\footnote")) then spadflag := count
- else if x = $charLbrace then count := count + 1
- else if x = $charRbrace then
- count := count - 1
- if spadflag = count then spadflag := false
- else if not spadflag and member(x,'("+" "*" "=" "==" "->")) then
- if $checkingXmptex? then
- checkDocError ["Symbol ",x,'" appearing outside \spad{}"]
- x = '"$" or x = '"%" => checkDocError ['"Unescaped ",x]
--- null spadflag and STRINGP x and (member(x,$argl) or #x = 1
--- and ALPHA_-CHAR_-P x.0) and not member(x,'("a" "A")) =>
--- checkDocError1 ['"Naked ",x]
--- null spadflag and STRINGP x and (not x.0 = $charBack and not DIGITP(x.0) and DIGITP(x.(MAXINDEX x))or member(x,'("true" "false")))
--- => checkDocError1 ["Naked ",x]
- u := rest u
- u
-
-
-
-
-@
-\eject
-\begin{thebibliography}{99}
-\bibitem{1} nothing
-\end{thebibliography}
-\end{document}