diff --git a/books/bookvol9.pamphlet b/books/bookvol9.pamphlet index b349633..a125289 100644 --- a/books/bookvol9.pamphlet +++ b/books/bookvol9.pamphlet @@ -7644,53 +7644,6 @@ 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} @@ -19342,80 +19295,94 @@ deleting entries from u assumes that the first element is useless (|macroExpand| x env))))) (hn (u) ; ((op,sig,doc), ...) --> ((op ((sig doc) ...)) ...) - (let (opList) - (setq opList (remdup (assocleft u))) + (let (opList op1 sig doc) + (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|)))))) + do (setq op1 (first item)) + (setq sig (second item)) + (setq doc (third item)) + when (equal op op1) + collect + (list sig doc))))))) + (let (unusedCommentLineNumbers docList u noHeading attributes + signatures name bigcnt op s litcnt a n r sig) + (declare (special |$e| |$lisplibForm| |$docList| |$op| $comblocklist)) + (setq unusedCommentLineNumbers + (loop for x in $comblocklist + when (cdr x) + collect x)) + (setq docList (msubst '$ '% (|transDocList| |$op| |$docList|))) + (cond + ((setq u + (loop for item in docList + when (null (cdr item)) + collect (car item))) + (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 (list (strconc (stringimage bigcnt) ".") 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 op (first item)) + (setq sig (second item)) + (setq s (|formatOpSignature| op sig)) + (|sayMSG| + (if (atom s) + (list '|%x9| s) + (cons '|%x9| s))))) + (when attributes + (|sayKeyedMsg| 'S2CD0005 + (list (strconc "(" (stringimage litcnt) ")"))) + (setq litcnt (1+ litcnt)) + (DO ((G166491 attributes + (CDR G166491)) + (x NIL)) + ((OR (ATOM G166491) + (PROGN + (SETQ x (CAR G166491)) + NIL)) + NIL) + (SEQ (EXIT + (PROGN + (setq a (|form2String| x)) + (|sayMSG| + (COND + ((ATOM a) + (CONS '|%x9| (CONS a NIL))) + ('T (CONS '|%x9| a)))))))))) + (when unusedCommentLineNumbers + (|sayKeyedMsg| 'S2CD0006 + (list (strconc (stringimage bigcnt) ".") name)) + (loop for item in unusedCommentLineNumbers + do + (setq r (second item)) + (|sayMSG| (cons " " (append (|bright| n) (list " " r))))))))) + (hn + (loop for item in docList + collect (append (fn (car item) |$e|) (cdr item))))))) \end{chunk} @@ -19781,7 +19748,6 @@ deleting entries from u assumes that the first element is useless \end{chunk} - \defun{checkDecorateForHt}{checkDecorateForHt} \calls{checkDecorateForHt}{checkDocError} \calls{checkDecorateForHt}{member} @@ -19890,26 +19856,28 @@ deleting entries from u assumes that the first element is useless \end{chunk} \defun{whoOwns}{whoOwns} +This function always returns nil in the current system. +Since it has no side effects we define it to return nil. \calls{whoOwns}{getdatabase} \calls{whoOwns}{strconc} \calls{whoOwns}{awk} \calls{whoOwns}{shut} \refsdollar{whoOwns}{exposeFlag} \begin{chunk}{defun whoOwns} -(defun |whoOwns| (con) - (let (filename quoteChar instream value) - (declare (special |$exposeFlag|)) - (cond - ((null |$exposeFlag|) nil) - (t - (setq filename (getdatabase con 'sourcefile)) - (setq quoteChar #\") - (obey (strconc "awk '$2 == " quoteChar filename quoteChar - " {print $1}' whofiles > /tmp/temp")) - (setq instream (make-instream "/tmp/temp")) - (setq value (unless (eofp instream) (readline instream))) - (shut instream) - value)))) +(defun |whoOwns| (con) nil) +; (let (filename quoteChar instream value) +; (declare (special |$exposeFlag|)) +; (cond +; ((null |$exposeFlag|) nil) +; (t +; (setq filename (getdatabase con 'sourcefile)) +; (setq quoteChar #\") +; (obey (strconc "awk '$2 == " quoteChar filename quoteChar +; " {print $1}' whofiles > /tmp/temp")) +; (setq instream (make-instream "/tmp/temp")) +; (setq value (unless (eofp instream) (readline instream))) +; (shut instream) +; value)))) \end{chunk} @@ -20545,8 +20513,6 @@ This returns a line beginning with right brace \end{chunk} - - \chapter{Utility Functions} \defun{translabel}{translabel} @@ -24496,7 +24462,6 @@ The current input line. \getchunk{defun checkDocError} \getchunk{defun checkDocError1} \getchunk{defun checkDocMessage} -\getchunk{defun checkExtract} \getchunk{defun checkGetMargin} \getchunk{defun checkGetParse} \getchunk{defun checkHTargs} @@ -24504,6 +24469,7 @@ The current input line. \getchunk{defun checkIeEgfun} \getchunk{defun checkLookForLeftBrace} \getchunk{defun checkLookForRightBrace} +\getchunk{defun checkTexht} \getchunk{defun checkRecordHash} \getchunk{defun checkRewrite} \getchunk{defun checkSayBracket} @@ -24512,7 +24478,6 @@ The current input line. \getchunk{defun checkSkipOpToken} \getchunk{defun checkSkipToken} \getchunk{defun checkSplit2Words} -\getchunk{defun checkTexht} \getchunk{defun checkTransformFirsts} \getchunk{defun checkWarning} \getchunk{defun coerce} diff --git a/changelog b/changelog index 5ff288d..38a9914 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,6 @@ +20111124 tpd src/axiom-website/patches.html 20111124.04.tpd.patch +20111124 tpd src/interp/c-doc.lisp treeshake compiler +20111124 tpd books/bookvol9 treeshake compiler 20111124 tpd src/axiom-website/patches.html 20111124.03.tpd.patch 20111124 tpd books/bookvolbib add additional references 20111124 tpd src/axiom-website/patches.html 20111124.02.tpd.patch diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index d095aa1..a3cc5ef 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -3694,5 +3694,7 @@ src/axiom-website/litprog.html add quote
books/bookvol9 treeshake compiler
20111124.03.tpd.patch books/bookvolbib add additional references
+20111124.04.tpd.patch +books/bookvol9 treeshake compiler
diff --git a/src/interp/c-doc.lisp.pamphlet b/src/interp/c-doc.lisp.pamphlet index 44dab1d..7b18450 100644 --- a/src/interp/c-doc.lisp.pamphlet +++ b/src/interp/c-doc.lisp.pamphlet @@ -13,6 +13,11 @@ (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] @@ -25,31 +30,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)) => @@ -57,84 +62,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)) @@ -143,56 +148,514 @@ ; 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|)) +(DEFUN |readForDoc| (|fn|) + (PROG (|$bootStrapMode|) + (DECLARE (SPECIAL |$bootStrapMode|)) + (RETURN + (PROGN + (SPADLET |$bootStrapMode| 'T) + (/RQ-LIB-1 (CONS |fn| (CONS 'SPAD NIL))))))) + + +;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 -; (PROGN -; (SPADLET |$bootStrapMode| 'T) -; (/RQ-LIB-1 (CONS |fn| (CONS 'SPAD NIL))))))) +; (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))))))))))))) ;--======================================================================= ;-- Transformation of ++ comments ;--======================================================================= + +;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 @@ -229,6 +692,533 @@ 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 +; 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| |$argl| |$checkingXmptex?|)) +; (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|) +; "\\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| (|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|) +; (declare (special |$charRbrace| |$charLbrace|)) +; (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| +; "\\texht") +; (SPADLET |u| (IFCDR |u|))) +; (COND +; ((NULL (BOOT-EQUAL (IFCAR |u|) +; |$charLbrace|)) +; (|checkDocError| +; "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| +; "\\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|) +; (declare (special |$origin| |$name| |$sysHash| |$setOptions| |$glossHash| +; |$currentSysList| |$lispHash| |$HTlisplinks| |$htHash| +; |$HTlinks| |$charBack|)) +; (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| +; "\\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 +; "Unparseable \\spadtype: " +; (CONS |s| NIL)))) +; ((NULL +; (|member| (|opOf| |parse|) +; |$currentSysList|)) +; (|checkDocError| +; (CONS +; "Bad system command: " +; (CONS |s| NIL)))) +; ((OR (ATOM |parse|) +; (NULL +; (AND (CONSP |parse|) +; (EQ (QCAR |parse|) '|set|) +; (PROGN +; (SPADLET |ISTMP#1| +; (QCDR |parse|)) +; (AND (CONSP |ISTMP#1|) +; (EQ (QCDR |ISTMP#1|) NIL) +; (PROGN +; (SPADLET |arg| +; (QCAR |ISTMP#1|)) +; 'T)))))) +; '|ok|) +; ((NULL +; (|spadSysChoose| |$setOptions| +; |arg|)) +; (PROGN +; (|checkDocError| +; (CONS +; "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| +; "\\spadtype") +; (SPADLET |u| +; (|checkLookForLeftBrace| +; (IFCDR |u|))) +; (SPADLET |u| (IFCDR |u|))) +; (SPADLET |s| +; (|checkGetStringBeforeRightBrace| +; |u|)) +; (SPADLET |parse| +; (|checkGetParse| |s|)) +; (COND +; ((NULL |parse|) +; (|checkDocError| +; (CONS +; "Unparseable \\spadtype: " +; (CONS |s| NIL)))) +; ('T +; (SPADLET |n| +; (|checkNumOfArgs| |parse|)) +; (COND +; ((NULL |n|) +; (|checkDocError| +; (CONS +; "Unknown \\spadtype: " +; (CONS |s| NIL)))) +; ((AND (ATOM |parse|) (> |n| 0)) +; '|skip|) +; ((NULL +; (SPADLET |key| +; (|checkIsValidType| |parse|))) +; (|checkDocError| +; (CONS +; "Unknown \\spadtype: " +; (CONS |s| NIL)))) +; ((ATOM |key|) '|ok|) +; ('T +; (|checkDocError| +; (CONS +; "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 +; "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 => @@ -590,6 +1580,113 @@ (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 @@ -756,6 +1853,31 @@ (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 @@ -815,6 +1937,61 @@ 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 " @@ -1517,6 +2694,160 @@ ('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 +; 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| +; "\\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| +; (|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] @@ -1765,6 +3096,414 @@ (|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|) +; (declare (special |$checkPrenAlist|)) +; (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 (CONSP |stack|) +; (PROGN +; (SPADLET |top| +; (QCAR |stack|)) +; (SPADLET |restStack| +; (QCDR |stack|)) +; 'T)) +; (COND +; ((NEQUAL |open| |top|) +; (|checkDocError| +; (CONS +; "Mismatch: left " +; (CONS +; (|checkSayBracket| +; |top|) +; (CONS +; " matches right " +; (CONS +; (|checkSayBracket| +; |open|) +; NIL))))))) +; (SPADLET |stack| |restStack|)) +; ('T +; (|checkDocError| +; (CONS +; "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 +; "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| '|)|))) +; "pren") +; ((OR (BOOT-EQUAL |x| (|char| '{)) (BOOT-EQUAL |x| (|char| '}))) +; "brace") +; ('T "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|) +; (declare (special |$charRbrace| |$charLbrace| |$beginEndList| |$charBack| +; |$htMacroTable|)) +; (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| +; "\\spadignore")) +; (BOOT-EQUAL (IFCAR (IFCDR |u|)) +; |$charLbrace|) +; (NULL +; (OR +; (|substring?| +; "\\radiobox" |x| +; 0) +; (|substring?| +; "\\inputbox" |x| +; 0)))) +; (|checkDocError| +; (CONS '|Unexpected HT command: | +; (CONS |x| NIL)))) +; ((BOOT-EQUAL |x| +; "\\beginitems") +; (SPADLET |beginEndStack| +; (CONS '|items| |beginEndStack|))) +; ((BOOT-EQUAL |x| +; "\\begin") +; (COND +; ((AND (CONSP |u|) +; (PROGN +; (SPADLET |ISTMP#1| +; (QCDR |u|)) +; (AND (CONSP |ISTMP#1|) +; (EQUAL (QCAR |ISTMP#1|) +; |$charLbrace|) +; (PROGN +; (SPADLET |ISTMP#2| +; (QCDR |ISTMP#1|)) +; (AND (CONSP |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 +; "Unknown begin type: \\begin{" +; (CONS |y| +; (CONS "}" +; NIL)))))) +; (SPADLET |beginEndStack| +; (CONS |y| |beginEndStack|)) +; (SPADLET |u| |r|)) +; ('T +; (|checkDocError| +; (CONS +; "Improper \\begin command" +; NIL))))) +; ((BOOT-EQUAL |x| +; "\\item") +; (COND +; ((|member| +; (IFCAR |beginEndStack|) +; '("items" "menu")) +; NIL) +; ((NULL |beginEndStack|) +; (|checkDocError| +; (CONS +; "\\item appears outside a \\begin-\\end" +; NIL))) +; ('T +; (|checkDocError| +; (CONS +; "\\item appears within a \\begin{" +; (CONS (IFCAR |beginEndStack|) +; (CONS "}.." +; NIL))))))) +; ((BOOT-EQUAL |x| +; "\\end") +; (COND +; ((AND (CONSP |u|) +; (PROGN +; (SPADLET |ISTMP#1| +; (QCDR |u|)) +; (AND (CONSP |ISTMP#1|) +; (EQUAL (QCAR |ISTMP#1|) +; |$charLbrace|) +; (PROGN +; (SPADLET |ISTMP#2| +; (QCDR |ISTMP#1|)) +; (AND (CONSP |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 +; "Trying to match \\begin{" +; (CONS +; (IFCAR |beginEndStack|) +; (CONS +; "} with \\end{" +; (CONS |y| (CONS '} NIL))))))))) +; ('T +; (|checkDocError| +; (CONS +; "Improper \\end command" +; NIL)))))))) +; (SPADLET |u| (CDR |u|)))))) +; (COND +; (|beginEndStack| +; (|checkDocError| +; (CONS "Missing \\end{" +; (CONS (CAR |beginEndStack|) +; (CONS "}" 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|) +; (declare (special |$htMacroTable|)) +; (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 "Missing argument for " +; (CONS |keyword| NIL)))))) +; (COND +; ((NULL (SPADLET |u| (|checkLookForRightBrace| (IFCDR |u|)))) +; (RETURN +; (|checkDocError| +; (CONS "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|) +; (declare (special |$charBlank| |$charLbrace|)) +; (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|) +; (declare (special |$charLbrace| |$charRbrace|)) +; (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 @@ -1788,6 +3527,332 @@ (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 +; i + +;(DEFUN |checkSkipBlanks| (|u| |i| |m|) +; (declare (special |$charBlank|)) +; (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|) +; (declare (special |$charDelimiters|)) +; (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|) +; (declare (special |$charIdentifierEndings|)) +; (OR (ALPHA-CHAR-P |c|) (DIGITP |c|) +; (member |c| |$charIdentifierEndings|))) + ;--======================================================================= ;-- Code for creating a personalized report for ++ comments ;--======================================================================= @@ -1833,9 +3898,209 @@ (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|) +; (declare (special |$exposeFlag|)) +; (RETURN +; (COND +; ((NULL |$exposeFlag|) NIL) +; ('T (SPADLET |filename| (GETDATABASE |con| 'SOURCEFILE)) +; (SPADLET |quoteChar| (|char| '|"|)) +; (OBEY (STRCONC "awk '$2 == " |quoteChar| +; |filename| |quoteChar| +; " {print $1}' whofiles > /tmp/temp")) +; (SPADLET |instream| (MAKE-INSTREAM "/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|) +; (declare (special |$compileDocumentation|)) +; (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|) +; (declare (special |$outStream| |$exposeFlag| |$exposeFlagHeading| +; |$constructorName| |$recheckingFlag| |$checkErrorFlag|)) +; (RETURN +; (PROGN +; (SPADLET |$checkErrorFlag| 'T) +; (SPADLET |msg| +; (COND +; (|$recheckingFlag| +; (COND +; (|$constructorName| (|checkDocMessage| |u|)) +; ('T (|concat| "> " |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|) +; (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{} +; 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|) +; (declare (special |$checkingXmptex?| |$charRbrace| |$charLbrace|)) +; (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| +; "\\em") +; (COND +; ((> |count| 0) +; (SPADLET |spadflag| +; (SPADDIFFERENCE |count| 1))) +; ('T +; (|checkDocError| +; (CONS +; "\\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 +; " appearing outside \\spad{}" +; NIL))))) +; ('T NIL))) +; ('T NIL)) +; (COND +; ((OR +; (BOOT-EQUAL |x| +; "$") +; (BOOT-EQUAL |x| +; "%")) +; (|checkDocError| +; (CONS "Unescaped " +; (CONS |x| NIL))))))) +; (SPADLET |u| (CDR |u|)))))) +; |u|))))) \end{chunk} \eject