diff --git a/books/bookvol9.pamphlet b/books/bookvol9.pamphlet index 12cfc11..c296aba 100644 --- a/books/bookvol9.pamphlet +++ b/books/bookvol9.pamphlet @@ -381,7 +381,7 @@ Equation(S: Type): public == private where ++ the lhs of eq2 should be a kernel private ==> add - Rep := Record(lhs: S, rhs: S) + Rep := Recod(lhs: S, rhs: S) eq1,eq2: $ s : S if S has IntegralDomain then @@ -7644,6 +7644,53 @@ Make pattern variable substitutions. \end{chunk} +\defun{checkExtract}{checkExtract} +\calls{checkExtract}{firstNonBlankPosition} +\calls{checkExtract}{substring?} +\calls{checkExtract}{charPosition} +\calls{checkExtract}{nequal} +\calls{checkExtract}{length} +\calls{checkExtract}{nreverse} +\begin{chunk}{defun checkExtract} +(defun |checkExtract| (header lines) + (let (line u margin firstLines m k j i acc) + ;; throw away lines until we find the header + (while lines + (setq line (car lines)) + (setq k (|firstNonBlankPosition| line)) + (when (|substring?| header line k) (return)) + (pop lines)) + ;; collect up the lines + (when lines + (setq u (car lines)) + (setq j (|charPosition| (|char| '|:|) u k)) + (setq margin k) + (setq firstLines + (if (nequal (setq k (|firstNonBlankPosition| u (1+ j))) -1) + (cons (substring u (1+ j) nil) (cdr lines)) + (cdr lines))) + (setq acc nil) + ;; look for another header; if found skip all the rest of the lines + (loop for line in firstLines + do + (setq m (|#| line)) + (cond + ;; include if blank + ((eql (setq k (|firstNonBlankPosition| line)) -1) '|skip|) + ;; include if indented + ((> k margin) '|skip|) + ;; include if not uppercased + ((null (upper-case-p (elt line k))) '|skip|) + ;; include if not colon + ((eql (setq j (|charPosition| (|char| '|:|) line k)) m) '|skip|) + ;; include if blank before colon + ((> j (setq i (|charPosition| (|char| '| |) line (1+ k)))) '|skip|) + (t (return nil))) + (setq acc (cons line acc))) + (nreverse acc)))) + +\end{chunk} + \defun{lisplibDoRename}{lisplibDoRename} \calls{lisplibDoRename}{replaceFile} \refsdollar{lisplibDoRename}{spadLibFT} @@ -19148,6 +19195,736 @@ Stack of results of reduced productions. \end{chunk} +\chapter{Comment handlers} +\defun{recordSignatureDocumentation}{recordSignatureDocumentation} +\calls{recordSignatureDocumentation}{recordDocumentation} +\calls{recordSignatureDocumentation}{postTransform} +\begin{chunk}{defun recordSignatureDocumentation} +(defun |recordSignatureDocumentation| (opSig lineno) + (|recordDocumentation| (cdr (|postTransform| opSig)) lineno)) + +\end{chunk} + + +\defun{recordAttributeDocumentation}{recordAttributeDocumentation} +\calls{recordAttributeDocumentation}{opOf} +\calls{recordAttributeDocumentation}{pname} +\calls{recordAttributeDocumentation}{upper-case-p} +\calls{recordAttributeDocumentation}{recordDocumentation} +\calls{recordAttributeDocumentation}{ifcdr} +\calls{recordAttributeDocumentation}{postTransform} +\begin{chunk}{defun recordAttributeDocumentation} +(defun |recordAttributeDocumentation| (arg lineno) + (let (att name) + (setq att (cadr arg)) + (setq name (|opOf| att)) + (cond + ((upper-case-p (elt (pname name) 0)) nil) + (t + (|recordDocumentation| + (list name (cons '|attribute| (ifcdr (|postTransform| att)))) lineno))))) + +\end{chunk} + +\defun{recordDocumentation}{recordDocumentation} +\calls{recordDocumentation}{recordHeaderDocumentation} +\calls{recordDocumentation}{collectComBlock} +\defsdollar{recordDocumentation}{maxSignatureLineNumber} +\defsdollar{recordDocumentation}{docList} +\begin{chunk}{defun recordDocumentation} +(defun |recordDocumentation| (key lineno) + (let (u) + (declare (special |$docList| |$maxSignatureLineNumber|)) + (|recordHeaderDocumentation| lineno) + (setq u (|collectComBlock| lineno)) + (setq |$maxSignatureLineNumber| lineno) + (setq |$docList| (cons (cons key u) |$docList|)))) + +\end{chunk} + +\defun{recordHeaderDocumentation}{recordHeaderDocumentation} +\calls{recordHeaderDocumentation}{assocright} +\refsdollar{recordHeaderDocumentation}{maxSignatureLineNumber} +\refsdollar{recordHeaderDocumentation}{comblocklist} +\refsdollar{recordHeaderDocumentation}{headerDocumentation} +\defsdollar{recordHeaderDocumentation}{headerDocumentation} +\defsdollar{recordHeaderDocumentation}{comblocklist} +\begin{chunk}{defun recordHeaderDocumentation} +(defun |recordHeaderDocumentation| (lineno) + (let (al) + (declare (special |$headerDocumentation| |$maxSignatureLineNumber| + $comblocklist)) + (when (eql |$maxSignatureLineNumber| 0) + (setq al + (loop for p in $comblocklist + when (or (null (car p)) (null lineno) (> lineno (car p))) + collect p)) + (setq $comblocklist (setdifference $comblocklist al)) + (setq |$headerDocumentation| (assocright al)) + (when |$headerDocumentation| (setq |$maxSignatureLineNumber| 1)) + |$headerDocumentation|))) + +\end{chunk} + +\defun{collectComBlock}{collectComBlock} +\calls{collectComBlock}{collectAndDeleteAssoc} +\defsdollar{collectComBlock}{comblocklist} +\begin{chunk}{defun collectComBlock} +(defun |collectComBlock| (x) + (let (val u) + (declare (special $comblocklist)) + (cond + ((and (consp $comblocklist) + (consp (qcar $comblocklist)) + (equal (qcaar $comblocklist) x)) + (setq val (qcdar $comblocklist)) + (setq u (append val (|collectAndDeleteAssoc| x))) + (setq $comblocklist (cdr $comblocklist)) + u) + (t (|collectAndDeleteAssoc| x))))) + +\end{chunk} + +\defun{collectAndDeleteAssoc}{collectAndDeleteAssoc} +\begin{verbatim} + u is (.. (x . a) .. (x . b) .. ) ==> (a b ..) +\end{verbatim} +deleting entries from u assumes that the first element is useless +\refsdollar{collectAndDeleteAssoc}{comblocklist} +\begin{chunk}{defun collectAndDeleteAssoc} +(defun |collectAndDeleteAssoc| (x) + (let (r res s) + (declare (special $comblocklist)) + (maplist + #'(lambda (y) + (when (setq s (cdr y)) + (do () + ((null (and s (consp (car s)) (equal (qcar (car s)) x))) nil) + (setq r (qcdr (car s))) + (setq res (append res r)) + (setq s (cdr s)) + (rplacd y s)))) + $comblocklist) + res)) + +\end{chunk} + +\defun{finalizeDocumentation}{finalizeDocumentation} +\calls{finalizeDocumentation}{bright} +\calls{finalizeDocumentation}{sayMSG} +\calls{finalizeDocumentation}{stringimage} +\calls{finalizeDocumentation}{strconc} +\calls{finalizeDocumentation}{sayKeyedMsg} +\calls{finalizeDocumentation}{form2String} +\calls{finalizeDocumentation}{formatOpSignature} +\calls{finalizeDocumentation}{transDocList} +\calls{finalizeDocumentation}{msubst} +\calls{finalizeDocumentation}{assocleft} +\calls{finalizeDocumentation}{remdup} +\calls{finalizeDocumentation}{macroExpand} +\calls{finalizeDocumentation}{sublislis} +\refsdollar{finalizeDocumentation}{e} +\refsdollar{finalizeDocumentation}{lisplibForm} +\refsdollar{finalizeDocumentation}{docList} +\refsdollar{finalizeDocumentation}{op} +\refsdollar{finalizeDocumentation}{comblocklist} +\refsdollar{finalizeDocumentation}{FormalMapVariableList} +\begin{chunk}{defun finalizeDocumentation} +(defun |finalizeDocumentation| () + (labels ( + (fn (x env) + (declare (special |$lisplibForm| |$FormalMapVariableList|)) + (cond + ((atom x) (list x nil)) + (t + (when (> (|#| x) 2) (setq x (take 2 x))) + (sublislis |$FormalMapVariableList| (cdr |$lisplibForm|) + (|macroExpand| x env))))) + (hn (u) + ; ((op,sig,doc), ...) --> ((op ((sig doc) ...)) ...) + (let (opList) + (setq opList (remdup (assocleft u))) + (loop for op in opList + collect + (cons op + (loop for item in u + when (equal op (first item)) + collect (cons (second item) (third item)))))))) + (let (unusedCommentLineNumbers docList u noHeading attributes signatures name + bigcnt s litcnt a n) + (declare (special |$e| |$lisplibForm| |$docList| |$op| $comblocklist)) + (setq unusedCommentLineNumbers + (loop for x in $comblocklist + do (cdr x) + collect x)) + (setq docList (msubst '$ '% (|transDocList| |$op| |$docList|))) + (cond + ((setq u + (loop for sig in docList + when (null (cdr sig)) + collect sig)) + (loop for y in u + do + (cond + ((eq y '|constructor|) (setq noHeading t)) + ((and (consp y) (consp (qcdr y)) (eq (qcddr y) nil) (consp (qcadr y)) + (eq (qcaadr y) '|attribute|)) + (setq attributes (cons (cons (qcar y) (qcdadr y)) attributes))) + (t (setq signatures (cons y signatures))))) + (setq name (car |$lisplibForm|)) + (when (or noHeading signatures attributes unusedCommentLineNumbers) + (|sayKeyedMsg| 'S2CD0001 nil) + (setq bigcnt 1) + (when (or noHeading signatures attributes) + (|sayKeyedMsg| 'S2CD0002 + (cons (strconc (stringimage bigcnt) ".") (list name))) + (setq bigcnt (1+ bigcnt)) + (setq litcnt 1) + (when noHeading + (|sayKeyedMsg| 'S2CD0003 + (list (strconc "(" (stringimage litcnt) ")") name)) + (setq litcnt (1+ litcnt))) + (when signatures + (|sayKeyedMsg| 'S2CD0004 + (list (strconc "(" (stringimage litcnt) ")"))) + (setq litcnt (1+ litcnt)) + (loop for item in signatures + do + (setq s (|formatOpSignature| (first item) (second item))) + (|sayMSG| + (if (atom s) + (list '|%x9| s) + (cons '|%x9| s))))) + (when attributes + (|sayKeyedMsg| 'S2CD0005 + (list (strconc "(" (stringimage litcnt) ")"))) + (setq litcnt (1+ litcnt)) + (loop for x in attributes + do + (setq a (|form2String| x)) + (|sayMSG| + (if (atom a) + (list '|%x9| a) + (cons '|%x9| a)))))) + (when unusedCommentLineNumbers + (|sayKeyedMsg| 'S2CD0006 + (list (strconc (stringimage bigcnt) ".") name)) + (loop for item in unusedCommentLineNumbers + do (|sayMSG| + (cons " " + (append (|bright| n) (list " " (second item)))))))))) + (hn + (loop for item in docList + collect (fn (car item) |$e|)))))) + +\end{chunk} + +\section{Transformation of ++ comments} +\defun{transDocList}{transDocList} +\calls{transDocList}{sayBrightly} +\calls{transDocList}{transDoc} +\calls{transDocList}{checkDocError} +\calls{transDocList}{checkDocError1} +\refsdollar{transDocList}{constructorName} +\begin{chunk}{defun transDocList} +(defun |transDocList| (|$constructorName| doclist) + (declare (special |$constructorName|)) + (let (commentList conEntry acc) + (|sayBrightly| + (list " Processing " |$constructorName| " for Browser database:")) + (setq commentList (|transDoc| |$constructorName| doclist)) + (setq acc nil) + (loop for entry in commentList + do + (cond + ((and (consp entry) (eq (qcar entry) '|constructor|) + (consp (qcdr entry)) (eq (qcddr entry) nil)) + (if conEntry + (|checkDocError| (list "Spurious comments: " (qcadr entry))) + (setq conEntry entry))) + (t (setq acc (cons entry acc))))) + (if conEntry + (cons conEntry acc) + (progn + (|checkDocError1| (list "Missing Description")) + acc)))) + +\end{chunk} + +\defun{transDoc}{transDoc} +\calls{transDoc}{checkDocError1} +\calls{transDoc}{checkTrim} +\calls{transDoc}{checkExtract} +\calls{transDoc}{transformAndRecheckComments} +\calls{transDoc}{nreverse} +\refsdollar{transDoc}{x} +\refsdollar{transDoc}{attribute?} +\defsdollar{transDoc}{x} +\defsdollar{transDoc}{attribute?} +\defsdollar{transDoc}{argl} +\begin{chunk}{defun transDoc} +(defun |transDoc| (conname doclist) + (declare (ignore conname)) + (let (|$x| |$attribute?| |$argl| rlist lines u v longline acc) + (declare (special |$x| |$attribute?| |$argl|)) + (setq |$x| nil) + (setq rlist (reverse doclist)) + (loop for item in rlist + do + (setq |$x| (car item)) + (setq lines (cdr item)) + (setq |$attribute?| + (and (consp |$x|) (consp (qcdr |$x|)) (eq (qcddr |$x|) nil) + (consp (qcadr |$x|)) (eq (qcdadr |$x|) nil) + (eq (qcaadr |$x|) '|attribute|))) + (cond + ((null lines) + (unless |$attribute?| (|checkDocError1| (list "Not documented!!!!")))) + (t + (setq u + (|checkTrim| |$x| + (cond + ((stringp lines) (list lines)) + ((eq |$x| '|constructor|) (car lines)) + (t lines)))) + (setq |$argl| nil) ;; possibly unused -- tpd + (setq longline + (cond + ((eq |$x| '|constructor|) + (setq v + (or + (|checkExtract| "Description:" u) + (and u (|checkExtract| "Description:" + (cons (strconc "Description: " (car u)) (cdr u)))))) + (|transformAndRecheckComments| '|constructor| (or v u))) + (t (|transformAndRecheckComments| |$x| u)))) + (setq acc (cons (list |$x| longline) acc))))) + (nreverse acc))) + +\end{chunk} + +\defun{transformAndRecheckComments}{transformAndRecheckComments} +\calls{transformAndRecheckComments}{sayBrightly} +\refsdollar{transformAndRecheckComments}{exposeFlagHeading} +\defsdollar{transformAndRecheckComments}{checkingXmptex?} +\defsdollar{transformAndRecheckComments}{x} +\defsdollar{transformAndRecheckComments}{name} +\defsdollar{transformAndRecheckComments}{origin} +\defsdollar{transformAndRecheckComments}{recheckingFlag} +\defsdollar{transformAndRecheckComments}{exposeFlagHeading} +\begin{chunk}{defun transformAndRecheckComments} +(defun |transformAndRecheckComments| (name lines) + (let (|$x| |$name| |$origin| |$recheckingFlag| |$exposeFlagHeading| u) + (declare (special |$x| |$name| |$origin| |$recheckingFlag| + |$exposeFlagHeading| |$exposeFlag| |$checkingXmptex?|)) + (setq |$checkingXmptex?| nil) + (setq |$x| name) + (setq |$name| '|GlossaryPage|) + (setq |$origin| '|gloss|) + (setq |$recheckingFlag| nil) + (setq |$exposeFlagHeading| (list "--------" name "---------")) + (unless |$exposeFlag| (|sayBrightly| |$exposeFlagHeading|)) + (setq u (|checkComments| name lines)) + (setq |$recheckingFlag| t) + (|checkRewrite| name (list u)) + (setq |$recheckingFlag| nil) + u)) + +\end{chunk} + +\defun{checkDocError1}{checkDocError1} +\calls{checkDocError1}{checkDocError} +\refsdollar{checkDocError1}{compileDocumentation} +\begin{chunk}{defun checkDocError1} +(defun |checkDocError1| (u) + (declare (special |$compileDocumentation|)) + (if (and (boundp '|$compileDocumentation|) |$compileDocumentation|) + nil + (|checkDocError| u))) + +\end{chunk} + +\defun{checkDocError}{checkDocError} +\calls{checkDocError}{checkDocMessage} +\calls{checkDocError}{concat} +\calls{checkDocError}{saybrightly1} +\calls{checkDocError}{sayBrightly} +\refsdollar{checkDocError}{checkErrorFlag} +\refsdollar{checkDocError}{recheckingFlag} +\refsdollar{checkDocError}{constructorName} +\refsdollar{checkDocError}{exposeFlag} +\refsdollar{checkDocError}{exposeFlagHeading} +\refsdollar{checkDocError}{outStream} +\defsdollar{checkDocError}{checkErrorFlag} +\defsdollar{checkDocError}{exposeFlagHeading} +\begin{chunk}{defun checkDocError} +(defun |checkDocError| (u) + (let (msg) + (declare (special |$outStream| |$exposeFlag| |$exposeFlagHeading| + |$constructorName| |$recheckingFlag| |$checkErrorFlag|)) + (setq |$checkErrorFlag| t) + (setq msg + (cond + (|$recheckingFlag| + (if |$constructorName| + (|checkDocMessage| u) + (|concat| "> " u))) + (|$constructorName| (|checkDocMessage| u)) + (t u))) + (when (and |$exposeFlag| |$exposeFlagHeading|) + (saybrightly1 |$exposeFlagHeading| |$outStream|) + (|sayBrightly| |$exposeFlagHeading|) + (setq |$exposeFlagHeading| nil)) + (|sayBrightly| msg) + (when |$exposeFlag| (saybrightly1 msg |$outStream|)))) + +\end{chunk} + +\defun{checkDocMessage}{checkDocMessage} +\calls{checkDocMessage}{getdatabase} +\calls{checkDocMessage}{whoOwns} +\calls{checkDocMessage}{concat} +\refsdollar{checkDocMessage}{x} +\refsdollar{checkDocMessage}{constructorName} +\begin{chunk}{defun checkDocMessage} +(defun |checkDocMessage| (u) + (let (sourcefile person middle) + (declare (special |$constructorName| |$x|)) + (setq sourcefile (getdatabase |$constructorName| 'sourcefile)) + (setq person (or (|whoOwns| |$constructorName|) "---")) + (setq middle + (if (boundp '|$x|) + (list "(" |$x| "): ") + (list ": "))) + (|concat| person ">" sourcefile "-->" |$constructorName| middle u))) + +\end{chunk} + +\defun{checkComments}{checkComments} +\calls{checkComments}{checkGetMargin} +\calls{checkComments}{nequal} +\calls{checkComments}{checkTransformFirsts} +\calls{checkComments}{checkIndentedLines} +\calls{checkComments}{checkGetArgs} +\calls{checkComments}{newString2Words} +\calls{checkComments}{checkAddSpaces} +\calls{checkComments}{checkIeEg} +\calls{checkComments}{checkSplit2Words} +\calls{checkComments}{checkBalance} +\calls{checkComments}{checkArguments} +\calls{checkComments}{checkFixCommonProblems} +\calls{checkComments}{checkDecorate} +\calls{checkComments}{strconc} +\calls{checkComments}{checkAddPeriod} +\calls{checkComments}{pp} +\refsdollar{checkComments}{attribute?} +\refsdollar{checkComments}{checkErrorFlag} +\defsdollar{checkComments}{argl} +\defsdollar{checkComments}{checkErrorFlag} +\begin{chunk}{defun checkComments} +(defun |checkComments| (nameSig lines) + (let (|$checkErrorFlag| margin w verbatim u2 okBefore u v res) + (declare (special |$checkErrorFlag| |$argl| |$attribute?|)) + (setq |$checkErrorFlag| nil) + (setq margin (|checkGetMargin| lines)) + (cond + ((and (or (null (boundp '|$attribute?|)) (null |$attribute?|)) + (nequal nameSig '|constructor|)) + (setq lines + (cons + (|checkTransformFirsts| (car nameSig) (car lines) margin) + (cdr lines))))) + (setq u (|checkIndentedLines| lines margin)) + (setq |$argl| (|checkGetArgs| (car u))) + (setq u2 nil) + (setq verbatim nil) + (loop for x in u + do (setq w (|newString2Words| x)) + (cond + (verbatim + (cond + ((and w (equal (car w) "\\end{verbatim}")) + (setq verbatim nil) + (setq u2 (append u2 w))) + (t + (setq u2 (append u2 (list x)))))) + ((and w (equal (car w) "\\begin{verbatim}")) + (setq verbatim t) + (setq u2 (append u2 w))) + (t (setq u2 (append u2 w))))) + (setq u u2) + (setq u (|checkAddSpaces| u)) + (setq u (|checkIeEg| u)) + (setq u (|checkSplit2Words| u)) + (|checkBalance| u) + (setq okBefore (null |$checkErrorFlag|)) + (|checkArguments| u) + (when |$checkErrorFlag| (setq u (|checkFixCommonProblem| u))) + (setq v (|checkDecorate| u)) + (setq res + (let ((result "")) + (loop for y in v + do (setq result (strconc result y))) + result)) + (setq res (|checkAddPeriod| res)) + (when |$checkErrorFlag| (|pp| res)) + res)) + +\end{chunk} + +\defun{checkTransformFirsts}{checkTransformFirsts} +\calls{checkTransformFirsts}{pname} +\calls{checkTransformFirsts}{leftTrim} +\calls{checkTransformFirsts}{fillerSpaces} +\calls{checkTransformFirsts}{checkTransformFirsts} +\calls{checkTransformFirsts}{maxindex} +\calls{checkTransformFirsts}{checkSkipToken} +\calls{checkTransformFirsts}{checkSkipBlanks} +\calls{checkTransformFirsts}{getMatchingRightPren} +\calls{checkTransformFirsts}{nequal} +\calls{checkTransformFirsts}{checkDocError} +\calls{checkTransformFirsts}{strconc} +\calls{checkTransformFirsts}{getl} +\calls{checkTransformFirsts}{lassoc} +\refsdollar{checkTransformFirsts}{checkPrenAlist} +\refsdollar{checkTransformFirsts}{charBack} +\begin{chunk}{defun checkTransformFirsts} +(defun |checkTransformFirsts| (opname u margin) + (prog (namestring s m infixOp p open close z n i prefixOp j k firstWord) + (declare (special |$checkPrenAlist| |$charBack|)) + (return + (progn +; case 1: \spad{... +; case 2: form(args) + (setq namestring (pname opname)) + (cond + ((equal namestring "Zero") (setq namestring "0")) + ((equal namestring "One") (setq namestring "1")) + (t nil)) + (cond + ((> margin 0) + (setq s (|leftTrim| u)) + (strconc (|fillerSpaces| margin) (|checkTransformFirsts| opname s 0))) + (t + (setq m (maxindex u)) + (cond + ((> 2 m) u) + ((equal (elt u 0) |$charBack|) u) + ((alpha-char-p (elt u 0)) + (setq i (or (|checkSkipToken| u 0 m) (return u))) + (setq j (or (|checkSkipBlanks| u i m) (return u))) + (setq open (elt u j)) + (cond + ((or (and (equal open #\[) (setq close #\])) + (and (equal open #\() (setq close #\)))) + (setq k (|getMatchingRightPren| u (1+ j) open close)) + (cond + ((nequal namestring (setq firstWord (substring u 0 i))) + (|checkDocError| + (list "Improper first word in comments: " firstWord)) + u) + ((null k) + (cond + ((equal open (|char| '[)) + (|checkDocError| + (list "Missing close bracket on first line: " u))) + (t + (|checkDocError| + (list "Missing close parenthesis on first line: " u)))) + u) + (t + (strconc "\\spad{" (substring u 0 (1+ k)) "}" + (substring u (1+ k) nil))))) + (t + (setq k (or (|checkSkipToken| u j m) (return u))) + (setq infixOp (intern (substring u j (- k j)))) + (cond +; case 3: form arg + ((null (getl infixOp '|Led|)) + (cond + ((nequal namestring (setq firstWord (substring u 0 i))) + (|checkDocError| + (list "Improper first word in comments: " firstWord)) + u) + ((and (eql (|#| (setq p (pname infixOp))) 1) + (setq open (elt p 0)) + (setq close (lassoc open |$checkPrenAlist|))) + (setq z (|getMatchingRightPren| u (1+ k) open close)) + (when (> z (maxindex u)) (setq z (1- k))) + (strconc "\\spad{" (substring u 0 (1+ z)) "}" + (substring u (1+ z) nil))) + (t + (strconc "\\spad{" (substring u 0 k) "}" + (substring u k nil))))) + (t + (setq z (or (|checkSkipBlanks| u k m) (return u))) + (setq n (or (|checkSkipToken| u z m) (return u))) + (cond + ((nequal namestring (pname infixOp)) + (|checkDocError| + (list "Improper initial operator in comments: " infixOp)) + u) + (t + (strconc "\\spad{" (substring u 0 n) "}" + (substring u n nil))))))))) +; case 4: arg op arg + (t + (setq i(or (|checkSkipToken| u 0 m) (return u))) + (cond + ((nequal namestring (setq firstWord (substring u 0 i))) + (|checkDocError| + (list "Improper first word in comments: " firstWord)) + u) + (t + (setq prefixOp (intern (substring u 0 i))) + (cond + ((null (getl prefixOp '|Nud|)) u) + (t + (setq j (or (|checkSkipBlanks| u i m) (return u))) + (cond +; case 5: op arg + ((equal (elt u j) (|char| '|(|)) + (setq j + (|getMatchingRightPren| u (1+ j) (|char| '|(|) (|char| '|)|))) + (cond + ((> j m) u) + (t + (strconc "\\spad{" (substring u 0 (1+ j)) "}" + (substring u (1+ j) nil))))) + (t + (setq k (or (|checkSkipToken| u j m) (return u))) + (cond + ((nequal namestring (setq firstWord (substring u 0 i))) + (|checkDocError| + (list "Improper first word in comments: " firstWord)) + u) + (t + (strconc "\\spad{" (substring u 0 k) "}" + (substring u k nil)))))))))))))))))) + +\end{chunk} + +\defun{getMatchingRightPren}{getMatchingRightPren} +\calls{getMatchingRightPren}{maxindex} +\begin{chunk}{defun getMatchingRightPren} +(defun |getMatchingRightPren| (u j open close) + (let (m c found count) + (setq count 0) + (setq m (maxindex u)) + (loop for i from j to m + do + (setq c (elt u i)) + (cond + ((equal c close) + (if (eql count 0) + (return (setq found i)) + (setq count (1- count)))) + ((equal c open) + (setq count (1+ count))))) + found)) + +\end{chunk} + +\defun{checkGetMargin}{checkGetMargin} +\calls{checkGetMargin}{firstNonBlankPosition} +\begin{chunk}{defun checkGetMargin} +(defun |checkGetMargin| (lines) + (let (x k margin) + (loop while lines + do + (setq x (car lines)) + (setq k (|firstNonBlankPosition| x)) + (unless (= k -1) (setq margin (if margin (min margin k) k))) + (pop lines)) + (or margin 0))) + +\end{chunk} + +\defun{firstNonBlankPosition}{firstNonBlankPosition} +\calls{firstNonBlankPosition}{nequal} +\calls{firstNonBlankPosition}{maxindex} +\begin{chunk}{defun firstNonBlankPosition} +(defun |firstNonBlankPosition| (&rest therest) + (let ((x (car therest)) (options (cdr therest)) start k) + (declare (special |$charBlank|)) + (setq start (or (ifcar options) 0)) + (setq k -1) + (loop for i from start to (maxindex x) + do (when (nequal (elt x i) |$charBlank|) (return (setq k i)))) + k)) + +\end{chunk} + +\defun{checkIeEg}{checkIeEg} +\calls{checkIeEg}{checkIeEgfun} +\calls{checkIeEg}{nreverse} +\begin{chunk}{defun checkIeEg} +(defun |checkIeEg| (u) + (let (x verbatim z acc) + (setq acc nil) + (setq verbatim nil) + (loop while u + do + (setq x (car u)) + (setq acc + (cond + ((equal x "\\end{verbatim}") + (setq verbatim nil) + (cons x acc)) + (verbatim (cons x acc)) + ((equal x "\\begin{verbatim}") + (setq verbatim t) + (cons x acc)) + ((setq z (|checkIeEgfun| x)) + (append (nreverse z) acc)) + (t (cons x acc)))) + (setq u (cdr u))) + (nreverse acc))) + +\end{chunk} + +\defun{checkIeEgfun}{checkIeEgfun} +\calls{checkIeEgfun}{maxindex} +\calls{checkIeEgfun}{checkIeEgFun} +\refsdollar{checkIeEgfun}{charPeriod} +\begin{chunk}{defun checkIeEgfun} +(defun |checkIeEgfun| (x) + (let (m key firstPart result) + (declare (special |$charPeriod|)) + (cond + ((characterp x) nil) + ((equal x "") nil) + (t + (setq m (maxindex x)) + (loop for k from 0 to (- m 3) + do + (cond + ((and + (equal (elt x (1+ k)) |$charPeriod|) + (equal (elt x (+ k 3)) |$charPeriod|) + (or + (and + (equal (elt x k) #\i) + (equal (elt x (+ k 2)) #\e) + (setq key "that is")) + (and + (equal (elt x k) #\e) + (equal (elt x (+ k 2)) #\g) + (setq key "for example")))) + (progn + (setq firstPart (when (> k 0) (cons (substring x 0 k) nil))) + (setq result + (append firstPart + (cons "\\spadignore{" + (cons (substring x k 4) + (cons "}" + (|checkIeEgfun| (substring x (+ k 4) nil))))))))))) + result)))) + +\end{chunk} + + + \chapter{Utility Functions} \defun{translabel}{translabel} @@ -23087,6 +23864,15 @@ The current input line. \getchunk{defun char-eq} \getchunk{defun char-ne} \getchunk{defun checkAndDeclare} +\getchunk{defun checkComments} +\getchunk{defun checkDocError} +\getchunk{defun checkDocError1} +\getchunk{defun checkDocMessage} +\getchunk{defun checkExtract} +\getchunk{defun checkGetMargin} +\getchunk{defun checkIeEg} +\getchunk{defun checkIeEgfun} +\getchunk{defun checkTransformFirsts} \getchunk{defun checkWarning} \getchunk{defun coerce} \getchunk{defun coerceable} @@ -23096,6 +23882,8 @@ The current input line. \getchunk{defun coerceExtraHard} \getchunk{defun coerceHard} \getchunk{defun coerceSubset} +\getchunk{defun collectAndDeleteAssoc} +\getchunk{defun collectComBlock} \getchunk{defun comma2Tuple} \getchunk{defun comp} \getchunk{defun comp2} @@ -23247,8 +24035,10 @@ The current input line. \getchunk{defun extractCodeAndConstructTriple} \getchunk{defun flattenSignatureList} +\getchunk{defun finalizeDocumentation} \getchunk{defun finalizeLisplib} \getchunk{defun fincomblock} +\getchunk{defun firstNonBlankPosition} \getchunk{defun fixUpPredicate} \getchunk{defun floatexpid} \getchunk{defun formal2Pattern} @@ -23265,6 +24055,7 @@ The current input line. \getchunk{defun getFormModemaps} \getchunk{defun getFunctorOpsAndAtts} \getchunk{defun getInverseEnvironment} +\getchunk{defun getMatchingRightPren} \getchunk{defun getModemap} \getchunk{defun getModemapList} \getchunk{defun getModemapListFromDomain} @@ -23610,6 +24401,10 @@ The current input line. \getchunk{defun read-a-line} \getchunk{defun recompile-lib-file-if-necessary} +\getchunk{defun recordAttributeDocumentation} +\getchunk{defun recordDocumentation} +\getchunk{defun recordHeaderDocumentation} +\getchunk{defun recordSignatureDocumentation} \getchunk{defun replaceExitEtc} \getchunk{defun removeSuperfluousMapping} \getchunk{defun replaceVars} @@ -23650,6 +24445,9 @@ The current input line. \getchunk{defun token-install} \getchunk{defun token-lookahead-type} \getchunk{defun token-print} +\getchunk{defun transDoc} +\getchunk{defun transDocList} +\getchunk{defun transformAndRecheckComments} \getchunk{defun transformOperationAlist} \getchunk{defun transImplementation} \getchunk{defun transIs} diff --git a/changelog b/changelog index a7dd1e7..6057c3a 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,6 @@ +20111116 tpd src/axiom-website/patches.html 20111116.01.tpd.patch +20111116 tpd src/interp/c-doc.lisp treeshake compiler +20111116 tpd books/bookvol9 treeshake compiler 20111113 tpd src/axiom-website/patches.html 20111113.01.tpd.patch 20111113 tpd src/interp/Makefile remove apply.lisp 20111113 tpd src/interp/apply.lisp removed, merged with bookvol9 diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index e667b7f..fed12b5 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -3680,5 +3680,7 @@ books/bookvol5 treeshake interpreter
books/bookvol9 treeshake compiler
20111113.01.tpd.patch books/bookvol9 treeshake compiler, remove apply.lisp
+20111116.01.tpd.patch +books/bookvol9 treeshake compiler
diff --git a/src/interp/c-doc.lisp.pamphlet b/src/interp/c-doc.lisp.pamphlet index db8fc1a..d2fe917 100644 --- a/src/interp/c-doc.lisp.pamphlet +++ b/src/interp/c-doc.lisp.pamphlet @@ -13,11 +13,6 @@ (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] @@ -30,31 +25,31 @@ ; sig := SUBST('$,dc,sig) ; getDocForCategory(conName,op,sig) -(DEFUN |getDoc| (|conName| |op| |modemap|) - (PROG (|LETTMP#1| |dc| |target| |sl| |pred| D |argList| |sig|) - (declare (special |$FormalMapArgumentList|)) - (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|))))))) +;(DEFUN |getDoc| (|conName| |op| |modemap|) +; (PROG (|LETTMP#1| |dc| |target| |sl| |pred| D |argList| |sig|) +; (declare (special |$FormalMapArgumentList|)) +; (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)) => @@ -62,84 +57,84 @@ ; pred is ['ofCategory,'_*1,form] => form ; nil -(DEFUN |getOfCategoryArgument| (|pred|) - (PROG (|fn| |ISTMP#1| |ISTMP#2| |form|) - (RETURN - (SEQ (COND - ((AND (CONSP |pred|) - (PROGN (SPADLET |fn| (QCAR |pred|)) 'T) - (member |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 (CONSP |pred|) (EQ (QCAR |pred|) '|ofCategory|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |pred|)) - (AND (CONSP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) '*1) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |form| (QCAR |ISTMP#2|)) - 'T)))))) - |form|) - ('T NIL)))))) +;(DEFUN |getOfCategoryArgument| (|pred|) +; (PROG (|fn| |ISTMP#1| |ISTMP#2| |form|) +; (RETURN +; (SEQ (COND +; ((AND (CONSP |pred|) +; (PROGN (SPADLET |fn| (QCAR |pred|)) 'T) +; (member |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 (CONSP |pred|) (EQ (QCAR |pred|) '|ofCategory|) +; (PROGN +; (SPADLET |ISTMP#1| (QCDR |pred|)) +; (AND (CONSP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) '*1) +; (PROGN +; (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) +; (AND (CONSP |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|))))))))))))) +;(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|))))))))))))) +;(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)) @@ -148,724 +143,56 @@ ; 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| $ |$FormalMapVariableList|)) - (RETURN - (SEQ (PROGN - (SPADLET |u| - (LASSOC |op| (GETDATABASE |abb| 'DOCUMENTATION))) - (SPADLET |$argList| |$FormalMapVariableList|) - (SPADLET $ '$) - (COND - ((AND (CONSP |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|))))))) +;(DEFUN |getOpDoc| (&REST G166194 &AUX |sigPart| |op| |abb|) +; (DSETQ (|abb| |op| . |sigPart|) G166194) +; (PROG (|$argList| $ |u| |sig| |s| |d|) +; (DECLARE (SPECIAL |$argList| $ |$FormalMapVariableList|)) +; (RETURN +; (SEQ (PROGN +; (SPADLET |u| +; (LASSOC |op| (GETDATABASE |abb| 'DOCUMENTATION))) +; (SPADLET |$argList| |$FormalMapVariableList|) +; (SPADLET $ '$) +; (COND +; ((AND (CONSP |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|) - (declare (special |$docList| |$maxSignatureLineNumber|)) - (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|) - (declare (special |$headerDocumentation| |$maxSignatureLineNumber| - $COMBLOCKLIST)) - (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|) - (declare (special $COMBLOCKLIST)) - (RETURN - (COND - ((AND (CONSP $COMBLOCKLIST) - (PROGN - (SPADLET |ISTMP#1| (QCAR $COMBLOCKLIST)) - (AND (CONSP |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|) - (declare (special $COMBLOCKLIST)) - (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 (CONSP |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|) - (declare (special |$lisplibForm| |$FormalMapVariableList|)) - (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|) - (declare (special |$e| |$lisplibForm| |$docList| |$op| $COMBLOCKLIST)) - (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 (CONSP |y|) - (PROGN - (SPADLET |x| (QCAR |y|)) - (SPADLET |ISTMP#1| (QCDR |y|)) - (AND (CONSP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN - (SPADLET |b| - (QCAR |ISTMP#1|)) - 'T))) - (CONSP |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|) - ".") - (CONS |name| NIL))) - (SPADLET |bigcnt| (PLUS |bigcnt| 1)) - (SPADLET |litcnt| 1) - (COND - (|noHeading| - (|sayKeyedMsg| 'S2CD0003 - (CONS (STRCONC "(" - (STRINGIMAGE |litcnt|) - ")") - (CONS |name| NIL))) - (SPADLET |litcnt| (PLUS |litcnt| 1)))) - (COND - (|signatures| - (|sayKeyedMsg| 'S2CD0004 - (CONS (STRCONC "(" - (STRINGIMAGE |litcnt|) - ")") - 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 "(" - (STRINGIMAGE |litcnt|) - ")") - 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|) - ".") - (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 " " - (APPEND (|bright| |n|) - (CONS " " - (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))))))))))))) +;(DEFUN |readForDoc| (|fn|) +; (PROG (|$bootStrapMode|) +; (DECLARE (SPECIAL |$bootStrapMode|)) +; (RETURN +; (PROGN +; (SPADLET |$bootStrapMode| 'T) +; (/RQ-LIB-1 (CONS |fn| (CONS 'SPAD NIL))))))) ;--======================================================================= ;-- 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 " Processing " - (CONS |$constructorName| - (CONS " 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 (CONSP |entry|) - (EQ (QCAR |entry|) '|constructor|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |entry|)) - (AND (CONSP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN - (SPADLET |x| (QCAR |ISTMP#1|)) - 'T)))) - (COND - (|conEntry| - (|checkDocError| - (CONS - "Spurious comments: " - (CONS |x| NIL)))) - ('T (SPADLET |conEntry| |entry|)))) - ('T (SPADLET |acc| (CONS |entry| |acc|))))))) - (COND - (|conEntry| (CONS |conEntry| |acc|)) - ('T - (|checkDocError1| - (CONS "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 (CONSP |$x|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |$x|)) - (AND (CONSP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN - (SPADLET |ISTMP#2| - (QCAR |ISTMP#1|)) - (AND (CONSP |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 - "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| - "Description:" - |u|) - (AND |u| - (|checkExtract| - "Description:" - (CONS - (STRCONC - "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 @@ -902,54 +229,6 @@ 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| |$exposeFlag| |$checkingXmptex?|)) - (RETURN - (PROGN - (SPADLET |$checkingXmptex?| NIL) - (SPADLET |$x| |name|) - (SPADLET |$name| '|GlossaryPage|) - (SPADLET |$origin| '|gloss|) - (SPADLET |$recheckingFlag| NIL) - (SPADLET |$exposeFlagHeading| - (CONS "--------" - (CONS |name| - (CONS "---------" 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 @@ -1790,113 +1069,6 @@ (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| |$argl| |$attribute?|)) - (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|) - "\\end{verbatim}")) - (SPADLET |verbatim| NIL) - (SPADLET |u2| (APPEND |u2| |w|))) - ('T - (SPADLET |u2| - (APPEND |u2| (CONS |x| NIL)))))) - ((AND |w| - (BOOT-EQUAL (CAR |w|) - "\\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 @@ -2147,61 +1319,6 @@ 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|) - (declare (special |$charBlank|)) - (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 " @@ -2904,117 +2021,6 @@ ('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| - "\\end{verbatim}") - (SPADLET |verbatim| NIL) - (CONS |x| |acc|)) - (|verbatim| (CONS |x| |acc|)) - ((BOOT-EQUAL |x| - "\\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|) - (declare (special |$charPeriod|)) - (RETURN - (SEQ (COND - ((CHARP |x|) NIL) - ((BOOT-EQUAL |x| "") 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| - "that is")) - (AND - (BOOT-EQUAL (ELT |x| |k|) - (|char| '|e|)) - (BOOT-EQUAL - (ELT |x| (PLUS |k| 2)) - (|char| '|g|)) - (SPADLET |key| - "for example")))) - (EXIT - (PROGN - (SPADLET |firstPart| - (COND - ((> |k| 0) - (CONS (SUBSTRING |x| 0 |k|) - NIL)) - ('T NIL))) - (SPADLET |result| - (APPEND |firstPart| - (CONS - "\\spadignore{" - (CONS (SUBSTRING |x| |k| 4) - (CONS "}" - (|checkIeEgfun| - (SUBSTRING |x| (PLUS |k| 4) - NIL)))))))))))))) - (EXIT |result|)))))))) - ;checkSplit2Words u == ; acc := nil ; while u repeat @@ -3737,267 +2743,6 @@ (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|) - (declare (special |$checkPrenAlist| |$charBack|)) - (RETURN - (PROGN - (SPADLET |namestring| (PNAME |opname|)) - (COND - ((BOOT-EQUAL |namestring| "Zero") - (SPADLET |namestring| "0")) - ((BOOT-EQUAL |namestring| "One") - (SPADLET |namestring| "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 "Improper first word in comments: " - (CONS |firstWord| NIL))) - |u|) - ((NULL |k|) - (COND - ((BOOT-EQUAL |open| (|char| '[)) - (|checkDocError| - (CONS "Missing close bracket on first line: " - (CONS |u| NIL)))) - ('T - (|checkDocError| - (CONS "Missing close parenthesis on first line: " - (CONS |u| NIL))))) - |u|) - ('T - (STRCONC "\\spad{" - (SUBSTRING |u| 0 (PLUS |k| 1)) - "}" - (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 "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 "\\spad{" - (SUBSTRING |u| 0 (PLUS |l| 1)) - "}" - (SUBSTRING |u| (PLUS |l| 1) NIL))) - ('T - (STRCONC "\\spad{" - (SUBSTRING |u| 0 |k|) "}" - (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 "Improper initial operator in comments: " - (CONS |infixOp| NIL))) - |u|) - ('T - (STRCONC "\\spad{" - (SUBSTRING |u| 0 |n|) "}" - (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 "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 "\\spad{" - (SUBSTRING |u| 0 (PLUS |j| 1)) - "}" - (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 "Improper first word in comments: " - (CONS |firstWord| NIL))) - |u|) - ('T - (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 - -(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 @@ -4194,33 +2939,6 @@ (|$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|) - (declare (special |$constructorName| |$x|)) - (RETURN - (PROGN - (SPADLET |sourcefile| - (GETDATABASE |$constructorName| 'SOURCEFILE)) - (SPADLET |person| - (OR (|whoOwns| |$constructorName|) "---")) - (SPADLET |middle| - (COND - ((BOUNDP '|$x|) - (CONS "(" - (CONS |$x| (CONS "): " NIL)))) - ('T (CONS ": " NIL)))) - (|concat| |person| ">" |sourcefile| - "-->" |$constructorName| |middle| |u|))))) - ;checkDecorateForHt u == ; count := 0 ; spadflag := false --means OK to wrap single letter words with \s{}