diff --git a/changelog b/changelog index 689fe8d..be4066a 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +20090827 tpd src/axiom-website/patches.html 20090827.02.tpd.patch +20090827 tpd src/interp/Makefile move c-doc.boot to c-doc.lisp +20090827 tpd src/interp/c-doc.lisp added, rewritten from c-doc.boot +20090827 tpd src/interp/c-doc.boot removed, rewritten to c-doc.lisp 20090827 tpd src/axiom-website/patches.html 20090827.01.tpd.patch 20090827 tpd src/interp/Makefile move fortcall.boot to fortcall.lisp 20090827 tpd src/interp/fortcall.lisp added, rewritten from fortcall.boot diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 550dbb6..24b1e12 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -1912,5 +1912,7 @@ template.lisp rewrite from boot to lisp
termrw.lisp rewrite from boot to lisp
20090827.01.tpd.patch fortcall.lisp rewrite from boot to lisp
+20090827.02.tpd.patch +c-doc.lisp rewrite from boot to lisp
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index 1d9fa16..1f8aace 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -2344,51 +2344,26 @@ ${MID}/cattable.lisp: ${IN}/cattable.lisp.pamphlet @ -\subsection{c-doc.boot \cite{60}} -<>= -${AUTO}/c-doc.${O}: ${OUT}/c-doc.${O} - @ echo 217 making ${AUTO}/c-doc.${O} from ${OUT}/c-doc.${O} - @ cp ${OUT}/c-doc.${O} ${AUTO} - -@ +\subsection{c-doc.lisp} <>= -${OUT}/c-doc.${O}: ${MID}/c-doc.clisp - @ echo 218 making ${OUT}/c-doc.${O} from ${MID}/c-doc.clisp - @ (cd ${MID} ; \ +${OUT}/c-doc.${O}: ${MID}/c-doc.lisp + @ echo 136 making ${OUT}/c-doc.${O} from ${MID}/c-doc.lisp + @ ( cd ${MID} ; \ if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/c-doc.clisp"' \ + echo '(progn (compile-file "${MID}/c-doc.lisp"' \ ':output-file "${OUT}/c-doc.${O}") (${BYE}))' | ${DEPSYS} ; \ else \ - echo '(progn (compile-file "${MID}/c-doc.clisp"' \ + echo '(progn (compile-file "${MID}/c-doc.lisp"' \ ':output-file "${OUT}/c-doc.${O}") (${BYE}))' | ${DEPSYS} \ >${TMP}/trace ; \ fi ) @ -<>= -${MID}/c-doc.clisp: ${IN}/c-doc.boot.pamphlet - @ echo 219 making ${MID}/c-doc.clisp from ${IN}/c-doc.boot.pamphlet +<>= +${MID}/c-doc.lisp: ${IN}/c-doc.lisp.pamphlet + @ echo 137 making ${MID}/c-doc.lisp from ${IN}/c-doc.lisp.pamphlet @ (cd ${MID} ; \ - ${TANGLE} ${IN}/c-doc.boot.pamphlet >c-doc.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "c-doc.boot") (${BYE}))' \ - | ${DEPSYS} ; \ - else \ - echo '(progn (boottran::boottocl "c-doc.boot") (${BYE}))' \ - | ${DEPSYS} >${TMP}/trace ; \ - fi ; \ - rm c-doc.boot ) - -@ -<>= -${DOC}/c-doc.boot.dvi: ${IN}/c-doc.boot.pamphlet - @echo 220 making ${DOC}/c-doc.boot.dvi from ${IN}/c-doc.boot.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/c-doc.boot.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} c-doc.boot ; \ - rm -f ${DOC}/c-doc.boot.pamphlet ; \ - rm -f ${DOC}/c-doc.boot.tex ; \ - rm -f ${DOC}/c-doc.boot ) + ${TANGLE} ${IN}/c-doc.lisp.pamphlet >c-doc.lisp ) @ @@ -5493,10 +5468,8 @@ clean: <> <> -<> <> -<> -<> +<> <> <> @@ -6018,7 +5991,6 @@ pp \bibitem{56} {\bf \$SPAD/src/interp/nag-f07.boot.pamphlet} \bibitem{57} {\bf \$SPAD/src/interp/nag-s.boot.pamphlet} \bibitem{58} {\bf \$SPAD/src/interp/category.boot.pamphlet} -\bibitem{60} {\bf \$SPAD/src/interp/c-doc.boot.pamphlet} \bibitem{64} {\bf \$SPAD/src/interp/compiler.boot.pamphlet} \end{thebibliography} \end{document} diff --git a/src/interp/c-doc.boot.pamphlet b/src/interp/c-doc.boot.pamphlet deleted file mode 100644 index 6e1c7ee..0000000 --- a/src/interp/c-doc.boot.pamphlet +++ /dev/null @@ -1,1294 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp c-doc.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{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. - -@ -<<*>>= -<> - -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 := nil - 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} diff --git a/src/interp/c-doc.lisp.pamphlet b/src/interp/c-doc.lisp.pamphlet new file mode 100644 index 0000000..9188631 --- /dev/null +++ b/src/interp/c-doc.lisp.pamphlet @@ -0,0 +1,4319 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp c-doc.lisp} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +@ +<<*>>= + +(IN-PACKAGE "BOOT" ) + +;batchExecute() == +; _/RF_-1 '(GENCON INPUT) + +(DEFUN |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) + +(DEFUN |getDoc| (|conName| |op| |modemap|) + (PROG (|LETTMP#1| |dc| |target| |sl| |pred| D |argList| |sig|) + (RETURN + (PROGN + (SPADLET |LETTMP#1| (|simplifyModemap| |modemap|)) + (SPADLET |dc| (CAR |LETTMP#1|)) + (SPADLET |target| (CADR |LETTMP#1|)) + (SPADLET |sl| (CADDR |LETTMP#1|)) + (SPADLET |pred| (CADDDR |LETTMP#1|)) + (SPADLET D (CAR (CDDDDR |LETTMP#1|))) + (SPADLET |sig| (CONS |target| |sl|)) + (COND + ((NULL (ATOM |dc|)) (SPADLET |sig| (MSUBST '$ |dc| |sig|)) + (SPADLET |sig| + (SUBLISLIS |$FormalMapVariableList| (CDR |dc|) + |sig|)) + (|getDocForDomain| |conName| |op| |sig|)) + ('T + (COND + ((SPADLET |argList| + (IFCDR (|getOfCategoryArgument| |pred|))) + (SUBLISLIS |$FormalMapArgumentList| |argList| |sig|))) + (SPADLET |sig| (MSUBST '$ |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 + +(DEFUN |getOfCategoryArgument| (|pred|) + (PROG (|fn| |ISTMP#1| |ISTMP#2| |form|) + (RETURN + (SEQ (COND + ((AND (PAIRP |pred|) + (PROGN (SPADLET |fn| (QCAR |pred|)) 'T) + (MEMQ |fn| '(AND OR NOT))) + (PROG (G166100) + (SPADLET G166100 NIL) + (RETURN + (DO ((G166106 NIL G166100) + (G166107 (CDR |pred|) (CDR G166107)) + (|x| NIL)) + ((OR G166106 (ATOM G166107) + (PROGN (SETQ |x| (CAR G166107)) NIL)) + G166100) + (SEQ (EXIT (SETQ G166100 + (OR G166100 + (|getOfCategoryArgument| |x|))))))))) + ((AND (PAIRP |pred|) (EQ (QCAR |pred|) '|ofCategory|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |pred|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) '*1) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |form| (QCAR |ISTMP#2|)) + 'T)))))) + |form|) + ('T NIL)))))) + +;getDocForCategory(name,op,sig) == +; getOpDoc(constructor? name,op,sig) or +; or/[getOpDoc(constructor? x,op,sig) for x in whatCatCategories name] + +(DEFUN |getDocForCategory| (|name| |op| |sig|) + (PROG () + (RETURN + (SEQ (OR (|getOpDoc| (|constructor?| |name|) |op| |sig|) + (PROG (G166122) + (SPADLET G166122 NIL) + (RETURN + (DO ((G166128 NIL G166122) + (G166129 (|whatCatCategories| |name|) + (CDR G166129)) + (|x| NIL)) + ((OR G166128 (ATOM G166129) + (PROGN (SETQ |x| (CAR G166129)) NIL)) + G166122) + (SEQ (EXIT (SETQ G166122 + (OR G166122 + (|getOpDoc| (|constructor?| |x|) + |op| |sig|))))))))))))) + +;getDocForDomain(name,op,sig) == +; getOpDoc(constructor? name,op,sig) or +; or/[getOpDoc(constructor? x,op,sig) for x in whatCatExtDom name] + +(DEFUN |getDocForDomain| (|name| |op| |sig|) + (PROG () + (RETURN + (SEQ (OR (|getOpDoc| (|constructor?| |name|) |op| |sig|) + (PROG (G166140) + (SPADLET G166140 NIL) + (RETURN + (DO ((G166146 NIL G166140) + (G166147 (|whatCatExtDom| |name|) + (CDR G166147)) + (|x| NIL)) + ((OR G166146 (ATOM G166147) + (PROGN (SETQ |x| (CAR G166147)) NIL)) + G166140) + (SEQ (EXIT (SETQ G166140 + (OR G166140 + (|getOpDoc| (|constructor?| |x|) + |op| |sig|))))))))))))) + +;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 + +(DEFUN |getOpDoc| (&REST G166194 &AUX |sigPart| |op| |abb|) + (DSETQ (|abb| |op| . |sigPart|) G166194) + (PROG (|$argList| $ |u| |sig| |s| |d|) + (DECLARE (SPECIAL |$argList| $)) + (RETURN + (SEQ (PROGN + (SPADLET |u| + (LASSOC |op| (GETDATABASE |abb| 'DOCUMENTATION))) + (SPADLET |$argList| |$FormalMapVariableList|) + (SPADLET $ '$) + (COND + ((AND (PAIRP |sigPart|) (EQ (QCDR |sigPart|) NIL) + (PROGN (SPADLET |sig| (QCAR |sigPart|)) 'T)) + (PROG (G166163) + (SPADLET G166163 NIL) + (RETURN + (DO ((G166171 NIL G166163) + (G166172 |u| (CDR G166172)) + (G166158 NIL)) + ((OR G166171 (ATOM G166172) + (PROGN + (SETQ G166158 (CAR G166172)) + NIL) + (PROGN + (PROGN + (SPADLET |s| (CAR G166158)) + (SPADLET |d| (CDR G166158)) + G166158) + NIL)) + G166163) + (SEQ (EXIT (COND + ((BOOT-EQUAL |sig| |s|) + (SETQ G166163 (OR G166163 |d|)))))))))) + ('T |u|))))))) + +;readForDoc fn == +; $bootStrapMode: local:= true +; _/RQ_-LIB_-1 [fn,'SPAD] + +(DEFUN |readForDoc| (|fn|) + (PROG (|$bootStrapMode|) + (DECLARE (SPECIAL |$bootStrapMode|)) + (RETURN + (PROGN + (SPADLET |$bootStrapMode| 'T) + (/RQ-LIB-1 (CONS |fn| (CONS 'SPAD NIL))))))) + +;recordSignatureDocumentation(opSig,lineno) == +; recordDocumentation(rest postTransform opSig,lineno) + +(DEFUN |recordSignatureDocumentation| (|opSig| |lineno|) + (|recordDocumentation| (CDR (|postTransform| |opSig|)) |lineno|)) + +;recordAttributeDocumentation(['Attribute,att],lineno) == +; name := opOf att +; UPPER_-CASE_-P (PNAME name).0 => nil +; recordDocumentation([name,['attribute,:IFCDR postTransform att]],lineno) + +(DEFUN |recordAttributeDocumentation| (G166206 |lineno|) + (PROG (|att| |name|) + (RETURN + (PROGN + (SPADLET |att| (CADR G166206)) + (SPADLET |name| (|opOf| |att|)) + (COND + ((UPPER-CASE-P (ELT (PNAME |name|) 0)) NIL) + ('T + (|recordDocumentation| + (CONS |name| + (CONS (CONS '|attribute| + (IFCDR (|postTransform| |att|))) + NIL)) + |lineno|))))))) + +;recordDocumentation(key,lineno) == +; recordHeaderDocumentation lineno +; u:= collectComBlock lineno +; --record NIL to mean "there was no documentation" +; $maxSignatureLineNumber := lineno +; $docList := [[key,:u],:$docList] + +(DEFUN |recordDocumentation| (|key| |lineno|) + (PROG (|u|) + (RETURN + (PROGN + (|recordHeaderDocumentation| |lineno|) + (SPADLET |u| (|collectComBlock| |lineno|)) + (SPADLET |$maxSignatureLineNumber| |lineno|) + (SPADLET |$docList| (CONS (CONS |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 + +(DEFUN |recordHeaderDocumentation| (|lineno|) + (PROG (|n| |u| |al|) + (RETURN + (SEQ (COND + ((EQL |$maxSignatureLineNumber| 0) + (SPADLET |al| + (PROG (G166235) + (SPADLET G166235 NIL) + (RETURN + (DO ((G166242 $COMBLOCKLIST + (CDR G166242)) + (|p| NIL)) + ((OR (ATOM G166242) + (PROGN + (SETQ |p| (CAR G166242)) + NIL) + (PROGN + (PROGN + (SPADLET |n| (CAR |p|)) + (SPADLET |u| (CDR |p|)) + |p|) + NIL)) + (NREVERSE0 G166235)) + (SEQ (EXIT (COND + ((OR (NULL |n|) + (NULL |lineno|) + (> |lineno| |n|)) + (SETQ G166235 + (CONS |p| G166235)))))))))) + (SPADLET $COMBLOCKLIST + (SETDIFFERENCE $COMBLOCKLIST |al|)) + (SPADLET |$headerDocumentation| (ASSOCRIGHT |al|)) + (COND + (|$headerDocumentation| + (SPADLET |$maxSignatureLineNumber| 1))) + |$headerDocumentation|) + ('T NIL)))))) + +;collectComBlock x == +; $COMBLOCKLIST is [[=x,:val],:.] => +; u := [:val,:collectAndDeleteAssoc x] +; $COMBLOCKLIST := rest $COMBLOCKLIST +; u +; collectAndDeleteAssoc x + +(DEFUN |collectComBlock| (|x|) + (PROG (|ISTMP#1| |val| |u|) + (RETURN + (COND + ((AND (PAIRP $COMBLOCKLIST) + (PROGN + (SPADLET |ISTMP#1| (QCAR $COMBLOCKLIST)) + (AND (PAIRP |ISTMP#1|) (EQUAL (QCAR |ISTMP#1|) |x|) + (PROGN (SPADLET |val| (QCDR |ISTMP#1|)) 'T)))) + (SPADLET |u| (APPEND |val| (|collectAndDeleteAssoc| |x|))) + (SPADLET $COMBLOCKLIST (CDR $COMBLOCKLIST)) |u|) + ('T (|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 + +(DEFUN |collectAndDeleteAssoc| (|x|) + (PROG (|ISTMP#1| |r| |res| |s|) + (RETURN + (SEQ (PROGN + (DO ((|y| $COMBLOCKLIST (CDR |y|))) ((ATOM |y|) NIL) + (SEQ (EXIT (COND + ((SPADLET |s| (CDR |y|)) + (DO () + ((NULL (AND |s| + (PROGN + (SPADLET |ISTMP#1| + (CAR |s|)) + (AND (PAIRP |ISTMP#1|) + (EQUAL (QCAR |ISTMP#1|) + |x|) + (PROGN + (SPADLET |r| + (QCDR |ISTMP#1|)) + 'T))))) + NIL) + (SEQ (EXIT + (PROGN + (SPADLET |res| + (APPEND |res| |r|)) + (SPADLET |s| (CDR |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] + +(DEFUN |finalizeDocumentation,hn| (|u|) + (PROG (|opList| |op1| |sig| |doc|) + (RETURN + (SEQ (SPADLET |opList| (REMDUP (ASSOCLEFT |u|))) + (EXIT (PROG (G166360) + (SPADLET G166360 NIL) + (RETURN + (DO ((G166369 |opList| (CDR G166369)) + (|op| NIL)) + ((OR (ATOM G166369) + (PROGN (SETQ |op| (CAR G166369)) NIL)) + (NREVERSE0 G166360)) + (SEQ (EXIT (SETQ G166360 + (CONS + (CONS |op| + (PROG (G166381) + (SPADLET G166381 NIL) + (RETURN + (DO + ((G166388 |u| + (CDR G166388)) + (G166346 NIL)) + ((OR (ATOM G166388) + (PROGN + (SETQ G166346 + (CAR G166388)) + NIL) + (PROGN + (PROGN + (SPADLET |op1| + (CAR G166346)) + (SPADLET |sig| + (CADR G166346)) + (SPADLET |doc| + (CADDR G166346)) + G166346) + NIL)) + (NREVERSE0 G166381)) + (SEQ + (EXIT + (COND + ((BOOT-EQUAL |op| + |op1|) + (SETQ G166381 + (CONS + (CONS |sig| + (CONS |doc| + NIL)) + G166381)))))))))) + G166360)))))))))))) + +(DEFUN |finalizeDocumentation,fn| (|x| |e|) + (SEQ (IF (ATOM |x|) (EXIT (CONS |x| (CONS NIL NIL)))) + (IF (> (|#| |x|) 2) (SPADLET |x| (TAKE 2 |x|)) NIL) + (EXIT (SUBLISLIS |$FormalMapVariableList| (CDR |$lisplibForm|) + (|macroExpand| |x| |e|))))) + +(DEFUN |finalizeDocumentation| () + (PROG (|unusedCommentLineNumbers| |docList| |u| |noHeading| |x| + |ISTMP#1| |b| |attributes| |signatures| |name| |bigcnt| + |op| |s| |litcnt| |a| |n| |r| |sig| |doc|) + (RETURN + (SEQ (PROGN + (SPADLET |unusedCommentLineNumbers| + (PROG (G166423) + (SPADLET G166423 NIL) + (RETURN + (DO ((G166430 $COMBLOCKLIST + (CDR G166430)) + (|x| NIL)) + ((OR (ATOM G166430) + (PROGN + (SETQ |x| (CAR G166430)) + NIL) + (PROGN + (PROGN + (SPADLET |n| (CAR |x|)) + (SPADLET |r| (CDR |x|)) + |x|) + NIL)) + (NREVERSE0 G166423)) + (SEQ (EXIT (COND + (|r| + (SETQ G166423 + (CONS |x| G166423)))))))))) + (SPADLET |docList| + (MSUBST '$ '% (|transDocList| |$op| |$docList|))) + (COND + ((SPADLET |u| + (PROG (G166443) + (SPADLET G166443 NIL) + (RETURN + (DO ((G166450 |docList| (CDR G166450)) + (G166312 NIL)) + ((OR (ATOM G166450) + (PROGN + (SETQ G166312 + (CAR G166450)) + NIL) + (PROGN + (PROGN + (SPADLET |sig| + (CAR G166312)) + (SPADLET |doc| + (CDR G166312)) + G166312) + NIL)) + (NREVERSE0 G166443)) + (SEQ (EXIT + (COND + ((NULL |doc|) + (SETQ G166443 + (CONS |sig| G166443)))))))))) + (DO ((G166467 |u| (CDR G166467)) (|y| NIL)) + ((OR (ATOM G166467) + (PROGN (SETQ |y| (CAR G166467)) NIL)) + NIL) + (SEQ (EXIT (COND + ((BOOT-EQUAL |y| '|constructor|) + (SPADLET |noHeading| 'T)) + ((AND (PAIRP |y|) + (PROGN + (SPADLET |x| (QCAR |y|)) + (SPADLET |ISTMP#1| (QCDR |y|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |b| + (QCAR |ISTMP#1|)) + 'T))) + (PAIRP |b|) + (EQUAL (QCAR |b|) '|attribute|) + (PROGN + (SPADLET |r| (QCDR |b|)) + 'T)) + (SPADLET |attributes| + (CONS (CONS |x| |r|) + |attributes|))) + ('T + (SPADLET |signatures| + (CONS |y| |signatures|))))))) + (SPADLET |name| (CAR |$lisplibForm|)) + (COND + ((OR |noHeading| |signatures| |attributes| + |unusedCommentLineNumbers|) + (|sayKeyedMsg| 'S2CD0001 NIL) (SPADLET |bigcnt| 1) + (COND + ((OR |noHeading| |signatures| |attributes|) + (|sayKeyedMsg| 'S2CD0002 + (CONS (STRCONC (STRINGIMAGE |bigcnt|) + (MAKESTRING ".")) + (CONS |name| NIL))) + (SPADLET |bigcnt| (PLUS |bigcnt| 1)) + (SPADLET |litcnt| 1) + (COND + (|noHeading| + (|sayKeyedMsg| 'S2CD0003 + (CONS (STRCONC (MAKESTRING "(") + (STRINGIMAGE |litcnt|) + (MAKESTRING ")")) + (CONS |name| NIL))) + (SPADLET |litcnt| (PLUS |litcnt| 1)))) + (COND + (|signatures| + (|sayKeyedMsg| 'S2CD0004 + (CONS (STRCONC (MAKESTRING "(") + (STRINGIMAGE |litcnt|) + (MAKESTRING ")")) + NIL)) + (SPADLET |litcnt| (PLUS |litcnt| 1)) + (DO ((G166479 |signatures| + (CDR G166479)) + (G166329 NIL)) + ((OR (ATOM G166479) + (PROGN + (SETQ G166329 (CAR G166479)) + NIL) + (PROGN + (PROGN + (SPADLET |op| (CAR G166329)) + (SPADLET |sig| + (CADR G166329)) + G166329) + NIL)) + NIL) + (SEQ (EXIT + (PROGN + (SPADLET |s| + (|formatOpSignature| |op| |sig|)) + (|sayMSG| + (COND + ((ATOM |s|) + (CONS '|%x9| (CONS |s| NIL))) + ('T (CONS '|%x9| |s|)))))))))) + (COND + (|attributes| + (|sayKeyedMsg| 'S2CD0005 + (CONS (STRCONC (MAKESTRING "(") + (STRINGIMAGE |litcnt|) + (MAKESTRING ")")) + NIL)) + (SPADLET |litcnt| (PLUS |litcnt| 1)) + (DO ((G166491 |attributes| + (CDR G166491)) + (|x| NIL)) + ((OR (ATOM G166491) + (PROGN + (SETQ |x| (CAR G166491)) + NIL)) + NIL) + (SEQ (EXIT + (PROGN + (SPADLET |a| (|form2String| |x|)) + (|sayMSG| + (COND + ((ATOM |a|) + (CONS '|%x9| (CONS |a| NIL))) + ('T (CONS '|%x9| |a|))))))))) + ('T NIL)))) + (COND + (|unusedCommentLineNumbers| + (|sayKeyedMsg| 'S2CD0006 + (CONS (STRCONC (STRINGIMAGE |bigcnt|) + (MAKESTRING ".")) + (CONS |name| NIL))) + (DO ((G166501 |unusedCommentLineNumbers| + (CDR G166501)) + (G166338 NIL)) + ((OR (ATOM G166501) + (PROGN + (SETQ G166338 (CAR G166501)) + NIL) + (PROGN + (PROGN + (SPADLET |n| (CAR G166338)) + (SPADLET |r| (CADR G166338)) + G166338) + NIL)) + NIL) + (SEQ (EXIT (|sayMSG| + (CONS (MAKESTRING " ") + (APPEND (|bright| |n|) + (CONS (MAKESTRING " ") + (CONS |r| NIL))))))))) + ('T NIL))) + ('T NIL)))) + (|finalizeDocumentation,hn| + (PROG (G166513) + (SPADLET G166513 NIL) + (RETURN + (DO ((G166519 |docList| (CDR G166519)) + (G166408 NIL)) + ((OR (ATOM G166519) + (PROGN + (SETQ G166408 (CAR G166519)) + NIL) + (PROGN + (PROGN + (SPADLET |sig| (CAR G166408)) + (SPADLET |doc| (CDR G166408)) + G166408) + NIL)) + (NREVERSE0 G166513)) + (SEQ (EXIT (SETQ G166513 + (CONS + (APPEND + (|finalizeDocumentation,fn| + |sig| |$e|) + |doc|) + G166513))))))))))))) + +;--======================================================================= +;-- 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 + +(DEFUN |transDocList| (|$constructorName| |doclist|) + (DECLARE (SPECIAL |$constructorName|)) + (PROG (|commentList| |ISTMP#1| |x| |conEntry| |acc|) + (RETURN + (SEQ (PROGN + (|sayBrightly| + (CONS (MAKESTRING " Processing ") + (CONS |$constructorName| + (CONS (MAKESTRING + " for Browser database:") + NIL)))) + (SPADLET |commentList| + (|transDoc| |$constructorName| |doclist|)) + (SPADLET |acc| NIL) + (DO ((G166575 |commentList| (CDR G166575)) + (|entry| NIL)) + ((OR (ATOM G166575) + (PROGN (SETQ |entry| (CAR G166575)) NIL)) + NIL) + (SEQ (EXIT (COND + ((AND (PAIRP |entry|) + (EQ (QCAR |entry|) '|constructor|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |entry|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |x| (QCAR |ISTMP#1|)) + 'T)))) + (COND + (|conEntry| + (|checkDocError| + (CONS + (MAKESTRING "Spurious comments: ") + (CONS |x| NIL)))) + ('T (SPADLET |conEntry| |entry|)))) + ('T (SPADLET |acc| (CONS |entry| |acc|))))))) + (COND + (|conEntry| (CONS |conEntry| |acc|)) + ('T + (|checkDocError1| + (CONS (MAKESTRING "Missing Description") NIL)) + |acc|))))))) + +;transDoc(conname,doclist) == +;--$exposeFlag and not isExposedConstructor conname => nil +;--skip over unexposed constructors when checking system files +; $x: local := nil +; 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 + +(DEFUN |transDoc| (|conname| |doclist|) + (PROG (|$x| |$attribute?| |$argl| |rlist| |lines| |ISTMP#1| |ISTMP#2| + |key| |u| |v| |longline| |acc|) + (DECLARE (SPECIAL |$x| |$attribute?| |$argl|)) + (RETURN + (SEQ (PROGN + (SPADLET |$x| NIL) + (SPADLET |rlist| (REVERSE |doclist|)) + (DO ((G166623 |rlist| (CDR G166623)) (G166606 NIL)) + ((OR (ATOM G166623) + (PROGN (SETQ G166606 (CAR G166623)) NIL) + (PROGN + (PROGN + (SPADLET |$x| (CAR G166606)) + (SPADLET |lines| (CDR G166606)) + G166606) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |$attribute?| + (AND (PAIRP |$x|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |$x|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |ISTMP#2| + (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |key| + (QCAR |ISTMP#2|)) + 'T))))) + (BOOT-EQUAL |key| '|attribute|))) + (COND + ((NULL |lines|) + (COND + (|$attribute?| NIL) + ('T + (|checkDocError1| + (CONS + (MAKESTRING + "Not documented!!!!") + NIL))))) + ('T + (SPADLET |u| + (|checkTrim| |$x| + (COND + ((STRINGP |lines|) + (CONS |lines| NIL)) + ((BOOT-EQUAL |$x| + '|constructor|) + (CAR |lines|)) + ('T |lines|)))) + (SPADLET |$argl| NIL) + (SPADLET |longline| + (COND + ((BOOT-EQUAL |$x| + '|constructor|) + (SPADLET |v| + (OR + (|checkExtract| + (MAKESTRING + "Description:") + |u|) + (AND |u| + (|checkExtract| + (MAKESTRING + "Description:") + (CONS + (STRCONC + (MAKESTRING + "Description: ") + (CAR |u|)) + (CDR |u|)))))) + (|transformAndRecheckComments| + '|constructor| + (OR |v| |u|))) + ('T + (|transformAndRecheckComments| + |$x| |u|)))) + (SPADLET |acc| + (CONS + (CONS |$x| + (CONS |longline| NIL)) + |acc|)))))))) + (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] + +(DEFUN |checkExtractItemList| (|l|) + (PROG (|m| |k| |acc|) + (RETURN + (SEQ (PROGN + (SPADLET |acc| NIL) + (DO () ((NULL |l|) NIL) + (SEQ (EXIT (PROGN + (SPADLET |m| (MAXINDEX (CAR |l|))) + (SPADLET |k| + (|charPosition| (|char| '|:|) + (CAR |l|) 0)) + (COND + ((<= |k| |m|) (RETURN NIL)) + ('T + (SPADLET |acc| (CONS (CAR |l|) |acc|)) + (SPADLET |l| (CDR |l|)))))))) + (PROG (G166663) + (SPADLET G166663 "") + (RETURN + (DO ((G166668 (NREVERSE |acc|) (CDR G166668)) + (|x| NIL)) + ((OR (ATOM G166668) + (PROGN (SETQ |x| (CAR G166668)) NIL)) + G166663) + (SEQ (EXIT (SETQ G166663 (STRCONC G166663 |x|)))))))))))) + +;--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 + +(DEFUN |transformAndRecheckComments| (|name| |lines|) + (PROG (|$x| |$name| |$origin| |$recheckingFlag| |$exposeFlagHeading| + |u|) + (DECLARE (SPECIAL |$x| |$name| |$origin| |$recheckingFlag| + |$exposeFlagHeading|)) + (RETURN + (PROGN + (SPADLET |$checkingXmptex?| NIL) + (SPADLET |$x| |name|) + (SPADLET |$name| '|GlossaryPage|) + (SPADLET |$origin| '|gloss|) + (SPADLET |$recheckingFlag| NIL) + (SPADLET |$exposeFlagHeading| + (CONS (MAKESTRING "--------") + (CONS |name| + (CONS (MAKESTRING "---------") NIL)))) + (COND + ((NULL |$exposeFlag|) (|sayBrightly| |$exposeFlagHeading|))) + (SPADLET |u| (|checkComments| |name| |lines|)) + (SPADLET |$recheckingFlag| 'T) + (|checkRewrite| |name| (CONS |u| NIL)) + (SPADLET |$recheckingFlag| NIL) + |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 + +(DEFUN |checkRewrite| (|name| |lines|) + (PROG (|$checkErrorFlag| |margin| |w| |verbatim| |u2| |okBefore| |u|) + (DECLARE (SPECIAL |$checkErrorFlag|)) + (RETURN + (SEQ (PROGN + (SPADLET |$checkErrorFlag| 'T) + (SPADLET |margin| 0) + (SPADLET |lines| (|checkRemoveComments| |lines|)) + (SPADLET |u| |lines|) + (COND + (|$checkingXmptex?| + (SPADLET |u| + (PROG (G166716) + (SPADLET G166716 NIL) + (RETURN + (DO ((G166721 |u| (CDR G166721)) + (|x| NIL)) + ((OR (ATOM G166721) + (PROGN + (SETQ |x| (CAR G166721)) + NIL)) + (NREVERSE0 G166716)) + (SEQ (EXIT + (SETQ G166716 + (CONS + (|checkAddIndented| |x| + |margin|) + G166716)))))))))) + (SPADLET |$argl| (|checkGetArgs| (CAR |u|))) + (SPADLET |u2| NIL) + (SPADLET |verbatim| NIL) + (DO ((G166732 |u| (CDR G166732)) (|x| NIL)) + ((OR (ATOM G166732) + (PROGN (SETQ |x| (CAR G166732)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |w| (|newString2Words| |x|)) + (COND + (|verbatim| + (COND + ((AND |w| + (BOOT-EQUAL (CAR |w|) + (MAKESTRING "\\end{verbatim}"))) + (SPADLET |verbatim| NIL) + (SPADLET |u2| (APPEND |u2| |w|))) + ('T + (SPADLET |u2| + (APPEND |u2| (CONS |x| NIL)))))) + ((AND |w| + (BOOT-EQUAL (CAR |w|) + (MAKESTRING "\\begin{verbatim}"))) + (SPADLET |verbatim| 'T) + (SPADLET |u2| (APPEND |u2| |w|))) + ('T (SPADLET |u2| (APPEND |u2| |w|)))))))) + (SPADLET |u| |u2|) + (SPADLET |u| (|checkAddSpaces| |u|)) + (SPADLET |u| (|checkSplit2Words| |u|)) + (SPADLET |u| (|checkAddMacros| |u|)) + (SPADLET |u| (|checkTexht| |u|)) + (SPADLET |okBefore| (NULL |$checkErrorFlag|)) + (|checkArguments| |u|) + (COND + (|$checkErrorFlag| + (SPADLET |u| (|checkFixCommonProblem| |u|)))) + (|checkRecordHash| |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 + +(DEFUN |checkTexht| (|u|) + (PROG (|count| |y| |x| |acc|) + (RETURN + (SEQ (PROGN + (SPADLET |count| 0) + (SPADLET |acc| NIL) + (DO () ((NULL |u|) NIL) + (SEQ (EXIT (PROGN + (SPADLET |x| (CAR |u|)) + (COND + ((AND (BOOT-EQUAL |x| + (MAKESTRING "\\texht")) + (SPADLET |u| (IFCDR |u|))) + (COND + ((NULL (BOOT-EQUAL (IFCAR |u|) + |$charLbrace|)) + (|checkDocError| + (MAKESTRING + "First left brace after \\texht missing")))) + (SPADLET |count| 1) + (DO () + ((NULL + (OR + (NEQUAL + (SPADLET |y| + (IFCAR (SPADLET |u| (CDR |u|)))) + |$charRbrace|) + (> |count| 1))) + NIL) + (SEQ (EXIT + (PROGN + (COND + ((BOOT-EQUAL |y| + |$charLbrace|) + (SPADLET |count| + (PLUS |count| 1)))) + (COND + ((BOOT-EQUAL |y| + |$charRbrace|) + (SPADLET |count| + (SPADDIFFERENCE |count| 1))) + ('T NIL)))))) + (SPADLET |x| + (IFCAR (SPADLET |u| (CDR |u|)))))) + (COND + ((AND (BOOT-EQUAL |x| + (MAKESTRING "\\httex")) + (SPADLET |u| (IFCDR |u|)) + (BOOT-EQUAL (IFCAR |u|) + |$charLbrace|)) + (SPADLET |acc| (CONS (IFCAR |u|) |acc|)) + (DO () + ((NULL + (NEQUAL + (SPADLET |y| + (IFCAR (SPADLET |u| (CDR |u|)))) + |$charRbrace|)) + NIL) + (SEQ (EXIT + (SPADLET |acc| (CONS |y| |acc|))))) + (SPADLET |acc| (CONS (IFCAR |u|) |acc|)) + (SPADLET |x| + (IFCAR (SPADLET |u| (CDR |u|)))) + (DO () + ((NULL + (NEQUAL + (IFCAR (SPADLET |u| (CDR |u|))) + |$charRbrace|)) + NIL) + (SEQ (EXIT '|skip|))) + (SPADLET |x| + (IFCAR (SPADLET |u| (CDR |u|)))))) + (SPADLET |acc| (CONS |x| |acc|)) + (SPADLET |u| (CDR |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 + +(DEFUN |checkRecordHash| (|u|) + (PROG (|p| |q| |htname| |ISTMP#1| |arg| |entry| |s| |parse| |n| |key| + |x|) + (RETURN + (SEQ (PROGN + (DO () ((NULL |u|) NIL) + (SEQ (EXIT (PROGN + (SPADLET |x| (CAR |u|)) + (COND + ((AND (STRINGP |x|) + (BOOT-EQUAL (ELT |x| 0) + |$charBack|)) + (COND + ((AND (|member| |x| |$HTlinks|) + (SPADLET |u| + (|checkLookForLeftBrace| + (IFCDR |u|))) + (SPADLET |u| + (|checkLookForRightBrace| + (IFCDR |u|))) + (SPADLET |u| + (|checkLookForLeftBrace| + (IFCDR |u|))) + (SPADLET |u| (IFCDR |u|))) + (SPADLET |htname| + (|intern| (IFCAR |u|))) + (SPADLET |entry| + (OR + (HGET |$htHash| |htname|) + (CONS NIL NIL))) + (HPUT |$htHash| |htname| + (CONS (CAR |entry|) + (CONS (CONS |$name| |$origin|) + (CDR |entry|))))) + ((AND (|member| |x| |$HTlisplinks|) + (SPADLET |u| + (|checkLookForLeftBrace| + (IFCDR |u|))) + (SPADLET |u| + (|checkLookForRightBrace| + (IFCDR |u|))) + (SPADLET |u| + (|checkLookForLeftBrace| + (IFCDR |u|))) + (SPADLET |u| (IFCDR |u|))) + (SPADLET |htname| + (|intern| + (|checkGetLispFunctionName| + (|checkGetStringBeforeRightBrace| + |u|)))) + (SPADLET |entry| + (OR + (HGET |$lispHash| |htname|) + (CONS NIL NIL))) + (HPUT |$lispHash| |htname| + (CONS (CAR |entry|) + (CONS (CONS |$name| |$origin|) + (CDR |entry|))))) + ((AND (OR + (SPADLET |p| + (|member| |x| + '("\\gloss" "\\spadglos"))) + (SPADLET |q| + (|member| |x| + '("\\glossSee" + "\\spadglosSee")))) + (SPADLET |u| + (|checkLookForLeftBrace| + (IFCDR |u|))) + (SPADLET |u| (IFCDR |u|))) + (COND + (|q| + (SPADLET |u| + (|checkLookForRightBrace| |u|)) + (SPADLET |u| + (|checkLookForLeftBrace| + (IFCDR |u|))) + (SPADLET |u| (IFCDR |u|)))) + (SPADLET |htname| + (|intern| + (|checkGetStringBeforeRightBrace| + |u|))) + (SPADLET |entry| + (OR + (HGET |$glossHash| + |htname|) + (CONS NIL NIL))) + (HPUT |$glossHash| |htname| + (CONS (CAR |entry|) + (CONS (CONS |$name| |$origin|) + (CDR |entry|))))) + ((AND (BOOT-EQUAL |x| + (MAKESTRING "\\spadsys")) + (SPADLET |u| + (|checkLookForLeftBrace| + (IFCDR |u|))) + (SPADLET |u| (IFCDR |u|))) + (SPADLET |s| + (|checkGetStringBeforeRightBrace| + |u|)) + (COND + ((BOOT-EQUAL (ELT |s| 0) + (|char| '|)|)) + (SPADLET |s| + (SUBSTRING |s| 1 NIL)))) + (SPADLET |parse| + (|checkGetParse| |s|)) + (COND + ((NULL |parse|) + (|checkDocError| + (CONS + (MAKESTRING + "Unparseable \\spadtype: ") + (CONS |s| NIL)))) + ((NULL + (|member| (|opOf| |parse|) + |$currentSysList|)) + (|checkDocError| + (CONS + (MAKESTRING + "Bad system command: ") + (CONS |s| NIL)))) + ((OR (ATOM |parse|) + (NULL + (AND (PAIRP |parse|) + (EQ (QCAR |parse|) '|set|) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |parse|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |arg| + (QCAR |ISTMP#1|)) + 'T)))))) + '|ok|) + ((NULL + (|spadSysChoose| |$setOptions| + |arg|)) + (PROGN + (|checkDocError| + (CONS + (MAKESTRING + "Incorrect \\spadsys: ") + (CONS |s| NIL))) + (SPADLET |entry| + (OR (HGET |$sysHash| |htname|) + (CONS NIL NIL))) + (HPUT |$sysHash| |htname| + (CONS (CAR |entry|) + (CONS (CONS |$name| |$origin|) + (CDR |entry|)))))))) + ((AND (BOOT-EQUAL |x| + (MAKESTRING "\\spadtype")) + (SPADLET |u| + (|checkLookForLeftBrace| + (IFCDR |u|))) + (SPADLET |u| (IFCDR |u|))) + (SPADLET |s| + (|checkGetStringBeforeRightBrace| + |u|)) + (SPADLET |parse| + (|checkGetParse| |s|)) + (COND + ((NULL |parse|) + (|checkDocError| + (CONS + (MAKESTRING + "Unparseable \\spadtype: ") + (CONS |s| NIL)))) + ('T + (SPADLET |n| + (|checkNumOfArgs| |parse|)) + (COND + ((NULL |n|) + (|checkDocError| + (CONS + (MAKESTRING + "Unknown \\spadtype: ") + (CONS |s| NIL)))) + ((AND (ATOM |parse|) (> |n| 0)) + '|skip|) + ((NULL + (SPADLET |key| + (|checkIsValidType| |parse|))) + (|checkDocError| + (CONS + (MAKESTRING + "Unknown \\spadtype: ") + (CONS |s| NIL)))) + ((ATOM |key|) '|ok|) + ('T + (|checkDocError| + (CONS + (MAKESTRING + "Wrong number of arguments: ") + (CONS (|form2HtString| |key|) + NIL)))))))) + ((AND (|member| |x| + '("\\spadop" "\\keyword")) + (SPADLET |u| + (|checkLookForLeftBrace| + (IFCDR |u|))) + (SPADLET |u| (IFCDR |u|))) + (SPADLET |x| + (|intern| + (|checkGetStringBeforeRightBrace| + |u|))) + (COND + ((NULL + (OR (GETL |x| '|Led|) + (GETL |x| '|Nud|))) + (|checkDocError| + (CONS + (MAKESTRING + "Unknown \\spadop: ") + (CONS |x| NIL)))))) + ('T NIL)))) + (SPADLET |u| (CDR |u|)))))) + '|done|))))) + +;checkGetParse s == ncParseFromString removeBackslashes s + +(DEFUN |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 + +(DEFUN |removeBackslashes| (|s|) + (PROG (|k|) + (RETURN + (COND + ((BOOT-EQUAL |s| (MAKESTRING "")) (MAKESTRING "")) + ((> (|#| |s|) (SPADLET |k| (|charPosition| |$charBack| |s| 0))) + (COND + ((EQL |k| 0) (|removeBackslashes| (SUBSTRING |s| 1 NIL))) + ('T + (STRCONC (SUBSTRING |s| 0 |k|) + (|removeBackslashes| + (SUBSTRING |s| (PLUS |k| 1) NIL)))))) + ('T |s|))))) + +;checkNumOfArgs conform == +; conname := opOf conform +; constructor? conname or (conname := abbreviation? conname) => +; #GETDATABASE(conname,'CONSTRUCTORARGS) +; nil --signals error + +(DEFUN |checkNumOfArgs| (|conform|) + (PROG (|conname|) + (RETURN + (PROGN + (SPADLET |conname| (|opOf| |conform|)) + (COND + ((OR (|constructor?| |conname|) + (SPADLET |conname| (|abbreviation?| |conname|))) + (|#| (GETDATABASE |conname| 'CONSTRUCTORARGS))) + ('T NIL)))))) + +;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 + +(DEFUN |checkIsValidType,fn| (|form| |coSig|) + (PROG () + (RETURN + (SEQ (IF (NEQUAL (|#| |form|) (|#| |coSig|)) (EXIT |form|)) + (IF (PROG (G166927) + (SPADLET G166927 NIL) + (RETURN + (DO ((G166935 NIL G166927) + (G166936 (CDR |form|) (CDR G166936)) + (|x| NIL) + (G166937 (CDR |coSig|) (CDR G166937)) + (|flag| NIL)) + ((OR G166935 (ATOM G166936) + (PROGN (SETQ |x| (CAR G166936)) NIL) + (ATOM G166937) + (PROGN (SETQ |flag| (CAR G166937)) NIL)) + G166927) + (SEQ (EXIT (COND + (|flag| (SETQ G166927 + (OR G166927 + (NULL + (|checkIsValidType| |x|))))))))))) + (EXIT NIL)) + (EXIT '|ok|))))) + +(DEFUN |checkIsValidType| (|form|) + (PROG (|op| |args| |conname|) + (RETURN + (COND + ((ATOM |form|) '|ok|) + ('T (SPADLET |op| (CAR |form|)) (SPADLET |args| (CDR |form|)) + (SPADLET |conname| + (COND + ((|constructor?| |op|) |op|) + ('T (|abbreviation?| |op|)))) + (COND + ((NULL |conname|) NIL) + ('T + (|checkIsValidType,fn| |form| + (GETDATABASE |conname| 'COSIG))))))))) + +;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 + +(DEFUN |checkGetLispFunctionName| (|s|) + (PROG (|n| |k| |j|) + (RETURN + (PROGN + (SPADLET |n| (|#| |s|)) + (COND + ((AND (SPADLET |k| (|charPosition| (|char| '|\||) |s| 1)) + (> |n| |k|) + (SPADLET |j| + (|charPosition| (|char| '|\||) |s| + (PLUS |k| 1))) + (> |n| |j|)) + (SUBSTRING |s| (PLUS |k| 1) + (SPADDIFFERENCE (SPADDIFFERENCE |j| |k|) 1))) + ('T + (|checkDocError| + (CONS (MAKESTRING "Ill-formed lisp expression : ") + (CONS |s| NIL))) + '|illformed|)))))) + +;checkGetStringBeforeRightBrace u == +; acc := nil +; while u repeat +; x := first u +; x = $charRbrace => return "STRCONC"/(NREVERSE acc) +; acc := [x,:acc] +; u := rest u + +(DEFUN |checkGetStringBeforeRightBrace| (|u|) + (PROG (|x| |acc|) + (RETURN + (SEQ (PROGN + (SPADLET |acc| NIL) + (DO () ((NULL |u|) NIL) + (SEQ (EXIT (PROGN + (SPADLET |x| (CAR |u|)) + (COND + ((BOOT-EQUAL |x| |$charRbrace|) + (RETURN + (PROG (G166979) + (SPADLET G166979 "") + (RETURN + (DO + ((G166984 (NREVERSE |acc|) + (CDR G166984)) + (G166968 NIL)) + ((OR (ATOM G166984) + (PROGN + (SETQ G166968 + (CAR G166984)) + NIL)) + G166979) + (SEQ + (EXIT + (SETQ G166979 + (STRCONC G166979 G166968))))))))) + ('T (SPADLET |acc| (CONS |x| |acc|)) + (SPADLET |u| (CDR |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 + +(DEFUN |appendOver| (G167000) + (PROG (|head| |tail| |end| |acc|) + (RETURN + (SEQ (PROGN + (SPADLET |head| (CAR G167000)) + (SPADLET |tail| (CDR G167000)) + (SPADLET |acc| (LASTNODE |head|)) + (DO ((G167015 |tail| (CDR G167015)) (|x| NIL)) + ((OR (ATOM G167015) + (PROGN (SETQ |x| (CAR G167015)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |end| (LASTNODE |x|)) + (RPLACD |acc| |x|) + (SPADLET |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 + +(DEFUN |checkRemoveComments| (|lines|) + (PROG (|line| |acc|) + (RETURN + (SEQ (PROGN + (DO () ((NULL |lines|) NIL) + (SEQ (EXIT (PROGN + (|do| (PROGN + (SPADLET |line| + (|checkTrimCommented| + (CAR |lines|))) + (COND + ((>= + (|firstNonBlankPosition| + |line|) + 0) + (SPADLET |acc| + (CONS |line| |acc|))) + ('T NIL)))) + (SPADLET |lines| (CDR |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 + +(DEFUN |checkTrimCommented| (|line|) + (PROG (|n| |k|) + (RETURN + (PROGN + (SPADLET |n| (|#| |line|)) + (SPADLET |k| (|htcharPosition| (|char| '%) |line| 0)) + (COND + ((EQL |k| 0) (MAKESTRING "")) + ((OR (>= |k| (SPADDIFFERENCE |n| 1)) + (NEQUAL (ELT |line| (PLUS |k| 1)) (|char| '%))) + |line|) + ((> (|#| |line|) |k|) (SUBSTRING |line| 0 |k|)) + ('T |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 + +(DEFUN |htcharPosition| (|char| |line| |i|) + (PROG (|m| |k|) + (RETURN + (PROGN + (SPADLET |m| (|#| |line|)) + (SPADLET |k| (|charPosition| |char| |line| |i|)) + (COND + ((BOOT-EQUAL |k| |m|) |k|) + ((> |k| 0) + (COND + ((NEQUAL (ELT |line| (SPADDIFFERENCE |k| 1)) |$charBack|) + |k|) + ('T (|htcharPosition| |char| |line| (PLUS |k| 1))))) + ('T 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 + +(DEFUN |checkAddMacros| (|u|) + (PROG (|x| |verbatim| |y| |acc|) + (RETURN + (SEQ (PROGN + (SPADLET |acc| NIL) + (SPADLET |verbatim| NIL) + (DO () ((NULL |u|) NIL) + (SEQ (EXIT (PROGN + (SPADLET |x| (CAR |u|)) + (SPADLET |acc| + (COND + ((BOOT-EQUAL |x| + (MAKESTRING "\\end{verbatim}")) + (SPADLET |verbatim| NIL) + (CONS |x| |acc|)) + (|verbatim| (CONS |x| |acc|)) + ((BOOT-EQUAL |x| + (MAKESTRING + "\\begin{verbatim}")) + (SPADLET |verbatim| 'T) + (CONS |x| |acc|)) + ((SPADLET |y| + (LASSOC |x| |$HTmacs|)) + (APPEND |y| |acc|)) + ('T (CONS |x| |acc|)))) + (SPADLET |u| (CDR |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 + +(DEFUN |checkComments| (|nameSig| |lines|) + (PROG (|$checkErrorFlag| |margin| |w| |verbatim| |u2| |okBefore| |u| + |v| |res|) + (DECLARE (SPECIAL |$checkErrorFlag|)) + (RETURN + (SEQ (PROGN + (SPADLET |$checkErrorFlag| NIL) + (SPADLET |margin| (|checkGetMargin| |lines|)) + (COND + ((AND (OR (NULL (BOUNDP '|$attribute?|)) + (NULL |$attribute?|)) + (NEQUAL |nameSig| '|constructor|)) + (SPADLET |lines| + (CONS (|checkTransformFirsts| (CAR |nameSig|) + (CAR |lines|) |margin|) + (CDR |lines|))))) + (SPADLET |u| (|checkIndentedLines| |lines| |margin|)) + (SPADLET |$argl| (|checkGetArgs| (CAR |u|))) + (SPADLET |u2| NIL) + (SPADLET |verbatim| NIL) + (DO ((G167097 |u| (CDR G167097)) (|x| NIL)) + ((OR (ATOM G167097) + (PROGN (SETQ |x| (CAR G167097)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |w| (|newString2Words| |x|)) + (COND + (|verbatim| + (COND + ((AND |w| + (BOOT-EQUAL (CAR |w|) + (MAKESTRING "\\end{verbatim}"))) + (SPADLET |verbatim| NIL) + (SPADLET |u2| (APPEND |u2| |w|))) + ('T + (SPADLET |u2| + (APPEND |u2| (CONS |x| NIL)))))) + ((AND |w| + (BOOT-EQUAL (CAR |w|) + (MAKESTRING "\\begin{verbatim}"))) + (SPADLET |verbatim| 'T) + (SPADLET |u2| (APPEND |u2| |w|))) + ('T (SPADLET |u2| (APPEND |u2| |w|)))))))) + (SPADLET |u| |u2|) + (SPADLET |u| (|checkAddSpaces| |u|)) + (SPADLET |u| (|checkIeEg| |u|)) + (SPADLET |u| (|checkSplit2Words| |u|)) + (|checkBalance| |u|) + (SPADLET |okBefore| (NULL |$checkErrorFlag|)) + (|checkArguments| |u|) + (COND + (|$checkErrorFlag| + (SPADLET |u| (|checkFixCommonProblem| |u|)))) + (SPADLET |v| (|checkDecorate| |u|)) + (SPADLET |res| + (PROG (G167103) + (SPADLET G167103 "") + (RETURN + (DO ((G167108 |v| (CDR G167108)) + (|y| NIL)) + ((OR (ATOM G167108) + (PROGN + (SETQ |y| (CAR G167108)) + NIL)) + G167103) + (SEQ (EXIT (SETQ G167103 + (STRCONC G167103 |y|)))))))) + (SPADLET |res| (|checkAddPeriod| |res|)) + (COND (|$checkErrorFlag| (|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 + +(DEFUN |checkIndentedLines| (|u| |margin|) + (PROG (|k| |s| |verbatim| |u2|) + (RETURN + (SEQ (PROGN + (SPADLET |verbatim| NIL) + (SPADLET |u2| NIL) + (DO ((G167153 |u| (CDR G167153)) (|x| NIL)) + ((OR (ATOM G167153) + (PROGN (SETQ |x| (CAR G167153)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |k| (|firstNonBlankPosition| |x|)) + (COND + ((BOOT-EQUAL |k| (SPADDIFFERENCE 1)) + (COND + (|verbatim| + (SPADLET |u2| + (APPEND |u2| + (CONS |$charFauxNewline| NIL)))) + ('T + (SPADLET |u2| + (APPEND |u2| + (CONS + (MAKESTRING + "\\blankline ") + NIL)))))) + ('T (SPADLET |s| (SUBSTRING |x| |k| NIL)) + (COND + ((BOOT-EQUAL |s| + (MAKESTRING "\\begin{verbatim}")) + (SPADLET |verbatim| 'T) + (SPADLET |u2| + (APPEND |u2| (CONS |s| NIL)))) + ((BOOT-EQUAL |s| + (MAKESTRING "\\end{verbatim}")) + (SPADLET |verbatim| NIL) + (SPADLET |u2| + (APPEND |u2| (CONS |s| NIL)))) + (|verbatim| + (SPADLET |u2| + (APPEND |u2| + (CONS + (SUBSTRING |x| |margin| NIL) + NIL)))) + ((BOOT-EQUAL |margin| |k|) + (SPADLET |u2| + (APPEND |u2| (CONS |s| NIL)))) + ('T + (SPADLET |u2| + (APPEND |u2| + (CONS + (STRCONC + (MAKESTRING + "\\indented{") + (STRINGIMAGE + (SPADDIFFERENCE |k| + |margin|)) + (MAKESTRING "}{") + (|checkAddSpaceSegments| + |s| 0) + (MAKESTRING "}")) + NIL))))))))))) + |u2|))))) + +;newString2Words l == +; not STRINGP l => [l] +; m := MAXINDEX l +; m = -1 => NIL +; i := 0 +; [w while newWordFrom(l,i,m) is [w,i]] + +(DEFUN |newString2Words| (|l|) + (PROG (|m| |ISTMP#1| |w| |ISTMP#2| |i|) + (RETURN + (SEQ (COND + ((NULL (STRINGP |l|)) (CONS |l| NIL)) + ('T (SPADLET |m| (MAXINDEX |l|)) + (COND + ((BOOT-EQUAL |m| (SPADDIFFERENCE 1)) NIL) + ('T (SPADLET |i| 0) + (PROG (G167196) + (SPADLET G167196 NIL) + (RETURN + (DO () + ((NULL (PROGN + (SPADLET |ISTMP#1| + (|newWordFrom| |l| |i| |m|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |w| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |i| + (QCAR |ISTMP#2|)) + 'T)))))) + (NREVERSE0 G167196)) + (SEQ (EXIT (SETQ G167196 (CONS |w| G167196))))))))))))))) + +;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] + +(DEFUN |newWordFrom| (|l| |i| |m|) + (PROG (|ch| |done| |buf|) + (RETURN + (SEQ (PROGN + (DO () + ((NULL (AND (<= |i| |m|) + (BOOT-EQUAL (ELT |l| |i|) '| |))) + NIL) + (SEQ (EXIT (SPADLET |i| (PLUS |i| 1))))) + (COND + ((> |i| |m|) NIL) + ('T (SPADLET |buf| (MAKESTRING "")) + (SPADLET |ch| (ELT |l| |i|)) + (COND + ((BOOT-EQUAL |ch| |$charFauxNewline|) + (CONS |$stringFauxNewline| (CONS (PLUS |i| 1) NIL))) + ('T (SPADLET |done| NIL) + (DO () ((NULL (AND (<= |i| |m|) (NULL |done|))) NIL) + (SEQ (EXIT (PROGN + (SPADLET |ch| (ELT |l| |i|)) + (COND + ((OR (BOOT-EQUAL |ch| |$charBlank|) + (BOOT-EQUAL |ch| + |$charFauxNewline|)) + (SPADLET |done| 'T)) + ('T + (SPADLET |buf| + (STRCONC |buf| |ch|)) + (SPADLET |i| (PLUS |i| 1)))))))) + (CONS |buf| (CONS |i| NIL))))))))))) + +;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 + +(DEFUN |checkAddPeriod| (|s|) + (PROG (|m| |lastChar|) + (RETURN + (PROGN + (SPADLET |m| (MAXINDEX |s|)) + (SPADLET |lastChar| (ELT |s| |m|)) + (COND + ((OR (BOOT-EQUAL |lastChar| (|char| '!)) + (BOOT-EQUAL |lastChar| (|char| '?)) + (BOOT-EQUAL |lastChar| (|char| (INTERN "." "BOOT")))) + |s|) + ((OR (BOOT-EQUAL |lastChar| (|char| '|,|)) + (BOOT-EQUAL |lastChar| (|char| '|;|))) + (SETELT |s| |m| (|char| (INTERN "." "BOOT"))) |s|) + ('T |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] + +(DEFUN |checkGetArgs| (|u|) + (PROG (|m| |k| |acc| |i|) + (RETURN + (SEQ (COND + ((NULL (STRINGP |u|)) NIL) + ('T (SPADLET |m| (MAXINDEX |u|)) + (SPADLET |k| (|firstNonBlankPosition| |u|)) + (COND + ((> |k| 0) (|checkGetArgs| (SUBSTRING |u| |k| NIL))) + ((|stringPrefix?| (MAKESTRING "\\spad{") |u|) + (SPADLET |k| + (OR (|getMatchingRightPren| |u| 6 (|char| '{) + (|char| '})) + |m|)) + (|checkGetArgs| + (SUBSTRING |u| 6 (SPADDIFFERENCE |k| 6)))) + ((> (SPADLET |i| (|charPosition| (|char| '|(|) |u| 0)) + |m|) + NIL) + ((NEQUAL (ELT |u| |m|) (|char| '|)|)) NIL) + ('T + (DO () + ((NULL (> |m| + (SPADLET |k| + (|charPosition| |$charComma| + |u| (PLUS |i| 1))))) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |acc| + (CONS + (|trimString| + (SUBSTRING |u| (PLUS |i| 1) + (SPADDIFFERENCE + (SPADDIFFERENCE |k| |i|) + 1))) + |acc|)) + (SPADLET |i| |k|))))) + (NREVERSE + (CONS (SUBSTRING |u| (PLUS |i| 1) + (SPADDIFFERENCE (SPADDIFFERENCE |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 + +(DEFUN |checkGetMargin| (|lines|) + (PROG (|x| |k| |margin|) + (RETURN + (SEQ (PROGN + (DO () ((NULL |lines|) NIL) + (SEQ (EXIT (PROGN + (|do| (PROGN + (SPADLET |x| (CAR |lines|)) + (SPADLET |k| + (|firstNonBlankPosition| |x|)) + (COND + ((BOOT-EQUAL |k| + (SPADDIFFERENCE 1)) + NIL) + ('T + (SPADLET |margin| + (COND + (|margin| (MIN |margin| |k|)) + ('T |k|))))))) + (SPADLET |lines| (CDR |lines|)))))) + (OR |margin| 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 + +(DEFUN |firstNonBlankPosition| (&REST G167305 &AUX |options| |x|) + (DSETQ (|x| . |options|) G167305) + (PROG (|start| |k|) + (RETURN + (SEQ (PROGN + (SPADLET |start| (OR (IFCAR |options|) 0)) + (SPADLET |k| (SPADDIFFERENCE 1)) + (DO ((G167295 (MAXINDEX |x|)) (|i| |start| (+ |i| 1))) + ((> |i| G167295) NIL) + (SEQ (EXIT (COND + ((NEQUAL (ELT |x| |i|) |$charBlank|) + (RETURN (SPADLET |k| |i|))) + ('T NIL))))) + |k|))))) + +;checkAddIndented(x,margin) == +; k := firstNonBlankPosition x +; k = -1 => '"\blankline " +; margin = k => x +; STRCONC('"\indented{",STRINGIMAGE(k-margin),'"}{",checkAddSpaceSegments(SUBSTRING(x,k,nil),0),'"}") + +(DEFUN |checkAddIndented| (|x| |margin|) + (PROG (|k|) + (RETURN + (PROGN + (SPADLET |k| (|firstNonBlankPosition| |x|)) + (COND + ((BOOT-EQUAL |k| (SPADDIFFERENCE 1)) + (MAKESTRING "\\blankline ")) + ((BOOT-EQUAL |margin| |k|) |x|) + ('T + (STRCONC (MAKESTRING "\\indented{") + (STRINGIMAGE (SPADDIFFERENCE |k| |margin|)) + (MAKESTRING "}{") + (|checkAddSpaceSegments| (SUBSTRING |x| |k| NIL) 0) + (MAKESTRING "}")))))))) + +;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) + +(DEFUN |checkAddSpaceSegments| (|u| |k|) + (PROG (|m| |i| |j| |n|) + (RETURN + (SEQ (PROGN + (SPADLET |m| (MAXINDEX |u|)) + (SPADLET |i| (|charPosition| |$charBlank| |u| |k|)) + (COND + ((> |i| |m|) |u|) + ('T (SPADLET |j| |i|) + (DO () + ((NULL (AND (> |m| (SPADLET |j| (PLUS |j| 1))) + (BOOT-EQUAL (ELT |u| |j|) + (|char| '| |)))) + NIL) + (SEQ (EXIT '|continue|))) + (SPADLET |n| (SPADDIFFERENCE |j| |i|)) + (COND + ((> |n| 1) + (STRCONC (SUBSTRING |u| 0 |i|) + (MAKESTRING "\\space{") (STRINGIMAGE |n|) + (MAKESTRING "}") + (|checkAddSpaceSegments| + (SUBSTRING |u| (PLUS |i| |n|) NIL) 0))) + ('T (|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) + +(DEFUN |checkTrim,trim| (|s|) + (PROG (|k| |m| |n|) + (RETURN + (SEQ (SPADLET |k| (|checkTrim,wherePP| |s|)) + (RETURN (SUBSTRING |s| (PLUS |k| 2) NIL)) + (SPADLET |m| (MAXINDEX |s|)) (SPADLET |n| (PLUS |k| 2)) + (DO ((|j| (PLUS |k| 2) (+ |j| 1))) + ((OR (> |j| |m|) + (NULL (BOOT-EQUAL (ELT |s| |j|) |$charBlank|))) + NIL) + (SEQ (EXIT (SPADLET |n| (PLUS |n| 1))))) + (EXIT (SUBSTRING |s| |n| NIL)))))) + +(DEFUN |checkTrim,wherePP| (|u|) + (PROG (|k|) + (RETURN + (SEQ (SPADLET |k| (|charPosition| |$charPlus| |u| 0)) + (IF (OR (BOOT-EQUAL |k| (|#| |u|)) + (NEQUAL (|charPosition| |$charPlus| |u| + (PLUS |k| 1)) + (PLUS |k| 1))) + (EXIT (|systemError| + (MAKESTRING " Improper comment found")))) + (EXIT |k|))))) + +(DEFUN |checkTrim| (|$x| |lines|) + (DECLARE (SPECIAL |$x|)) + (PROG (|j| |s|) + (RETURN + (SEQ (PROGN + (SPADLET |s| + (CONS (|checkTrim,wherePP| (CAR |lines|)) NIL)) + (DO ((G167356 (CDR |lines|) (CDR G167356)) (|x| NIL)) + ((OR (ATOM G167356) + (PROGN (SETQ |x| (CAR G167356)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |j| (|checkTrim,wherePP| |x|)) + (COND + ((NULL (MEMQ |j| |s|)) + (|checkDocError| + (CONS |$x| + (CONS + (MAKESTRING + " has varying indentation levels") + NIL))) + (SPADLET |s| (CONS |j| |s|))) + ('T NIL)))))) + (PROG (G167366) + (SPADLET G167366 NIL) + (RETURN + (DO ((G167371 |lines| (CDR G167371)) (|y| NIL)) + ((OR (ATOM G167371) + (PROGN (SETQ |y| (CAR G167371)) NIL)) + (NREVERSE0 G167366)) + (SEQ (EXIT (SETQ G167366 + (CONS (|checkTrim,trim| |y|) + G167366)))))))))))) + +;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 + +(DEFUN |checkExtract| (|header| |lines|) + (PROG (|line| |u| |margin| |firstLines| |m| |k| |j| |i| |acc|) + (RETURN + (SEQ (PROGN + (DO () ((NULL |lines|) NIL) + (SEQ (EXIT (PROGN + (SPADLET |line| (CAR |lines|)) + (SPADLET |k| + (|firstNonBlankPosition| |line|)) + (COND + ((|substring?| |header| |line| |k|) + (RETURN NIL)) + ('T (SPADLET |lines| (CDR |lines|)))))))) + (COND + ((NULL |lines|) NIL) + ('T (SPADLET |u| (CAR |lines|)) + (SPADLET |j| (|charPosition| (|char| '|:|) |u| |k|)) + (SPADLET |margin| |k|) + (SPADLET |firstLines| + (COND + ((NEQUAL (SPADLET |k| + (|firstNonBlankPosition| |u| + (PLUS |j| 1))) + (SPADDIFFERENCE 1)) + (CONS (SUBSTRING |u| (PLUS |j| 1) NIL) + (CDR |lines|))) + ('T (CDR |lines|)))) + (SPADLET |acc| NIL) + (DO ((G167406 |firstLines| (CDR G167406)) + (|line| NIL)) + ((OR (ATOM G167406) + (PROGN (SETQ |line| (CAR G167406)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (|do| (PROGN + (SPADLET |m| (|#| |line|)) + (COND + ((BOOT-EQUAL + (SPADLET |k| + (|firstNonBlankPosition| + |line|)) + (SPADDIFFERENCE 1)) + '|skip|) + ((> |k| |margin|) '|skip|) + ((NULL + (UPPER-CASE-P + (ELT |line| |k|))) + '|skip|) + ((BOOT-EQUAL + (SPADLET |j| + (|charPosition| + (|char| '|:|) |line| |k|)) + |m|) + '|skip|) + ((> |j| + (SPADLET |i| + (|charPosition| + (|char| '| |) |line| + (PLUS |k| 1)))) + '|skip|) + ('T (RETURN NIL))))) + (SPADLET |acc| (CONS |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 + +(DEFUN |checkFixCommonProblem| (|u|) + (PROG (|x| |next| |acc|) + (RETURN + (SEQ (PROGN + (SPADLET |acc| NIL) + (DO () ((NULL |u|) NIL) + (SEQ (EXIT (PROGN + (SPADLET |x| (CAR |u|)) + (COND + ((AND (BOOT-EQUAL |x| |$charLbrace|) + (|member| + (SPADLET |next| (IFCAR (CDR |u|))) + |$HTspadmacros|) + (NEQUAL (IFCAR (IFCDR (CDR |u|))) + |$charLbrace|)) + (|checkDocError| + (CONS (MAKESTRING "Reversing ") + (CONS |next| + (CONS + (MAKESTRING " and left brace") + NIL)))) + (SPADLET |acc| + (CONS |$charLbrace| + (CONS |next| |acc|))) + (SPADLET |u| (CDR (CDR |u|)))) + ('T (SPADLET |acc| (CONS |x| |acc|)) + (SPADLET |u| (CDR |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 + +(DEFUN |checkDecorate| (|u|) + (PROG (|x| |count| |mathSymbolsOk| |spadflag| |verbatim| |v| |xcount| + |acc|) + (RETURN + (SEQ (PROGN + (SPADLET |count| 0) + (SPADLET |spadflag| NIL) + (SPADLET |mathSymbolsOk| NIL) + (SPADLET |acc| NIL) + (SPADLET |verbatim| NIL) + (DO () ((NULL |u|) NIL) + (SEQ (EXIT (PROGN + (SPADLET |x| (CAR |u|)) + (COND + ((NULL |verbatim|) + (COND + ((BOOT-EQUAL |x| (MAKESTRING "\\em")) + (COND + ((> |count| 0) + (SPADLET |mathSymbolsOk| + (SPADDIFFERENCE |count| 1)) + (SPADLET |spadflag| + (SPADDIFFERENCE |count| 1))) + ('T + (|checkDocError| + (CONS + (MAKESTRING + "\\em must be enclosed in braces") + NIL)))))) + (COND + ((|member| |x| + '("\\spadpaste" "\\spad" + "\\spadop")) + (SPADLET |mathSymbolsOk| |count|))) + (COND + ((|member| |x| + '("\\s" "\\spadtype" "\\spadsys" + "\\example" "\\andexample" + "\\spadop" "\\spad" + "\\spadignore" "\\spadpaste" + "\\spadcommand" "\\footnote")) + (SPADLET |spadflag| |count|)) + ((BOOT-EQUAL |x| |$charLbrace|) + (SPADLET |count| (PLUS |count| 1))) + ((BOOT-EQUAL |x| |$charRbrace|) + (SPADLET |count| + (SPADDIFFERENCE |count| 1)) + (COND + ((BOOT-EQUAL |mathSymbolsOk| + |count|) + (SPADLET |mathSymbolsOk| NIL))) + (COND + ((BOOT-EQUAL |spadflag| |count|) + (SPADLET |spadflag| NIL)) + ('T NIL))) + ((AND (NULL |mathSymbolsOk|) + (|member| |x| + '("+" "*" "=" "==" "->"))) + (COND + (|$checkingXmptex?| + (|checkDocError| + (CONS '|Symbol | + (CONS |x| + (CONS + (MAKESTRING + " appearing outside \\spad{}") + NIL))))) + ('T NIL))) + ('T NIL)))) + (SPADLET |acc| + (COND + ((BOOT-EQUAL |x| + (MAKESTRING "\\end{verbatim}")) + (SPADLET |verbatim| NIL) + (CONS |x| |acc|)) + (|verbatim| (CONS |x| |acc|)) + ((BOOT-EQUAL |x| + (MAKESTRING + "\\begin{verbatim}")) + (SPADLET |verbatim| 'T) + (CONS |x| |acc|)) + ((AND + (BOOT-EQUAL |x| + (MAKESTRING "\\begin")) + (BOOT-EQUAL + (CAR + (SPADLET |v| (IFCDR |u|))) + |$charLbrace|) + (BOOT-EQUAL + (CAR + (SPADLET |v| (IFCDR |v|))) + (MAKESTRING "detail")) + (BOOT-EQUAL + (CAR + (SPADLET |v| (IFCDR |v|))) + |$charRbrace|)) + (SPADLET |u| |v|) + (CONS + (MAKESTRING "\\blankline ") + |acc|)) + ((AND + (BOOT-EQUAL |x| + (MAKESTRING "\\end")) + (BOOT-EQUAL + (CAR + (SPADLET |v| (IFCDR |u|))) + |$charLbrace|) + (BOOT-EQUAL + (CAR + (SPADLET |v| (IFCDR |v|))) + (MAKESTRING "detail")) + (BOOT-EQUAL + (CAR + (SPADLET |v| (IFCDR |v|))) + |$charRbrace|)) + (SPADLET |u| |v|) |acc|) + ((OR + (BOOT-EQUAL |x| (|char| '$)) + (BOOT-EQUAL |x| + (MAKESTRING "$"))) + (CONS (MAKESTRING "\\$") |acc|)) + ((OR + (BOOT-EQUAL |x| (|char| '%)) + (BOOT-EQUAL |x| + (MAKESTRING "%"))) + (CONS (MAKESTRING "\\%") |acc|)) + ((OR + (BOOT-EQUAL |x| (|char| '|,|)) + (BOOT-EQUAL |x| + (MAKESTRING ","))) + (CONS (MAKESTRING ",{}") |acc|)) + ((BOOT-EQUAL |x| + (MAKESTRING "\\spad")) + (CONS (MAKESTRING "\\spad") + |acc|)) + ((AND (STRINGP |x|) + (DIGITP (ELT |x| 0))) + (CONS |x| |acc|)) + ((AND (NULL |spadflag|) + (OR + (AND (CHARP |x|) + (ALPHA-CHAR-P |x|) + (NULL + (MEMQ |x| + |$charExclusions|))) + (|member| |x| |$argl|))) + (CONS |$charRbrace| + (CONS |x| + (CONS |$charLbrace| + (CONS (MAKESTRING "\\spad") + |acc|))))) + ((AND (NULL |spadflag|) + (OR + (AND (STRINGP |x|) + (NULL + (BOOT-EQUAL (ELT |x| 0) + |$charBack|)) + (DIGITP + (ELT |x| (MAXINDEX |x|)))) + (|member| |x| + '("true" "false")))) + (CONS |$charRbrace| + (CONS |x| + (CONS |$charLbrace| + (CONS (MAKESTRING "\\spad") + |acc|))))) + ('T (SPADLET |xcount| (|#| |x|)) + (COND + ((AND (EQL |xcount| 3) + (BOOT-EQUAL (ELT |x| 1) + (|char| '|t|)) + (BOOT-EQUAL (ELT |x| 2) + (|char| '|h|))) + (CONS (MAKESTRING "th") + (CONS |$charRbrace| + (CONS (ELT |x| 0) + (CONS |$charLbrace| + (CONS + (MAKESTRING "\\spad") + |acc|)))))) + ((AND (EQL |xcount| 4) + (BOOT-EQUAL (ELT |x| 1) + (|char| '-)) + (BOOT-EQUAL (ELT |x| 2) + (|char| '|t|)) + (BOOT-EQUAL (ELT |x| 3) + (|char| '|h|))) + (CONS (MAKESTRING "-th") + (CONS |$charRbrace| + (CONS (ELT |x| 0) + (CONS |$charLbrace| + (CONS + (MAKESTRING "\\spad") + |acc|)))))) + ((OR + (AND (EQL |xcount| 2) + (BOOT-EQUAL (ELT |x| 1) + (|char| '|i|))) + (AND (NULL |spadflag|) + (> |xcount| 0) + (> 4 |xcount|) + (NULL + (|member| |x| + '("th" "rd" "st"))) + (|hasNoVowels| |x|))) + (CONS |$charRbrace| + (CONS |x| + (CONS |$charLbrace| + (CONS + (MAKESTRING "\\spad") + |acc|))))) + ('T + (CONS + (|checkAddBackSlashes| |x|) + |acc|)))))) + (SPADLET |u| (CDR |u|)))))) + (NREVERSE |acc|)))))) + +;hasNoVowels x == +; max := MAXINDEX x +; x.max = char 'y => false +; and/[not isVowel(x.i) for i in 0..max] + +(DEFUN |hasNoVowels| (|x|) + (PROG (|max|) + (RETURN + (SEQ (PROGN + (SPADLET |max| (MAXINDEX |x|)) + (COND + ((BOOT-EQUAL (ELT |x| |max|) (|char| '|y|)) NIL) + ('T + (PROG (G167501) + (SPADLET G167501 'T) + (RETURN + (DO ((G167507 NIL (NULL G167501)) + (|i| 0 (QSADD1 |i|))) + ((OR G167507 (QSGREATERP |i| |max|)) + G167501) + (SEQ (EXIT (SETQ G167501 + (AND G167501 + (NULL + (|isVowel| (ELT |x| |i|))))))))))))))))) + +;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) + +(DEFUN |isVowel| (|c|) + (OR (EQ |c| (|char| '|a|)) (EQ |c| (|char| '|e|)) + (EQ |c| (|char| '|i|)) (EQ |c| (|char| '|o|)) + (EQ |c| (|char| '|u|)) (EQ |c| (|char| 'A)) (EQ |c| (|char| 'E)) + (EQ |c| (|char| 'I)) (EQ |c| (|char| 'O)) (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 + +(DEFUN |checkAddBackSlashes| (|s|) + (PROG (|c| |m| |char| |insertIndex| |k|) + (RETURN + (SEQ (COND + ((OR (AND (CHARP |s|) (SPADLET |c| |s|)) + (AND (EQL (|#| |s|) 1) (SPADLET |c| (ELT |s| 0)))) + (COND + ((MEMQ |s| |$charEscapeList|) + (STRCONC |$charBack| |c|)) + ('T |s|))) + ('T (SPADLET |k| 0) (SPADLET |m| (MAXINDEX |s|)) + (SPADLET |insertIndex| NIL) + (DO () ((NULL (<= |k| |m|)) NIL) + (SEQ (EXIT (PROGN + (|do| (PROGN + (SPADLET |char| (ELT |s| |k|)) + (COND + ((BOOT-EQUAL |char| |$charBack|) + (SPADLET |k| (PLUS |k| 2))) + ((MEMQ |char| |$charEscapeList|) + (RETURN + (SPADLET |insertIndex| |k|)))))) + (SPADLET |k| (PLUS |k| 1)))))) + (COND + (|insertIndex| + (|checkAddBackSlashes| + (STRCONC (SUBSTRING |s| 0 |insertIndex|) + |$charBack| (ELT |s| |k|) + (SUBSTRING |s| (PLUS |insertIndex| 1) + NIL)))) + ('T |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 + +(DEFUN |checkAddSpaces| (|u|) + (PROG (|u2| |space|) + (RETURN + (SEQ (COND + ((NULL |u|) NIL) + ((NULL (CDR |u|)) |u|) + ('T (SPADLET |space| |$charBlank|) (SPADLET |u2| NIL) + (DO ((|i| 1 (QSADD1 |i|)) (G167557 |u| (CDR G167557)) + (|f| NIL)) + ((OR (ATOM G167557) + (PROGN (SETQ |f| (CAR G167557)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (COND + ((BOOT-EQUAL |f| + (MAKESTRING "\\begin{verbatim}")) + (SPADLET |space| |$charFauxNewline|) + (COND + ((NULL |u2|) + (SPADLET |u2| (CONS |space| NIL))) + ('T NIL)))) + (COND + ((> |i| 1) + (SPADLET |u2| + (APPEND |u2| + (CONS |space| (CONS |f| NIL))))) + ('T + (SPADLET |u2| + (APPEND |u2| (CONS |f| NIL))))) + (COND + ((BOOT-EQUAL |f| + (MAKESTRING "\\end{verbatim}")) + (SPADLET |u2| + (APPEND |u2| + (CONS |space| NIL))) + (SPADLET |space| |$charBlank|)) + ('T NIL)))))) + |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 + +(DEFUN |checkIeEg| (|u|) + (PROG (|x| |verbatim| |z| |acc|) + (RETURN + (SEQ (PROGN + (SPADLET |acc| NIL) + (SPADLET |verbatim| NIL) + (DO () ((NULL |u|) NIL) + (SEQ (EXIT (PROGN + (SPADLET |x| (CAR |u|)) + (SPADLET |acc| + (COND + ((BOOT-EQUAL |x| + (MAKESTRING "\\end{verbatim}")) + (SPADLET |verbatim| NIL) + (CONS |x| |acc|)) + (|verbatim| (CONS |x| |acc|)) + ((BOOT-EQUAL |x| + (MAKESTRING + "\\begin{verbatim}")) + (SPADLET |verbatim| 'T) + (CONS |x| |acc|)) + ((SPADLET |z| + (|checkIeEgfun| |x|)) + (APPEND (NREVERSE |z|) |acc|)) + ('T (CONS |x| |acc|)))) + (SPADLET |u| (CDR |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 + +(DEFUN |checkIeEgfun| (|x|) + (PROG (|m| |key| |firstPart| |result|) + (RETURN + (SEQ (COND + ((CHARP |x|) NIL) + ((BOOT-EQUAL |x| (MAKESTRING "")) NIL) + ('T (SPADLET |m| (MAXINDEX |x|)) + (SEQ (DO ((G167607 (SPADDIFFERENCE |m| 3)) + (|k| 0 (QSADD1 |k|))) + ((QSGREATERP |k| G167607) NIL) + (SEQ (EXIT (COND + ((AND + (BOOT-EQUAL (ELT |x| (PLUS |k| 1)) + |$charPeriod|) + (BOOT-EQUAL (ELT |x| (PLUS |k| 3)) + |$charPeriod|) + (OR + (AND + (BOOT-EQUAL (ELT |x| |k|) + (|char| '|i|)) + (BOOT-EQUAL + (ELT |x| (PLUS |k| 2)) + (|char| '|e|)) + (SPADLET |key| + (MAKESTRING "that is"))) + (AND + (BOOT-EQUAL (ELT |x| |k|) + (|char| '|e|)) + (BOOT-EQUAL + (ELT |x| (PLUS |k| 2)) + (|char| '|g|)) + (SPADLET |key| + (MAKESTRING "for example"))))) + (EXIT + (PROGN + (SPADLET |firstPart| + (COND + ((> |k| 0) + (CONS (SUBSTRING |x| 0 |k|) + NIL)) + ('T NIL))) + (SPADLET |result| + (APPEND |firstPart| + (CONS + (MAKESTRING "\\spadignore{") + (CONS (SUBSTRING |x| |k| 4) + (CONS (MAKESTRING "}") + (|checkIeEgfun| + (SUBSTRING |x| (PLUS |k| 4) + NIL)))))))))))))) + (EXIT |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 + +(DEFUN |checkSplit2Words| (|u|) + (PROG (|x| |verbatim| |z| |acc|) + (RETURN + (SEQ (PROGN + (SPADLET |acc| NIL) + (DO () ((NULL |u|) NIL) + (SEQ (EXIT (PROGN + (SPADLET |x| (CAR |u|)) + (SPADLET |acc| + (COND + ((BOOT-EQUAL |x| + (MAKESTRING "\\end{verbatim}")) + (SPADLET |verbatim| NIL) + (CONS |x| |acc|)) + (|verbatim| (CONS |x| |acc|)) + ((BOOT-EQUAL |x| + (MAKESTRING + "\\begin{verbatim}")) + (SPADLET |verbatim| 'T) + (CONS |x| |acc|)) + ((SPADLET |z| + (|checkSplitBrace| |x|)) + (APPEND (NREVERSE |z|) |acc|)) + ('T (CONS |x| |acc|)))) + (SPADLET |u| (CDR |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] + +(DEFUN |checkSplitBrace| (|x|) + (PROG (|m| |u|) + (RETURN + (SEQ (COND + ((CHARP |x|) (CONS |x| NIL)) + ((EQL (|#| |x|) 1) (CONS (ELT |x| 0) NIL)) + ((AND (SPADLET |u| (|checkSplitBackslash| |x|)) (CDR |u|)) + (PROG (G167644) + (SPADLET G167644 NIL) + (RETURN + (DO ((G167649 |u| (CDR G167649)) (|y| NIL)) + ((OR (ATOM G167649) + (PROGN (SETQ |y| (CAR G167649)) NIL)) + G167644) + (SEQ (EXIT (SETQ G167644 + (APPEND G167644 + (|checkSplitBrace| |y|))))))))) + ('T (SPADLET |m| (MAXINDEX |x|)) + (COND + ((AND (SPADLET |u| (|checkSplitOn| |x|)) (CDR |u|)) + (PROG (G167655) + (SPADLET G167655 NIL) + (RETURN + (DO ((G167660 |u| (CDR G167660)) (|y| NIL)) + ((OR (ATOM G167660) + (PROGN (SETQ |y| (CAR G167660)) NIL)) + G167655) + (SEQ (EXIT (SETQ G167655 + (APPEND G167655 + (|checkSplitBrace| |y|))))))))) + ((AND (SPADLET |u| (|checkSplitPunctuation| |x|)) + (CDR |u|)) + (PROG (G167666) + (SPADLET G167666 NIL) + (RETURN + (DO ((G167671 |u| (CDR G167671)) (|y| NIL)) + ((OR (ATOM G167671) + (PROGN (SETQ |y| (CAR G167671)) NIL)) + G167666) + (SEQ (EXIT (SETQ G167666 + (APPEND G167666 + (|checkSplitBrace| |y|))))))))) + ('T (CONS |x| NIL))))))))) + +;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] + +(DEFUN |checkSplitBackslash| (|x|) + (PROG (|m| |k| |u| |v|) + (RETURN + (COND + ((NULL (STRINGP |x|)) (CONS |x| NIL)) + ('T (SPADLET |m| (MAXINDEX |x|)) + (COND + ((> |m| (SPADLET |k| (|charPosition| |$charBack| |x| 0))) + (COND + ((OR (EQL |m| 1) (ALPHA-CHAR-P (ELT |x| (PLUS |k| 1)))) + (COND + ((> |m| + (SPADLET |k| (|charPosition| |$charBack| |x| 1))) + (CONS (SUBSTRING |x| 0 |k|) + (|checkSplitBackslash| (SUBSTRING |x| |k| NIL)))) + ('T (CONS |x| NIL)))) + ((EQL |k| 0) + (CONS (SUBSTRING |x| 0 2) + (|checkSplitBackslash| (SUBSTRING |x| 2 NIL)))) + ('T (SPADLET |u| (SUBSTRING |x| 0 |k|)) + (SPADLET |v| (SUBSTRING |x| |k| 2)) + (COND + ((BOOT-EQUAL (PLUS |k| 1) |m|) + (CONS |u| (CONS |v| NIL))) + ('T + (CONS |u| + (CONS |v| + (|checkSplitBackslash| + (SUBSTRING |x| (PLUS |k| 2) NIL))))))))) + ('T (CONS |x| NIL)))))))) + +;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] + +(DEFUN |checkSplitPunctuation| (|x|) + (PROG (|m| |lastchar| |v| |k| |u|) + (RETURN + (COND + ((CHARP |x|) (CONS |x| NIL)) + ('T (SPADLET |m| (MAXINDEX |x|)) + (COND + ((> 1 |m|) (CONS |x| NIL)) + ('T (SPADLET |lastchar| (ELT |x| |m|)) + (COND + ((AND (BOOT-EQUAL |lastchar| |$charPeriod|) + (BOOT-EQUAL (ELT |x| (SPADDIFFERENCE |m| 1)) + |$charPeriod|)) + (COND + ((EQL |m| 1) (CONS |x| NIL)) + ((AND (> |m| 3) + (BOOT-EQUAL (ELT |x| (SPADDIFFERENCE |m| 2)) + |$charPeriod|)) + (APPEND (|checkSplitPunctuation| + (SUBSTRING |x| 0 (SPADDIFFERENCE |m| 2))) + (CONS (MAKESTRING "...") NIL))) + ('T + (APPEND (|checkSplitPunctuation| + (SUBSTRING |x| 0 (SPADDIFFERENCE |m| 1))) + (CONS (MAKESTRING "..") NIL))))) + ((OR (BOOT-EQUAL |lastchar| |$charPeriod|) + (BOOT-EQUAL |lastchar| |$charSemiColon|) + (BOOT-EQUAL |lastchar| |$charComma|)) + (CONS (SUBSTRING |x| 0 |m|) (CONS |lastchar| NIL))) + ((AND (> |m| 1) + (BOOT-EQUAL (ELT |x| (SPADDIFFERENCE |m| 1)) + |$charQuote|)) + (CONS (SUBSTRING |x| 0 (SPADDIFFERENCE |m| 1)) + (CONS (SUBSTRING |x| (SPADDIFFERENCE |m| 1) NIL) + NIL))) + ((> |m| (SPADLET |k| (|charPosition| |$charBack| |x| 0))) + (COND + ((EQL |k| 0) + (COND + ((OR (EQL |m| 1) (HGET |$htMacroTable| |x|) + (ALPHA-CHAR-P (ELT |x| 1))) + (CONS |x| NIL)) + ('T (SPADLET |v| (SUBSTRING |x| 2 NIL)) + (CONS (SUBSTRING |x| 0 2) + (|checkSplitPunctuation| |v|))))) + ('T (SPADLET |u| (SUBSTRING |x| 0 |k|)) + (SPADLET |v| (SUBSTRING |x| |k| NIL)) + (APPEND (|checkSplitPunctuation| |u|) + (|checkSplitPunctuation| |v|))))) + ((> |m| (SPADLET |k| (|charPosition| |$charDash| |x| 1))) + (SPADLET |u| (SUBSTRING |x| (PLUS |k| 1) NIL)) + (CONS (SUBSTRING |x| 0 |k|) + (CONS |$charDash| (|checkSplitPunctuation| |u|)))) + ('T (CONS |x| NIL)))))))))) + +;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)] + +(DEFUN |checkSplitOn| (|x|) + (PROG (|m| |char| |k| |l|) + (RETURN + (SEQ (COND + ((CHARP |x|) (CONS |x| NIL)) + ('T (SPADLET |l| |$charSplitList|) + (SPADLET |m| (MAXINDEX |x|)) + (DO () ((NULL |l|) NIL) + (SEQ (EXIT (PROGN + (SPADLET |char| (CAR |l|)) + (|do| (COND + ((AND (EQL |m| 0) + (BOOT-EQUAL (ELT |x| 0) |char|)) + (RETURN + (SPADLET |k| + (SPADDIFFERENCE 1)))) + ('T + (SPADLET |k| + (|charPosition| |char| |x| 0)) + (COND + ((AND (> |k| 0) + (BOOT-EQUAL + (ELT |x| + (SPADDIFFERENCE |k| 1)) + |$charBack|)) + (CONS |x| NIL)) + ((<= |k| |m|) (RETURN |k|)))))) + (SPADLET |l| (CDR |l|)))))) + (COND + ((NULL |l|) (CONS |x| NIL)) + ((BOOT-EQUAL |k| (SPADDIFFERENCE 1)) (CONS |char| NIL)) + ((EQL |k| 0) + (CONS |char| (CONS (SUBSTRING |x| 1 NIL) NIL))) + ((BOOT-EQUAL |k| (MAXINDEX |x|)) + (CONS (SUBSTRING |x| 0 |k|) (CONS |char| NIL))) + ('T + (CONS (SUBSTRING |x| 0 |k|) + (CONS |char| + (|checkSplitOn| + (SUBSTRING |x| (PLUS |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 + +(DEFUN |checkBalance| (|u|) + (PROG (|x| |openClose| |open| |top| |restStack| |stack|) + (RETURN + (SEQ (PROGN + (|checkBeginEnd| |u|) + (SPADLET |stack| NIL) + (DO () ((NULL |u|) NIL) + (SEQ (EXIT (PROGN + (|do| (PROGN + (SPADLET |x| (CAR |u|)) + (COND + ((SPADLET |openClose| + (|assoc| |x| |$checkPrenAlist|)) + (SPADLET |stack| + (CONS (CAR |openClose|) + |stack|))) + ((SPADLET |open| + (|rassoc| |x| + |$checkPrenAlist|)) + (COND + ((AND (PAIRP |stack|) + (PROGN + (SPADLET |top| + (QCAR |stack|)) + (SPADLET |restStack| + (QCDR |stack|)) + 'T)) + (COND + ((NEQUAL |open| |top|) + (|checkDocError| + (CONS + (MAKESTRING + "Mismatch: left ") + (CONS + (|checkSayBracket| + |top|) + (CONS + (MAKESTRING + " matches right ") + (CONS + (|checkSayBracket| + |open|) + NIL))))))) + (SPADLET |stack| |restStack|)) + ('T + (|checkDocError| + (CONS + (MAKESTRING + "Missing left ") + (CONS + (|checkSayBracket| |open|) + NIL))))))))) + (SPADLET |u| (CDR |u|)))))) + (COND + (|stack| (DO ((G167759 (NREVERSE |stack|) + (CDR G167759)) + (|x| NIL)) + ((OR (ATOM G167759) + (PROGN + (SETQ |x| (CAR G167759)) + NIL)) + NIL) + (SEQ (EXIT (|checkDocError| + (CONS + (MAKESTRING "Missing right ") + (CONS (|checkSayBracket| |x|) + NIL)))))))) + |u|))))) + +;checkSayBracket x == +; x = char '_( or x = char '_) => '"pren" +; x = char '_{ or x = char '_} => '"brace" +; '"bracket" + +(DEFUN |checkSayBracket| (|x|) + (COND + ((OR (BOOT-EQUAL |x| (|char| '|(|)) (BOOT-EQUAL |x| (|char| '|)|))) + (MAKESTRING "pren")) + ((OR (BOOT-EQUAL |x| (|char| '{)) (BOOT-EQUAL |x| (|char| '}))) + (MAKESTRING "brace")) + ('T (MAKESTRING "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 + +(DEFUN |checkBeginEnd| (|u|) + (PROG (|x| |ISTMP#1| |ISTMP#2| |y| |r| |beginEndStack|) + (RETURN + (SEQ (PROGN + (SPADLET |beginEndStack| NIL) + (DO () ((NULL |u|) NIL) + (SEQ (EXIT (PROGN + (IDENTITY + (PROGN + (SPADLET |x| (CAR |u|)) + (COND + ((AND (STRINGP |x|) + (BOOT-EQUAL (ELT |x| 0) + |$charBack|) + (> (|#| |x|) 2) + (NULL (HGET |$htMacroTable| |x|)) + (NULL + (BOOT-EQUAL |x| + (MAKESTRING "\\spadignore"))) + (BOOT-EQUAL (IFCAR (IFCDR |u|)) + |$charLbrace|) + (NULL + (OR + (|substring?| + (MAKESTRING "\\radiobox") |x| + 0) + (|substring?| + (MAKESTRING "\\inputbox") |x| + 0)))) + (|checkDocError| + (CONS '|Unexpected HT command: | + (CONS |x| NIL)))) + ((BOOT-EQUAL |x| + (MAKESTRING "\\beginitems")) + (SPADLET |beginEndStack| + (CONS '|items| |beginEndStack|))) + ((BOOT-EQUAL |x| + (MAKESTRING "\\begin")) + (COND + ((AND (PAIRP |u|) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |u|)) + (AND (PAIRP |ISTMP#1|) + (EQUAL (QCAR |ISTMP#1|) + |$charLbrace|) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |y| + (QCAR |ISTMP#2|)) + (SPADLET |r| + (QCDR |ISTMP#2|)) + 'T))))) + (BOOT-EQUAL (CAR |r|) + |$charRbrace|)) + (COND + ((NULL + (|member| |y| + |$beginEndList|)) + (|checkDocError| + (CONS + (MAKESTRING + "Unknown begin type: \\begin{") + (CONS |y| + (CONS (MAKESTRING "}") + NIL)))))) + (SPADLET |beginEndStack| + (CONS |y| |beginEndStack|)) + (SPADLET |u| |r|)) + ('T + (|checkDocError| + (CONS + (MAKESTRING + "Improper \\begin command") + NIL))))) + ((BOOT-EQUAL |x| + (MAKESTRING "\\item")) + (COND + ((|member| + (IFCAR |beginEndStack|) + '("items" "menu")) + NIL) + ((NULL |beginEndStack|) + (|checkDocError| + (CONS + (MAKESTRING + "\\item appears outside a \\begin-\\end") + NIL))) + ('T + (|checkDocError| + (CONS + (MAKESTRING + "\\item appears within a \\begin{") + (CONS (IFCAR |beginEndStack|) + (CONS (MAKESTRING "}..") + NIL))))))) + ((BOOT-EQUAL |x| + (MAKESTRING "\\end")) + (COND + ((AND (PAIRP |u|) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |u|)) + (AND (PAIRP |ISTMP#1|) + (EQUAL (QCAR |ISTMP#1|) + |$charLbrace|) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |y| + (QCAR |ISTMP#2|)) + (SPADLET |r| + (QCDR |ISTMP#2|)) + 'T))))) + (BOOT-EQUAL (CAR |r|) + |$charRbrace|)) + (COND + ((BOOT-EQUAL |y| + (IFCAR |beginEndStack|)) + (SPADLET |beginEndStack| + (CDR |beginEndStack|)) + (SPADLET |u| |r|)) + ('T + (|checkDocError| + (CONS + (MAKESTRING + "Trying to match \\begin{") + (CONS + (IFCAR |beginEndStack|) + (CONS + (MAKESTRING + "} with \\end{") + (CONS |y| (CONS '} NIL))))))))) + ('T + (|checkDocError| + (CONS + (MAKESTRING + "Improper \\end command") + NIL)))))))) + (SPADLET |u| (CDR |u|)))))) + (COND + (|beginEndStack| + (|checkDocError| + (CONS (MAKESTRING "Missing \\end{") + (CONS (CAR |beginEndStack|) + (CONS (MAKESTRING "}") NIL))))) + ('T '|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 + +(DEFUN |checkArguments| (|u|) + (PROG (|x| |k|) + (RETURN + (SEQ (PROGN + (DO () ((NULL |u|) NIL) + (SEQ (EXIT (PROGN + (|do| (PROGN + (SPADLET |x| (CAR |u|)) + (COND + ((NULL + (SPADLET |k| + (HGET |$htMacroTable| |x|))) + '|skip|) + ((EQL |k| 0) '|skip|) + ((> |k| 0) + (|checkHTargs| |x| (CDR |u|) |k| + NIL)) + ('T + (|checkHTargs| |x| (CDR |u|) + (SPADDIFFERENCE |k|) 'T))))) + (SPADLET |u| (CDR |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?) + +(DEFUN |checkHTargs| (|keyword| |u| |nargs| |integerValue?|) + (PROG () + (RETURN + (COND + ((EQL |nargs| 0) '|ok|) + ('T + (COND + ((NULL (SPADLET |u| (|checkLookForLeftBrace| |u|))) + (RETURN + (|checkDocError| + (CONS (MAKESTRING "Missing argument for ") + (CONS |keyword| NIL)))))) + (COND + ((NULL (SPADLET |u| (|checkLookForRightBrace| (IFCDR |u|)))) + (RETURN + (|checkDocError| + (CONS (MAKESTRING "Missing right brace for ") + (CONS |keyword| NIL)))))) + (|checkHTargs| |keyword| (CDR |u|) (SPADDIFFERENCE |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 + +(DEFUN |checkLookForLeftBrace| (|u|) + (PROG (|x|) + (RETURN + (SEQ (PROGN + (DO () ((NULL |u|) NIL) + (SEQ (EXIT (PROGN + (SPADLET |x| (CAR |u|)) + (COND + ((BOOT-EQUAL |x| |$charLbrace|) + (RETURN |u|))) + (COND + ((NEQUAL |x| |$charBlank|) (RETURN NIL)) + ('T (SPADLET |u| (CDR |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 + +(DEFUN |checkLookForRightBrace| (|u|) + (PROG (|x| |found| |count|) + (RETURN + (SEQ (PROGN + (SPADLET |count| 0) + (DO () ((NULL |u|) NIL) + (SEQ (EXIT (PROGN + (SPADLET |x| (CAR |u|)) + (|do| (COND + ((BOOT-EQUAL |x| |$charRbrace|) + (COND + ((EQL |count| 0) + (RETURN (SPADLET |found| |u|))) + ('T + (SPADLET |count| + (SPADDIFFERENCE |count| 1))))) + ((BOOT-EQUAL |x| |$charLbrace|) + (SPADLET |count| (PLUS |count| 1))))) + (SPADLET |u| (CDR |u|)))))) + |found|))))) + +;checkInteger s == +; CHARP s => false +; s = '"" => false +; and/[DIGIT_-CHAR_-P s.i for i in 0..MAXINDEX s] + +(DEFUN |checkInteger| (|s|) + (PROG () + (RETURN + (SEQ (COND + ((CHARP |s|) NIL) + ((BOOT-EQUAL |s| (MAKESTRING "")) NIL) + ('T + (PROG (G167927) + (SPADLET G167927 'T) + (RETURN + (DO ((G167933 NIL (NULL G167927)) + (G167934 (MAXINDEX |s|)) (|i| 0 (QSADD1 |i|))) + ((OR G167933 (QSGREATERP |i| G167934)) + G167927) + (SEQ (EXIT (SETQ G167927 + (AND G167927 + (DIGIT-CHAR-P (ELT |s| |i|))))))))))))))) + +;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)) + +(DEFUN |checkTransformFirsts| (|opname| |u| |margin|) + (PROG (|namestring| |s| |m| |infixOp| |p| |open| |close| |l| |n| |i| + |prefixOp| |j| |k| |firstWord|) + (RETURN + (PROGN + (SPADLET |namestring| (PNAME |opname|)) + (COND + ((BOOT-EQUAL |namestring| (MAKESTRING "Zero")) + (SPADLET |namestring| (MAKESTRING "0"))) + ((BOOT-EQUAL |namestring| (MAKESTRING "One")) + (SPADLET |namestring| (MAKESTRING "1"))) + ('T NIL)) + (COND + ((> |margin| 0) (SPADLET |s| (|leftTrim| |u|)) + (STRCONC (|fillerSpaces| |margin|) + (|checkTransformFirsts| |opname| |s| 0))) + ('T (SPADLET |m| (MAXINDEX |u|)) + (COND + ((> 2 |m|) |u|) + ((BOOT-EQUAL (ELT |u| 0) |$charBack|) |u|) + ((ALPHA-CHAR-P (ELT |u| 0)) + (SPADLET |i| + (OR (|checkSkipToken| |u| 0 |m|) (RETURN |u|))) + (SPADLET |j| + (OR (|checkSkipBlanks| |u| |i| |m|) + (RETURN |u|))) + (SPADLET |open| (ELT |u| |j|)) + (COND + ((OR (AND (BOOT-EQUAL |open| (|char| '[)) + (SPADLET |close| (|char| ']))) + (AND (BOOT-EQUAL |open| (|char| '|(|)) + (SPADLET |close| (|char| '|)|)))) + (SPADLET |k| + (|getMatchingRightPren| |u| (PLUS |j| 1) + |open| |close|)) + (COND + ((NEQUAL |namestring| + (SPADLET |firstWord| (SUBSTRING |u| 0 |i|))) + (|checkDocError| + (CONS (MAKESTRING + "Improper first word in comments: ") + (CONS |firstWord| NIL))) + |u|) + ((NULL |k|) + (COND + ((BOOT-EQUAL |open| (|char| '[)) + (|checkDocError| + (CONS (MAKESTRING + "Missing close bracket on first line: ") + (CONS |u| NIL)))) + ('T + (|checkDocError| + (CONS (MAKESTRING + "Missing close parenthesis on first line: ") + (CONS |u| NIL))))) + |u|) + ('T + (STRCONC (MAKESTRING "\\spad{") + (SUBSTRING |u| 0 (PLUS |k| 1)) + (MAKESTRING "}") + (SUBSTRING |u| (PLUS |k| 1) NIL))))) + ('T + (SPADLET |k| + (OR (|checkSkipToken| |u| |j| |m|) + (RETURN |u|))) + (SPADLET |infixOp| + (INTERN (SUBSTRING |u| |j| + (SPADDIFFERENCE |k| |j|)))) + (COND + ((NULL (GETL |infixOp| '|Led|)) + (COND + ((NEQUAL |namestring| + (SPADLET |firstWord| + (SUBSTRING |u| 0 |i|))) + (|checkDocError| + (CONS (MAKESTRING + "Improper first word in comments: ") + (CONS |firstWord| NIL))) + |u|) + ((AND (EQL (|#| (SPADLET |p| (PNAME |infixOp|))) + 1) + (SPADLET |open| (ELT |p| 0)) + (SPADLET |close| + (LASSOC |open| |$checkPrenAlist|))) + (SPADLET |l| + (|getMatchingRightPren| |u| + (PLUS |k| 1) |open| |close|)) + (COND + ((> |l| (MAXINDEX |u|)) + (SPADLET |l| (SPADDIFFERENCE |k| 1)))) + (STRCONC (MAKESTRING "\\spad{") + (SUBSTRING |u| 0 (PLUS |l| 1)) + (MAKESTRING "}") + (SUBSTRING |u| (PLUS |l| 1) NIL))) + ('T + (STRCONC (MAKESTRING "\\spad{") + (SUBSTRING |u| 0 |k|) (MAKESTRING "}") + (SUBSTRING |u| |k| NIL))))) + ('T + (SPADLET |l| + (OR (|checkSkipBlanks| |u| |k| |m|) + (RETURN |u|))) + (SPADLET |n| + (OR (|checkSkipToken| |u| |l| |m|) + (RETURN |u|))) + (COND + ((NEQUAL |namestring| (PNAME |infixOp|)) + (|checkDocError| + (CONS (MAKESTRING + "Improper initial operator in comments: ") + (CONS |infixOp| NIL))) + |u|) + ('T + (STRCONC (MAKESTRING "\\spad{") + (SUBSTRING |u| 0 |n|) (MAKESTRING "}") + (SUBSTRING |u| |n| NIL))))))))) + ('T + (SPADLET |i| + (OR (|checkSkipToken| |u| 0 |m|) (RETURN |u|))) + (COND + ((NEQUAL |namestring| + (SPADLET |firstWord| (SUBSTRING |u| 0 |i|))) + (|checkDocError| + (CONS (MAKESTRING + "Improper first word in comments: ") + (CONS |firstWord| NIL))) + |u|) + ('T (SPADLET |prefixOp| (INTERN (SUBSTRING |u| 0 |i|))) + (COND + ((NULL (GETL |prefixOp| '|Nud|)) |u|) + ('T + (SPADLET |j| + (OR (|checkSkipBlanks| |u| |i| |m|) + (RETURN |u|))) + (COND + ((BOOT-EQUAL (ELT |u| |j|) (|char| '|(|)) + (SPADLET |j| + (|getMatchingRightPren| |u| + (PLUS |j| 1) (|char| '|(|) + (|char| '|)|))) + (COND + ((> |j| |m|) |u|) + ('T + (STRCONC (MAKESTRING "\\spad{") + (SUBSTRING |u| 0 (PLUS |j| 1)) + (MAKESTRING "}") + (SUBSTRING |u| (PLUS |j| 1) NIL))))) + ('T + (SPADLET |k| + (OR (|checkSkipToken| |u| |j| |m|) + (RETURN |u|))) + (COND + ((NEQUAL |namestring| + (SPADLET |firstWord| + (SUBSTRING |u| 0 |i|))) + (|checkDocError| + (CONS (MAKESTRING + "Improper first word in comments: ") + (CONS |firstWord| NIL))) + |u|) + ('T + (STRCONC (MAKESTRING "\\spad{") + (SUBSTRING |u| 0 |k|) + (MAKESTRING "}") + (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 + +(DEFUN |getMatchingRightPren| (|u| |j| |open| |close|) + (PROG (|m| |c| |found| |count|) + (RETURN + (SEQ (PROGN + (SPADLET |count| 0) + (SPADLET |m| (MAXINDEX |u|)) + (DO ((|i| |j| (+ |i| 1))) ((> |i| |m|) NIL) + (SEQ (EXIT (PROGN + (SPADLET |c| (ELT |u| |i|)) + (|do| (COND + ((BOOT-EQUAL |c| |close|) + (COND + ((EQL |count| 0) + (RETURN (SPADLET |found| |i|))) + ('T + (SPADLET |count| + (SPADDIFFERENCE |count| 1))))) + ((BOOT-EQUAL |c| |open|) + (SPADLET |count| (PLUS |count| 1))))))))) + |found|))))) + +;checkSkipBlanks(u,i,m) == +; while i < m and u.i = $charBlank repeat i := i + 1 +; i = m => nil +; i + +(DEFUN |checkSkipBlanks| (|u| |i| |m|) + (SEQ (PROGN + (DO () + ((NULL (AND (> |m| |i|) + (BOOT-EQUAL (ELT |u| |i|) |$charBlank|))) + NIL) + (SEQ (EXIT (SPADLET |i| (PLUS |i| 1))))) + (COND ((BOOT-EQUAL |i| |m|) NIL) ('T |i|))))) + +;checkSkipToken(u,i,m) == +; ALPHA_-CHAR_-P(u.i) => checkSkipIdentifierToken(u,i,m) +; checkSkipOpToken(u,i,m) + +(DEFUN |checkSkipToken| (|u| |i| |m|) + (COND + ((ALPHA-CHAR-P (ELT |u| |i|)) + (|checkSkipIdentifierToken| |u| |i| |m|)) + ('T (|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 + +(DEFUN |checkSkipOpToken| (|u| |i| |m|) + (SEQ (PROGN + (DO () + ((NULL (AND (> |m| |i|) + (NULL (|checkAlphabetic| (ELT |u| |i|))) + (NULL (|member| (ELT |u| |i|) + |$charDelimiters|)))) + NIL) + (SEQ (EXIT (SPADLET |i| (PLUS |i| 1))))) + (COND ((BOOT-EQUAL |i| |m|) NIL) ('T |i|))))) + +;checkSkipIdentifierToken(u,i,m) == +; while i < m and checkAlphabetic u.i repeat i := i + 1 +; i = m => nil +; i + +(DEFUN |checkSkipIdentifierToken| (|u| |i| |m|) + (SEQ (PROGN + (DO () + ((NULL (AND (> |m| |i|) (|checkAlphabetic| (ELT |u| |i|)))) + NIL) + (SEQ (EXIT (SPADLET |i| (PLUS |i| 1))))) + (COND ((BOOT-EQUAL |i| |m|) NIL) ('T |i|))))) + +;checkAlphabetic c == +; ALPHA_-CHAR_-P c or DIGITP c or MEMQ(c,$charIdentifierEndings) + +(DEFUN |checkAlphabetic| (|c|) + (OR (ALPHA-CHAR-P |c|) (DIGITP |c|) + (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() + +(DEFUN |docreport| (|nam|) + (PROGN + (OBEY (MAKESTRING "rm docreport.input")) + (OBEY (STRCONC (MAKESTRING "echo \")bo setOutStream('") + (STRINGIMAGE |nam|) (MAKESTRING ")\" > temp.input"))) + (OBEY (MAKESTRING + "cat docreport.header temp.input > docreport.input")) + (OBEY (STRCONC (MAKESTRING "awk '/") (STRINGIMAGE |nam|) + (MAKESTRING + "/ {printf(\")co %s.spad\\n\",$2)}' whofiles > temp.input"))) + (OBEY (MAKESTRING "cat docreport.input temp.input > temp1.input")) + (OBEY (MAKESTRING + "cat temp1.input docreport.trailer > docreport.input")) + (OBEY (MAKESTRING "rm temp.input")) + (OBEY (MAKESTRING "rm temp1.input")) + (SETQ /EDITFILE (MAKESTRING "docreport.input")) + (/RQ))) + +;setOutStream nam == +; filename := STRCONC('"/tmp/",STRINGIMAGE nam,".docreport") +; $outStream := MAKE_-OUTSTREAM filename + +(DEFUN |setOutStream| (|nam|) + (PROG (|filename|) + (RETURN + (PROGN + (SPADLET |filename| + (STRCONC (MAKESTRING "/tmp/") (STRINGIMAGE |nam|) + (INTERN ".docreport" "BOOT"))) + (SPADLET |$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 + +(DEFUN |whoOwns| (|con|) + (PROG (|filename| |quoteChar| |instream| |value|) + (RETURN + (COND + ((NULL |$exposeFlag|) NIL) + ('T (SPADLET |filename| (GETDATABASE |con| 'SOURCEFILE)) + (SPADLET |quoteChar| (|char| '|"|)) + (OBEY (STRCONC (MAKESTRING "awk '$2 == ") |quoteChar| + |filename| |quoteChar| + (MAKESTRING + " {print $1}' whofiles > /tmp/temp"))) + (SPADLET |instream| (MAKE-INSTREAM (MAKESTRING "/tmp/temp"))) + (SPADLET |value| + (COND + ((EOFP |instream|) NIL) + ('T (READLINE |instream|)))) + (SHUT |instream|) |value|))))) + +;--======================================================================= +;-- Report Documentation Error +;--======================================================================= +;checkDocError1 u == +;--when compiling for documentation, ignore certain errors +; BOUNDP '$compileDocumentation and $compileDocumentation => nil +; checkDocError u + +(DEFUN |checkDocError1| (|u|) + (COND + ((AND (BOUNDP '|$compileDocumentation|) |$compileDocumentation|) + NIL) + ('T (|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) + +(DEFUN |checkDocError| (|u|) + (PROG (|msg|) + (RETURN + (PROGN + (SPADLET |$checkErrorFlag| 'T) + (SPADLET |msg| + (COND + (|$recheckingFlag| + (COND + (|$constructorName| (|checkDocMessage| |u|)) + ('T (|concat| (MAKESTRING "> ") |u|)))) + (|$constructorName| (|checkDocMessage| |u|)) + ('T |u|))) + (COND + ((AND |$exposeFlag| |$exposeFlagHeading|) + (SAYBRIGHTLY1 |$exposeFlagHeading| |$outStream|) + (|sayBrightly| |$exposeFlagHeading|) + (SPADLET |$exposeFlagHeading| NIL))) + (|sayBrightly| |msg|) + (COND + (|$exposeFlag| (SAYBRIGHTLY1 |msg| |$outStream|)) + ('T NIL)))))) + +; --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) + +(DEFUN |checkDocMessage| (|u|) + (PROG (|sourcefile| |person| |middle|) + (RETURN + (PROGN + (SPADLET |sourcefile| + (GETDATABASE |$constructorName| 'SOURCEFILE)) + (SPADLET |person| + (OR (|whoOwns| |$constructorName|) (MAKESTRING "---"))) + (SPADLET |middle| + (COND + ((BOUNDP '|$x|) + (CONS (MAKESTRING "(") + (CONS |$x| (CONS (MAKESTRING "): ") NIL)))) + ('T (CONS (MAKESTRING ": ") NIL)))) + (|concat| |person| (MAKESTRING ">") |sourcefile| + (MAKESTRING "-->") |$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 + +(DEFUN |checkDecorateForHt| (|u|) + (PROG (|x| |count| |spadflag|) + (RETURN + (SEQ (PROGN + (SPADLET |count| 0) + (SPADLET |spadflag| NIL) + (DO () ((NULL |u|) NIL) + (SEQ (EXIT (PROGN + (SPADLET |x| (CAR |u|)) + (|do| (PROGN + (COND + ((BOOT-EQUAL |x| + (MAKESTRING "\\em")) + (COND + ((> |count| 0) + (SPADLET |spadflag| + (SPADDIFFERENCE |count| 1))) + ('T + (|checkDocError| + (CONS + (MAKESTRING + "\\em must be enclosed in braces") + NIL)))))) + (COND + ((|member| |x| + '("\\s" "\\spadop" "\\spadtype" + "\\spad" "\\spadpaste" + "\\spadcommand" "\\footnote")) + (SPADLET |spadflag| |count|)) + ((BOOT-EQUAL |x| |$charLbrace|) + (SPADLET |count| + (PLUS |count| 1))) + ((BOOT-EQUAL |x| |$charRbrace|) + (SPADLET |count| + (SPADDIFFERENCE |count| 1)) + (COND + ((BOOT-EQUAL |spadflag| + |count|) + (SPADLET |spadflag| NIL)) + ('T NIL))) + ((AND (NULL |spadflag|) + (|member| |x| + '("+" "*" "=" "==" "->"))) + (COND + (|$checkingXmptex?| + (|checkDocError| + (CONS '|Symbol | + (CONS |x| + (CONS + (MAKESTRING + " appearing outside \\spad{}") + NIL))))) + ('T NIL))) + ('T NIL)) + (COND + ((OR + (BOOT-EQUAL |x| + (MAKESTRING "$")) + (BOOT-EQUAL |x| + (MAKESTRING "%"))) + (|checkDocError| + (CONS (MAKESTRING "Unescaped ") + (CONS |x| NIL))))))) + (SPADLET |u| (CDR |u|)))))) + |u|))))) + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document}