diff --git a/books/bookvol5.pamphlet b/books/bookvol5.pamphlet index cef4206..306f3eb 100644 --- a/books/bookvol5.pamphlet +++ b/books/bookvol5.pamphlet @@ -50421,6 +50421,360 @@ Given \verb|("one" "two" "three")| generate \verb|"(one,two,three)"| \end{chunk} +\chapter{Browser Support Code} +\calls{conPage}{form2HtString} +\calls{conPage}{downcase} +\calls{conPage}{lassq} +\calls{conPage}{downlink} +\calls{conPage}{conPageFastPath} +\calls{conPage}{kPage} +\calls{conPage}{ySearch} +\usesdollar{conPage}{conArgstrings} +\defun{conPage}{conPage} +\begin{chunk}{defun conPage} +(defun |conPage| (&rest arglist) + (let (|$conArgstrings| form da pageName line a b) + (declare (special |$conArgstrings|)) + (setq a (car arglist)) + (setq b (cdr arglist)) + (setq form (cond ((atom a) (cons a b)) (t a))) + (setq |$conArgstrings| (loop for x in (cdr a) collect (|form2HtString| x))) + (cond ((null (atom a)) (setq a (car a)))) + (setq da (downcase a)) + (cond + ((setq pageName + (lassq da + '((|type| . |CategoryType|) + (|union| . |DomainUnion|) + (|record| . |DomainRecord|) + (|mapping| . |DomainMapping|) + (|enumeration| . |DomainEnumeration|)))) + (|downlink| pageName)) + ((setq line (|conPageFastPath| da)) (|kPage| line form)) + ((setq line (|conPageFastPath| (upcase a))) (|kPage| line form)) + (t (|ySearch| a))))) + +\end{chunk} + +\defun{conPageFastPath}{gets line quickly for constructor name or abbreviation} +\calls{conPageFastPath}{length} +\calls{conPageFastPath}{stringimage} +\calls{conPageFastPath}{charPosition} +\calls{conPageFastPath}{lassq} +\calls{conPageFastPath}{dbRead} +\calls{conPageFastPath}{conPageConEntry} +\usesdollar{conPageFastPath}{lowerCaseConTb} +\begin{chunk}{defun conPageFastPath} +(defun |conPageFastPath| (x) + (let (s name entry lineNumber) + (declare (special |$lowerCaseConTb|)) + (setq s (stringimage x)) + (unless (> (|#| s) (|charPosition| #\* s 0)) ; quit if name has * in it + (setq name (cond ((stringp x) (intern x)) (t x))) + (setq entry (hget |$lowerCaseConTb| name)) + (when entry + ;'dbLineNumbers property is set by function dbAugmentConstructorDataTable + (if (setq lineNumber (lassq '|dbLineNumber| (cddr entry))) + (|dbRead| lineNumber) + (|conPageConEntry| (car entry))))))) + +\end{chunk} + +\defun{conPageConEntry}{conPageConEntry} +\calls{conPageConEntry}{buildLIbdbConEntry} +\usesdollar{conPageConEntry}{conname} +\usesdollar{conPageConEntry}{conform} +\usesdollar{conPageConEntry}{exposed?} +\usesdollar{conPageConEntry}{doc} +\usesdollar{conPageConEntry}{kind} +\begin{chunk}{defun conPageConEntry} +(defun |conPageConEntry| (entry) + (let (|$conname| |$conform| |$exposed?| |$doc| |$kind|) + (declare (special |$conname| |$conform| |$exposed?| |$doc| |$kind|)) + (setq |$conname| nil) + (setq |$conform| nil) + (setq |$exposed?| nil) + (setq |$doc| nil) + (setq |$kind| nil) + (|buildLibdbConEntry| entry))))) + +\end{chunk} + +\defun{kdPageInfo}{kdPageInfo} +\calls{kdPageInfo}{htSay} +\calls{kdPageInfo}{nequal} +\calls{kdPageInfo}{bcHt} +\calls{kdPageInfo}{stringimage} +\calls{kdPageInfo}{htSaturnBreak} +\calls{kdPageInfo}{htSayStandard} +\calls{kdPageInfo}{kPageArgs} +\calls{kdPageInfo}{length} +\calls{kdPageInfo}{extractFileNameFromPath} +\calls{kdPageInfo}{subseq} +\calls{kdPageInfo}{getdatabase} +\calls{kdPageInfo}{htSay} +\calls{kdPageInfo}{htMakePage} +\begin{chunk}{defun kdPageInfo} +(defun |kdPageInfo| (name abbrev nargs conform signature file?) + (let (sourceFileName filename) + (|htSay| '|{\\sf | name "}") + (when (nequal abbrev name) (|bcHt| (list '| has abbreviation | abbrev))) + (when file? (|bcHt| (list " is a source file."))) + (cond + ((eql nargs 0) + (when (nequal abbrev name) (|bcHt| "."))) + (t + (when (nequal abbrev name) (|bcHt| " and")) + (|bcHt| + (if (eql nargs 1) + " takes one argument:" + (list '| takes | (stringimage nargs) '| arguments:|))))) + (|htSaturnBreak|) + (|htSayStandard| "\\indentrel{2}") + (when (> nargs 0) (|kPageArgs| conform signature)) + (|htSayStandard| "\\indentrel{-2}") + (when (char= (elt name (1- (|#| name))) #\&) + (setq name (subseq name 0 (1- (|#| name))))) + (setq sourceFileName (getdatabase (intern name) 'sourcefile)) + (setq filename (|extractFileNameFromPath| sourceFileName)) + (when (nequal filename "") + (|htSayStandard| "\\newline{}") + (|htSay| "The source code for the constructor is found in ")) + (|htMakePage| + (list (list '|text| "\\unixcommand{" filename "}{\\$AXIOM/lib/SPADEDIT " + sourceFileName " " name "}"))) + (when (nequal nargs 0) (|htSay| ".")) + (|htSaturnBreak|))) + +\end{chunk} + +\defun{kArgPage}{kArgPage} +\calls{kArgPage}{htpProperty} +\calls{kArgPage}{getConstructorModemap} +\calls{kArgPage}{position} +\calls{kArgPage}{sublisFormal} +\calls{kArgPage}{mkDomTypeForm} +\calls{kArgPage}{domainDescendantsOf} +\calls{kArgPage}{htpSetProperty} +\calls{kArgPage}{dbShowCons} +\begin{chunk}{defun kArgPage} +(defun |kArgPage| (htPage arg) + (let (conform op args domname source n typeForm domTypeForm descendants rank) + (setq conform (|htpProperty| htPage '|conform|)) + (setq op (car conform)) + (setq args (cdr conform)) + (setq domname (|htpProperty| htPage '|domname|)) + (setq source (cddar (|getConstructorModemap| op))) + (setq n (|position| arg args)) + (setq typeForm (|sublisFormal| args (elt source n))) + (setq domTypeForm (|mkDomTypeForm| typeForm conform domname)) + (setq descendants (|domainDescendantsOf| typeForm domTypeForm)) + (|htpSetProperty| htPage '|cAlist| descendants) + (setq rank + (unless (> n 4) (elt '(|First| |Second| |Third| |Fourth| |Fifth|) n))) + (|htpSetProperty| htPage '|rank| rank) + (|htpSetProperty| htPage '|thing| "argument") + (|dbShowCons| htPage '|names|))) + +\end{chunk} + +\defun{reportCategory}{reportCategory} +\calls{reportCategory}{htSay} +\calls{reportCategory}{categoryParts} +\calls{reportCategory}{bcConform} +\calls{reportCategory}{bcPred} +\calls{reportCategory}{bcConPredTable} +\calls{reportCategory}{reportAO} +\begin{chunk}{defun reportCategory} +(defun |reportCategory| (conform typeForm arg) + (let (lt1 conlist attrlist oplist) + (|htSay| "Argument {\\em " arg "}") + (setq lt1 (|categoryParts| conform typeForm t)) + (setq conlist (car lt1)) + (setq attrlist (cadr lt1)) + (setq oplist (cddr lt1)) + (|htSay| " must ") + (cond + (conlist + (|htSay| "belong to ") + (cond + ((and (consp conlist) (eq (qcdr conlist) nil)) + (|htSay| "category ") + (|bcConform| (caar conlist)) + (|bcPred| (cdar conlist))) + (t + (|htSay| "categories:") + (|bcConPredTable| conlist (|opOf| conform)) + (|htSay| "\\newline "))))) + (cond + (attrlist + (when conlist (|htSay| " and ")) + (|reportAO| "attribute" attrlist) + (|htSay| "\\newline "))) + (cond + (oplist + (when (or conlist attrlist) (|htSay| " and ")) + (|reportAO| "operation" oplist))))) + +\end{chunk} + +\defun{reportAO}{reportAO} +\calls{reportAO}{htSay} +\calls{reportAO}{satDownLink} +\calls{reportAO}{escapeSpecialChars} +\calls{reportAO}{form2HtString} +\calls{reportAO}{bcConform} +\begin{chunk}{defun reportAO} +(defun |reportAO| (kind oplist) + (let (op sig pred attr ops sigs) + (|htSay| "have " kind ":") + (dolist (item oplist) + (setq op (car item)) + (setq sig (cadr item)) + (setq pred (cddr item)) + (|htSay| "\\newline ") + (when (eql (|#| oplist) 1) (|htSay| "\\centerline{")) + (cond + ((string= kind "attribute") + (setq attr (|form2String| (cons op sig))) + (|satDownLink| attr (list "(|attrPage| '|" attr "|)" ))) + (t + (setq ops (|escapeSpecialChars| (stringimage op))) + (setq sigs (|form2HtString| (cons '|Mapping| sig))) + (|satDownLink| ops (list "(|opPage| '|" ops "| |" sigs "|)")) + (|htSay| ": ") + (|bcConform| (cons '|Mapping| sig)))) + (when (eql (|#| oplist) 1) (|htSay| "}"))) + (|htSay| "\\newline "))) + +\end{chunk} + +\defun{mkDomTypeForm}{mkDomTypeForm} +\calls{mkDomTypeForm}{sublislis} +\calls{mkDomTypeForm}{mkDomTypeForm} +\calls{mkDomTypeForm}{hasIndent} +\begin{chunk}{defun mkDomTypeForm} +(defun |mkDomTypeForm| (typeForm conform domname) + (cond + (domname (sublislis (cdr domname) (cdr conform) typeForm)) + ((and (consp typeForm) (eq (qcar typeForm) '|Join|)) + (cons '|Join| + (loop for t1 in (qcdr typeForm) collect + (|mkDomTypeForm| t1 conform domname)))) + ((null (|hasIdent| typeForm)) typeForm))) + +\end{chunk} + +\defun{domainDescendantsOf}{domainDescendantsOf} +\calls{domainDescendantsOf}{systemError} +\calls{domainDescendantsOf}{simpHasPred} +\calls{domainDescendantsOf}{quickAnd} +\calls{domainDescendantsOf}{domainsOf} +\calls{domainDescendantsOf}{ifcdr} +\calls{domainDescendantsOf}{qcar} +\calls{domainDescendantsOf}{qcdr} +\calls{domainDescendantsOf}{assoc} +\calls{domainDescendantsOf}{listSort} +\calls{domainDescendantsOf}{function} +\calls{domainDescendantsOf}{delete} +\begin{chunk}{defun domainDescendantsOf} +(defun |domainDescendantsOf| (conform domform) + (labels ( + (catScreen (r alist) + (let (t1 item pred pred1 npred) + (dolist (x r) + (unless (and (consp x) (member (qcar x) '(attribute signature))) + (|systemError| x)) + (setq alist + (dolist (anitem alist (nreverse0 t1)) + (setq item (car anitem)) + (setq pred (cdr anitem)) + (when (and + (setq pred1 (|simpHasPred| (list '|has| item x))) + (setq npred (|quickAnd| pred1 pred))) + (setq t1 (cons (cons item npred) t1)))))) + alist)) + ; keep only those domains that appear in ALL parts of Join + (jfn (arg domlist) + (let (y r item pred u keepList alist) + (setq y (car arg)) + (setq r (cdr arg)) + (setq alist (|domainsOf| y (ifcar domlist))) + (dolist (x r) + (setq domlist (ifcdr domlist)) + (when (and (consp x) (eq (qcar x) 'category) (consp (qcdr x))) + (setq alist (catScreen (cddr x) alist))) + (setq keepList nil) + (dolist (dom (|domainsOf| x (ifcar domlist))) + (setq item (car dom)) + (setq pred (cdr dom)) + (when (setq u (|assoc| item alist)) + (setq keepList + (cons (cons item (|quickAnd| (cdr u) pred)) keepList)))) + (setq alist keepList)) + (dolist (pair alist) + (rplacd pair (|simpHasPred| (cdr pair)))) + (|listSort| (|function| glesseqp) alist)))) + (if (consp conform) + (cond + ((eq (qcar conform) '|Join|) + (jfn + (|delete| '(|Type| |Object|) (qcdr conform)) + (|delete| '(|Type| |Object|) (ifcdr domform)))) + ((eq (qcar conform) 'category) nil) + (t (|domainsOf| conform domform))) + (|domainsOf| conform domform)))) + +\end{chunk} + +There are 8 parts of an htPage: +\begin{enumerate} +\item kind +\item name +\item nargs +\item xflag +\item sig +\item args +\item abbrev +\item comments +\end{enumerate} + +\defun{kiPage}{kiPage} +\calls{kiPage}{htpProperty} +\calls{kiPage}{mkConform} +\calls{kiPage}{kDomainName} +\calls{kiPage}{errorPage} +\calls{kiPage}{capitalize} +\calls{kiPage}{htInitPage} +\calls{kiPage}{htCopyProplist} +\calls{kiPage}{dbShowConsDoc1} +\calls{kiPage}{htShowPage} +\usesdollar{kiPage}{conformsAreDomains} +\begin{chunk}{defun kiPage} +(defun |kiPage| (htPage junk) + (declare (ignore junk)) + (let (lt1 kind name nargs args conform domname heading page) + (declare (special |$conformsAreDomains|)) + (setq lt1 (|htpProperty| htPage '|parts|)) + (setq kind (first lt1)) + (setq name (second lt1)) + (setq nargs (third lt1)) + (setq args (sixth lt1)) + (setq conform (|mkConform| kind name args)) + (setq domname (|kDomainName| htPage kind name nargs)) + (cond + ((and (consp domname) (eq (qcar domname) '|error|)) + (|errorPage| htPage domname)) + (t + (setq heading + (list "Description of " (|capitalize| kind) " {\\sf " name args "}")) + (setq page (|htInitPage| heading (|htCopyProplist| htPage))) + (setq |$conformsAreDomains| domname) + (|dbShowConsDoc1| htPage conform nil) + (|htShowPage|))))) + +\end{chunk} + \chapter{The Interpreter} \begin{chunk}{Interpreter} (setq *print-array* nil) @@ -51005,6 +51359,9 @@ Given \verb|("one" "two" "three")| generate \verb|"(one,two,three)"| \getchunk{defun compressOpen} \getchunk{defun computeDomainVariableAlist} \getchunk{defun condErrorMsg} +\getchunk{defun conPage} +\getchunk{defun conPageConEntry} +\getchunk{defun conPageFastPath} \getchunk{defun constoken} \getchunk{defun constructSubst} \getchunk{defun containsVars} @@ -51065,6 +51422,7 @@ Given \verb|("one" "two" "three")| generate \verb|"(one,two,three)"| \getchunk{defun displayValue} \getchunk{defun displayWorkspaceNames} \getchunk{defun doDoitButton} +\getchunk{defun domainDescendantsOf} \getchunk{defun domainToGenvar} \getchunk{defun domArg} \getchunk{defun domArg2} @@ -51382,7 +51740,10 @@ Given \verb|("one" "two" "three")| generate \verb|"(one,two,three)"| \getchunk{defun justifyMyType} +\getchunk{defun kArgPage} +\getchunk{defun kdPageInfo} \getchunk{defun KeepPart?} +\getchunk{defun kiPage} \getchunk{defun lassocSub} \getchunk{defun lastTokPosn} @@ -51452,6 +51813,7 @@ Given \verb|("one" "two" "three")| generate \verb|"(one,two,three)"| \getchunk{defun messageprint-2} \getchunk{defun mkCurryFun} \getchunk{defun mkDomPvar} +\getchunk{defun mkDomTypeForm} \getchunk{defun mkEvalable} \getchunk{defun mkEvalableMapping} \getchunk{defun mkEvalableRecord} @@ -52024,6 +52386,8 @@ Given \verb|("one" "two" "three")| generate \verb|"(one,two,three)"| \getchunk{defun replacePercentByDollar,fn} \getchunk{defun replacePercentByDollar} \getchunk{defun replaceSharps} +\getchunk{defun reportAO} +\getchunk{defun reportCategory} \getchunk{defun reportOperations} \getchunk{defun reportOpsFromLisplib} \getchunk{defun reportOpsFromLisplib0} diff --git a/changelog b/changelog index f5314f6..7c5d723 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,6 @@ +20130526 tpd src/axiom-website/patches.html 20130526.03.tpd.patch +20130526 tpd src/interp/br-con.lisp incremental rewrite of br-con.lisp +20130526 tpd books/bookvol5 incremental rewrite of br-con.lisp 20130526 tpd src/axiom-website/patches.html 20130526.02.tpd.patch 20130526 tpd src/interp/regress.lisp improve diff output 20130526 tpd src/axiom-website/patches.html 20130526.01.tpd.patch diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index c289427..04bc71b 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -4183,6 +4183,8 @@ buglist remove error message for deleted files books/bookvol10.* fix failing test cases 20130526.02.tpd.patch src/interp/regress.lisp improve diff output +20130526.03.tpd.patch +books/bookvol5 incremental rewrite of br-con.lisp diff --git a/src/interp/br-con.lisp.pamphlet b/src/interp/br-con.lisp.pamphlet index 009697a..060a2df 100644 --- a/src/interp/br-con.lisp.pamphlet +++ b/src/interp/br-con.lisp.pamphlet @@ -12,712 +12,6 @@ \begin{chunk}{*} (IN-PACKAGE "BOOT" ) -;--====================> WAS b-con.boot <================================ -;--======================================================================= -;-- Pages Initiated from HyperDoc Pages -;--======================================================================= -;--NOTE: This duplicate version was discovered 3/20/94 in br-search.boot -;--called from buttons via bcCon, bcAbb, bcConform, dbShowCons1, dbSelectCon -;--conPage(a,:b) == -;-- --The next 4 lines allow e.g. MATRIX INT ==> Matrix Integer (see kPage) -;-- $conArgstrings: local := -;-- atom a => b -;-- a := conform2OutputForm a -;-- [mathform2HtString x for x in rest a] -;-- if not atom a then a := first a -;-- da := DOWNCASE a -;-- pageName := LASSQ(da,'((type . CategoryType)(union . DomainUnion)(record . DomainRecord)(mapping . DomainMapping))) => -;-- downlink pageName --special jump out for primitive domains -;-- line := conPageFastPath a => kPage line --lower case name of cons? -;-- line := conPageFastPath UPCASE a => kPage line --upper case an abbr? -;-- ySearch a --slow search (include default packages) -;-- -;--called from buttons via bcCon, bcAbb, bcConform, dbShowCons1, dbSelectCon -;conPage(a,:b) == -; --The next 4 lines allow e.g. MATRIX INT ==> Matrix Integer (see kPage) -; form := -; atom a => [a,:b] -; a -; $conArgstrings: local := [form2HtString x for x in KDR a] -; if not atom a then a := first a -; da := DOWNCASE a -; pageName := LASSQ(da,'((type . CategoryType)(union . DomainUnion)(record . DomainRecord)(mapping . DomainMapping)(enumeration . DomainEnumeration))) => -; downlink pageName --special jump out for primitive domains -; line := conPageFastPath da => kPage(line,form) --lower case name of cons? -; line := conPageFastPath UPCASE a => kPage(line,form) --upper case an abbr? -; ySearch a --slow search (include default packages) - -(DEFUN |conPage| (&REST G165763 &AUX |b| |a|) - (DSETQ (|a| . |b|) G165763) - (PROG (|$conArgstrings| |form| |da| |pageName| |line|) - (DECLARE (SPECIAL |$conArgstrings|)) - (RETURN - (SEQ (PROGN - (SPADLET |form| - (COND ((ATOM |a|) (CONS |a| |b|)) ('T |a|))) - (SPADLET |$conArgstrings| - (PROG (G165739) - (SPADLET G165739 NIL) - (RETURN - (DO ((G165744 (KDR |a|) (CDR G165744)) - (|x| NIL)) - ((OR (ATOM G165744) - (PROGN - (SETQ |x| (CAR G165744)) - NIL)) - (NREVERSE0 G165739)) - (SEQ (EXIT (SETQ G165739 - (CONS (|form2HtString| |x|) - G165739)))))))) - (COND ((NULL (ATOM |a|)) (SPADLET |a| (CAR |a|)))) - (SPADLET |da| (DOWNCASE |a|)) - (COND - ((SPADLET |pageName| - (LASSQ |da| - '((|type| . |CategoryType|) - (|union| . |DomainUnion|) - (|record| . |DomainRecord|) - (|mapping| . |DomainMapping|) - (|enumeration| . |DomainEnumeration|)))) - (|downlink| |pageName|)) - ((SPADLET |line| (|conPageFastPath| |da|)) - (|kPage| |line| |form|)) - ((SPADLET |line| (|conPageFastPath| (UPCASE |a|))) - (|kPage| |line| |form|)) - ('T (|ySearch| |a|)))))))) - -;conPageFastPath x == --called by conPage and constructorSearch -;--gets line quickly for constructor name or abbreviation -; s := STRINGIMAGE x -; charPosition(char '_*,s,0) < #s => nil --quit if name has * in it -; name := (STRINGP x => INTERN x; x) -; entry := HGET($lowerCaseConTb,name) or return nil -; lineNumber := LASSQ('dbLineNumber,CDDR entry) => -; --'dbLineNumbers property is set by function dbAugmentConstructorDataTable -; dbRead lineNumber --read record for constructor from libdb.text -; conPageConEntry first entry - -(DEFUN |conPageFastPath| (|x|) - (PROG (|s| |name| |entry| |lineNumber|) - (declare (special |$lowerCaseConTb|)) - (RETURN - (PROGN - (SPADLET |s| (STRINGIMAGE |x|)) - (COND - ((> (|#| |s|) (|charPosition| (|char| '*) |s| 0)) NIL) - ('T - (SPADLET |name| - (COND ((STRINGP |x|) (INTERN |x|)) ('T |x|))) - (SPADLET |entry| - (OR (HGET |$lowerCaseConTb| |name|) (RETURN NIL))) - (COND - ((SPADLET |lineNumber| - (LASSQ '|dbLineNumber| (CDDR |entry|))) - (|dbRead| |lineNumber|)) - ('T (|conPageConEntry| (CAR |entry|)))))))))) - -;conPageConEntry entry == -; $conname: local := nil -; $conform: local := nil -; $exposed?:local := nil -; $doc: local := nil -; $kind: local := nil -; buildLibdbConEntry entry - -(DEFUN |conPageConEntry| (|entry|) - (PROG (|$conname| |$conform| |$exposed?| |$doc| |$kind|) - (DECLARE (SPECIAL |$conname| |$conform| |$exposed?| |$doc| |$kind|)) - (RETURN - (PROGN - (SPADLET |$conname| NIL) - (SPADLET |$conform| NIL) - (SPADLET |$exposed?| NIL) - (SPADLET |$doc| NIL) - (SPADLET |$kind| NIL) - (|buildLibdbConEntry| |entry|))))) - -;--======================================================================= -;-- Constructor Page -;--======================================================================= -;-- in br-saturn.boot now -;--% kPage(line,:options) == --any cat, dom, package, default package -;--% --constructors Cname\#\E\sig \args \abb \comments (C is C, D, P, X) -;--% ------------------> BRANCH OUT FOR SATURN -;--% true => kPageSaturn(line,options) -;--% parts := dbXParts(line,7,1) -;--% [kind,name,nargs,xflag,sig,args,abbrev,comments] := parts -;--% form := IFCAR options -;--% isFile := null kind -;--% kind := kind or '"package" -;--% RPLACA(parts,kind) -;--% conform := mkConform(kind,name,args) -;--% conname := opOf conform -;--% capitalKind := capitalize kind -;--% signature := ncParseFromString sig -;--% sourceFileName := dbSourceFile INTERN name -;--% constrings := -;--% KDR form => dbConformGenUnder form -;--% [STRCONC(name,args)] -;--% emString := ['"{\sf ",:constrings,'"}"] -;--% heading := [capitalKind,'" ",:emString] -;--% if not isExposedConstructor conname then heading := ['"Unexposed ",:heading] -;--% if name=abbrev then abbrev := asyAbbreviation(conname,nargs) -;--% page := htInitPage(heading,nil) -;--% htpSetProperty(page,'isFile,true) -;--% htpSetProperty(page,'parts,parts) -;--% htpSetProperty(page,'heading,heading) -;--% htpSetProperty(page,'kind,kind) -;--% if asharpConstructorName? conname then -;--% htpSetProperty(page,'isAsharpConstructor,true) -;--% htpSetProperty(page,'conform,conform) -;--% htpSetProperty(page,'signature,signature) -;--% kdPageInfo(name,abbrev,nargs,conform,signature,isFile) -;--% htSayStandard '"\newline" -;--% htBeginMenu(3) -;--% htSayStandard '"\item " -;--% htMakePage [['bcLinks,['"\menuitemstyle{Description}", -;--% [['text,'"\tab{19}",'"General description"]],'kiPage,nil]]] -;--% satBreak() -;--% htMakePage [['bcLinks,['"\menuitemstyle{Operations}", -;--% [['text,'"\tab{19}All exported operations"]],'koPage,'"operation"]]] -;--% if not asharpConstructorName? conname then -;--% satBreak() -;--% htMakePage [['bcLinks,['"\menuitemstyle{Attributes}", -;--% [['text,'"\tab{19}All exported attributes"]],'koPage,'"attribute"]]] -;--% if kind ^= 'category and (pathname := dbHasExamplePage conname) then -;--% satBreak() -;--% htMakePage [['bcLinks,['"\menuitemstyle{Examples}", -;--% [['text,'"\tab{19}Examples illustrating use"]],'kxPage,pathname]]] -;--% satBreak() -;--% htMakePage [['bcLinks,['"\menuitemstyle{Exports}", -;--% [['text,'"\tab{19}Explicit categories and operations"]],'kePage,nil]]] -;--% satBreak() -;--% htMakePage [['bcLinks,['"\menuitemstyle{Cross Reference}", -;--% [['text,'"\tab{19}Hierarchy and usage information"]],'kcPage,nil]]] -;--% htEndMenu(3) -;--% if kind ^= 'category and nargs > 0 then addParameterTemplates conform -;--% htShowPage() -;--% -;conform2String u == -; x := form2String u -; atom x => STRINGIMAGE x -; "STRCONC"/[STRINGIMAGE y for y in x] - -(DEFUN |conform2String| (|u|) - (PROG (|x|) - (RETURN - (SEQ (PROGN - (SPADLET |x| (|form2String| |u|)) - (COND - ((ATOM |x|) (STRINGIMAGE |x|)) - ('T - (PROG (G165793) - (SPADLET G165793 "") - (RETURN - (DO ((G165798 |x| (CDR G165798)) (|y| NIL)) - ((OR (ATOM G165798) - (PROGN (SETQ |y| (CAR G165798)) NIL)) - G165793) - (SEQ (EXIT (SETQ G165793 - (STRCONC G165793 - (STRINGIMAGE |y|))))))))))))))) - -;kxPage(htPage,name) == downlink name - -(DEFUN |kxPage| (|htPage| |name|) - (declare (ignore |htPage|)) - (|downlink| |name|)) - -;kdPageInfo(name,abbrev,nargs,conform,signature,file?) == -; htSay("{\sf ",name,'"}") -; if abbrev ^= name then bcHt [" has abbreviation ",abbrev] -; if file? then bcHt ['" is a source file."] -; if nargs = 0 then (if abbrev ^= name then bcHt '".") -; else -; if abbrev ^= name then bcHt '" and" -; bcHt -; nargs = 1 => '" takes one argument:" -; [" takes ",STRINGIMAGE nargs," arguments:"] -; htSaturnBreak() -; htSayStandard '"\indentrel{2}" -; if nargs > 0 then kPageArgs(conform,signature) -; htSayStandard '"\indentrel{-2}" -; if name.(#name-1) = char "&" then name := SUBSEQ(name, 0, #name-1) -;--sourceFileName := dbSourceFile INTERN name -; sourceFileName := GETDATABASE(INTERN name,'SOURCEFILE) -; filename := extractFileNameFromPath sourceFileName -; if filename ^= '"" then -; htSayStandard '"\newline{}" -; htSay('"The source code for the constructor is found in ") -; htMakePage [['text,'"\unixcommand{",filename,'"}{_\$AXIOM/lib/SPADEDIT ", -; sourceFileName, '" ", name, '"}"]] -; if nargs ^= 0 then htSay '"." -; htSaturnBreak() - -(DEFUN |kdPageInfo| - (|name| |abbrev| |nargs| |conform| |signature| |file?|) - (PROG (|sourceFileName| |filename|) - (RETURN - (PROGN - (|htSay| '|{\\sf | |name| "}") - (COND - ((NEQUAL |abbrev| |name|) - (|bcHt| (CONS '| has abbreviation | (CONS |abbrev| NIL))))) - (COND - (|file?| (|bcHt| (CONS " is a source file." NIL)))) - (COND - ((EQL |nargs| 0) - (COND - ((NEQUAL |abbrev| |name|) (|bcHt| ".")) - ('T NIL))) - ('T - (COND - ((NEQUAL |abbrev| |name|) (|bcHt| " and"))) - (|bcHt| (COND - ((EQL |nargs| 1) - " takes one argument:") - ('T - (CONS '| takes | - (CONS (STRINGIMAGE |nargs|) - (CONS '| arguments:| NIL)))))))) - (|htSaturnBreak|) - (|htSayStandard| "\\indentrel{2}") - (COND ((> |nargs| 0) (|kPageArgs| |conform| |signature|))) - (|htSayStandard| "\\indentrel{-2}") - (COND - ((BOOT-EQUAL (ELT |name| (SPADDIFFERENCE (|#| |name|) 1)) - (|char| '&)) - (SPADLET |name| - (SUBSEQ |name| 0 (SPADDIFFERENCE (|#| |name|) 1))))) - (SPADLET |sourceFileName| - (GETDATABASE (INTERN |name|) 'SOURCEFILE)) - (SPADLET |filename| - (|extractFileNameFromPath| |sourceFileName|)) - (COND - ((NEQUAL |filename| "") - (|htSayStandard| "\\newline{}") - (|htSay| "The source code for the constructor is found in "))) - (|htMakePage| - (CONS (CONS '|text| - (CONS "\\unixcommand{" - (CONS |filename| - (CONS - "}{\\$AXIOM/lib/SPADEDIT " - (CONS |sourceFileName| - (CONS " " - (CONS |name| - (CONS "}" NIL)))))))) - NIL)) - (COND ((NEQUAL |nargs| 0) (|htSay| "."))) - (|htSaturnBreak|))))) - -;kArgPage(htPage,arg) == -; [op,:args] := conform := htpProperty(htPage,'conform) -; domname := htpProperty(htPage,'domname) -; heading := htpProperty(htPage,'heading) -; source := CDDAR getConstructorModemap op -; n := position(arg,args) -; typeForm := sublisFormal(args,source . n) -; domTypeForm := mkDomTypeForm(typeForm,conform,domname) -; descendants := domainDescendantsOf(typeForm,domTypeForm) -; htpSetProperty(htPage,'cAlist,descendants) -; rank := -; n > 4 => nil -; ('(First Second Third Fourth Fifth)).n -; htpSetProperty(htPage,'rank,rank) -; htpSetProperty(htPage,'thing,'"argument") -;--htpSetProperty(htPage,'specialMessage,['reportCategory,conform,typeForm,arg]) -; dbShowCons(htPage,'names) - -(DEFUN |kArgPage| (|htPage| |arg|) - (PROG (|conform| |op| |args| |domname| |heading| |source| |n| - |typeForm| |domTypeForm| |descendants| |rank|) - (RETURN - (PROGN - (SPADLET |conform| (|htpProperty| |htPage| '|conform|)) - (SPADLET |op| (CAR |conform|)) - (SPADLET |args| (CDR |conform|)) - (SPADLET |domname| (|htpProperty| |htPage| '|domname|)) - (SPADLET |heading| (|htpProperty| |htPage| '|heading|)) - (SPADLET |source| (CDDAR (|getConstructorModemap| |op|))) - (SPADLET |n| (|position| |arg| |args|)) - (SPADLET |typeForm| (|sublisFormal| |args| (ELT |source| |n|))) - (SPADLET |domTypeForm| - (|mkDomTypeForm| |typeForm| |conform| |domname|)) - (SPADLET |descendants| - (|domainDescendantsOf| |typeForm| |domTypeForm|)) - (|htpSetProperty| |htPage| '|cAlist| |descendants|) - (SPADLET |rank| - (COND - ((> |n| 4) NIL) - ('T - (ELT '(|First| |Second| |Third| |Fourth| |Fifth|) - |n|)))) - (|htpSetProperty| |htPage| '|rank| |rank|) - (|htpSetProperty| |htPage| '|thing| "argument") - (|dbShowCons| |htPage| '|names|))))) - -;reportCategory(conform,typeForm,arg) == -; htSay('"Argument {\em ",arg,'"}") -; [conlist,attrlist,:oplist] := categoryParts(conform,typeForm,true) -; htSay '" must " -; if conlist then -; htSay '"belong to " -; if conlist is [u] then -; htSay('"category ") -; bcConform first u -; bcPred rest u -; else -; htSay('"categories:") -; bcConPredTable(conlist,opOf conform) -; htSay '"\newline " -; if attrlist then -; if conlist then htSay '" and " -; reportAO('"attribute",attrlist) -; htSay '"\newline " -; if oplist then -; if conlist or attrlist then htSay '" and " -; reportAO('"operation",oplist) - -(DEFUN |reportCategory| (|conform| |typeForm| |arg|) - (PROG (|LETTMP#1| |conlist| |attrlist| |oplist| |u|) - (RETURN - (PROGN - (|htSay| "Argument {\\em " |arg| "}") - (SPADLET |LETTMP#1| (|categoryParts| |conform| |typeForm| 'T)) - (SPADLET |conlist| (CAR |LETTMP#1|)) - (SPADLET |attrlist| (CADR |LETTMP#1|)) - (SPADLET |oplist| (CDDR |LETTMP#1|)) - (|htSay| " must ") - (COND - (|conlist| (|htSay| "belong to ") - (COND - ((AND (CONSP |conlist|) (EQ (QCDR |conlist|) NIL) - (PROGN (SPADLET |u| (QCAR |conlist|)) 'T)) - (|htSay| "category ") - (|bcConform| (CAR |u|)) (|bcPred| (CDR |u|))) - ('T (|htSay| "categories:") - (|bcConPredTable| |conlist| (|opOf| |conform|)) - (|htSay| "\\newline "))))) - (COND - (|attrlist| (COND (|conlist| (|htSay| " and "))) - (|reportAO| "attribute" |attrlist|) - (|htSay| "\\newline "))) - (COND - (|oplist| - (COND - ((OR |conlist| |attrlist|) - (|htSay| " and "))) - (|reportAO| "operation" |oplist|)) - ('T NIL)))))) - -;reportAO(kind,oplist) == -; htSay('"have ",kind,'":") -; for [op,sig,:pred] in oplist repeat -; htSay '"\newline " -; if #oplist = 1 then htSay '"\centerline{" -; if kind = '"attribute" then -; attr := form2String [op,:sig] -; satDownLink(attr,['"(|attrPage| '|",attr,'"|)"]) -; else -; ops := escapeSpecialChars STRINGIMAGE op -; sigs := form2HtString ['Mapping,:sig] -; satDownLink(ops,['"(|opPage| '|",ops,'"| |",sigs,'"|)"]) -; htSay '": " -; bcConform ['Mapping,:sig] -; if #oplist = 1 then htSay '"}" -; htSay '"\newline " - -(DEFUN |reportAO| (|kind| |oplist|) - (PROG (|op| |sig| |pred| |attr| |ops| |sigs|) - (RETURN - (SEQ (PROGN - (|htSay| "have " |kind| ":") - (DO ((G165885 |oplist| (CDR G165885)) (G165871 NIL)) - ((OR (ATOM G165885) - (PROGN (SETQ G165871 (CAR G165885)) NIL) - (PROGN - (PROGN - (SPADLET |op| (CAR G165871)) - (SPADLET |sig| (CADR G165871)) - (SPADLET |pred| (CDDR G165871)) - G165871) - NIL)) - NIL) - (SEQ (EXIT (PROGN - (|htSay| "\\newline ") - (COND - ((EQL (|#| |oplist|) 1) - (|htSay| "\\centerline{"))) - (COND - ((BOOT-EQUAL |kind| - "attribute") - (SPADLET |attr| - (|form2String| - (CONS |op| |sig|))) - (|satDownLink| |attr| - (CONS "(|attrPage| '|" - (CONS |attr| - (CONS "|)" NIL))))) - ('T - (SPADLET |ops| - (|escapeSpecialChars| - (STRINGIMAGE |op|))) - (SPADLET |sigs| - (|form2HtString| - (CONS '|Mapping| |sig|))) - (|satDownLink| |ops| - (CONS "(|opPage| '|" - (CONS |ops| - (CONS "| |" - (CONS |sigs| - (CONS "|)" NIL)))))) - (|htSay| ": ") - (|bcConform| (CONS '|Mapping| |sig|)))) - (COND - ((EQL (|#| |oplist|) 1) - (|htSay| "}")) - ('T NIL)))))) - (|htSay| "\\newline ")))))) - -;mkDomTypeForm(typeForm,conform,domname) == --called by kargPage -; domname => SUBLISLIS(rest domname,rest conform,typeForm) -; typeForm is ['Join,:r] => ['Join,:[mkDomTypeForm(t,conform,domname) for t in r]] -; null hasIdent typeForm => typeForm -; nil - -(DEFUN |mkDomTypeForm| (|typeForm| |conform| |domname|) - (PROG (|r|) - (RETURN - (SEQ (COND - (|domname| - (SUBLISLIS (CDR |domname|) (CDR |conform|) |typeForm|)) - ((AND (CONSP |typeForm|) (EQ (QCAR |typeForm|) '|Join|) - (PROGN (SPADLET |r| (QCDR |typeForm|)) 'T)) - (CONS '|Join| - (PROG (G165906) - (SPADLET G165906 NIL) - (RETURN - (DO ((G165911 |r| (CDR G165911)) (|t| NIL)) - ((OR (ATOM G165911) - (PROGN - (SETQ |t| (CAR G165911)) - NIL)) - (NREVERSE0 G165906)) - (SEQ (EXIT (SETQ G165906 - (CONS - (|mkDomTypeForm| |t| |conform| - |domname|) - G165906))))))))) - ((NULL (|hasIdent| |typeForm|)) |typeForm|) - ('T NIL)))))) - -;domainDescendantsOf(conform,domform) == main where --called by kargPage -; main == -; conform is [op,:r] => -; op = 'Join => jfn(DELETE('(Type Object),r),DELETE('(Type Object),IFCDR domform)) -; op = 'CATEGORY => nil -; domainsOf(conform,domform) -; domainsOf(conform,domform) -; jfn([y,:r],domlist) == --keep only those domains that appear in ALL parts of Join -; alist := domainsOf(y,IFCAR domlist) -; for x in r repeat -; domlist := IFCDR domlist -; x is ['CATEGORY,.,:r] => alist := catScreen(r,alist) -; keepList := nil -; for [item,:pred] in domainsOf(x,IFCAR domlist) repeat -; u := ASSOC(item,alist) => -; keepList := [[item,:quickAnd(CDR u,pred)],:keepList] -; alist := keepList -; for pair in alist repeat RPLACD(pair,simpHasPred CDR pair) -; listSort(function GLESSEQP, alist) -; catScreen(r,alist) == -; for x in r repeat -; x isnt [op1,:.] and MEMQ(op1,'(ATTRIBUTE SIGNATURE)) => systemError x -; alist := [[item,:npred] for [item,:pred] in alist | -; (pred1 := simpHasPred ['has,item,x]) and (npred := quickAnd(pred1,pred))] -; alist - -(DEFUN |domainDescendantsOf,catScreen| (|r| |alist|) - (PROG (|op1| |item| |pred| |pred1| |npred|) - (RETURN - (SEQ (DO ((G165951 |r| (CDR G165951)) (|x| NIL)) - ((OR (ATOM G165951) - (PROGN (SETQ |x| (CAR G165951)) NIL)) - NIL) - (SEQ (IF (AND (NULL (AND (CONSP |x|) - (PROGN - (SPADLET |op1| (QCAR |x|)) - 'T))) - (member |op1| '(ATTRIBUTE SIGNATURE))) - (EXIT (|systemError| |x|))) - (EXIT (SPADLET |alist| - (PROG (G165963) - (SPADLET G165963 NIL) - (RETURN - (DO - ((G165970 |alist| - (CDR G165970)) - (G165937 NIL)) - ((OR (ATOM G165970) - (PROGN - (SETQ G165937 - (CAR G165970)) - NIL) - (PROGN - (PROGN - (SPADLET |item| - (CAR G165937)) - (SPADLET |pred| - (CDR G165937)) - G165937) - NIL)) - (NREVERSE0 G165963)) - (SEQ - (EXIT - (COND - ((AND - (SPADLET |pred1| - (|simpHasPred| - (CONS '|has| - (CONS |item| - (CONS |x| NIL))))) - (SPADLET |npred| - (|quickAnd| |pred1| - |pred|))) - (SETQ G165963 - (CONS - (CONS |item| |npred|) - G165963))))))))))))) - (EXIT |alist|))))) - -(DEFUN |domainDescendantsOf,jfn| (G165987 |domlist|) - (PROG (|y| |ISTMP#1| |r| |item| |pred| |u| |keepList| |alist|) - (RETURN - (SEQ (PROGN - (SPADLET |y| (CAR G165987)) - (SPADLET |r| (CDR G165987)) - G165987 - (SEQ (SPADLET |alist| (|domainsOf| |y| (IFCAR |domlist|))) - (DO ((G166013 |r| (CDR G166013)) (|x| NIL)) - ((OR (ATOM G166013) - (PROGN (SETQ |x| (CAR G166013)) NIL)) - NIL) - (SEQ (SPADLET |domlist| (IFCDR |domlist|)) - (IF (AND (CONSP |x|) (EQ (QCAR |x|) 'CATEGORY) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SPADLET |r| (QCDR |ISTMP#1|)) - 'T)))) - (EXIT (SPADLET |alist| - (|domainDescendantsOf,catScreen| - |r| |alist|)))) - (SPADLET |keepList| NIL) - (DO ((G166023 - (|domainsOf| |x| (IFCAR |domlist|)) - (CDR G166023)) - (G165931 NIL)) - ((OR (ATOM G166023) - (PROGN - (SETQ G165931 (CAR G166023)) - NIL) - (PROGN - (PROGN - (SPADLET |item| (CAR G165931)) - (SPADLET |pred| (CDR G165931)) - G165931) - NIL)) - NIL) - (SEQ (EXIT (IF - (SPADLET |u| - (|assoc| |item| |alist|)) - (EXIT - (SPADLET |keepList| - (CONS - (CONS |item| - (|quickAnd| (CDR |u|) - |pred|)) - |keepList|))))))) - (EXIT (SPADLET |alist| |keepList|)))) - (DO ((G166033 |alist| (CDR G166033)) - (|pair| NIL)) - ((OR (ATOM G166033) - (PROGN (SETQ |pair| (CAR G166033)) NIL)) - NIL) - (SEQ (EXIT (RPLACD |pair| - (|simpHasPred| (CDR |pair|)))))) - (EXIT (|listSort| (|function| GLESSEQP) |alist|)))))))) - -(DEFUN |domainDescendantsOf| (|conform| |domform|) - (PROG (|op| |r|) - (RETURN - (COND - ((AND (CONSP |conform|) - (PROGN - (SPADLET |op| (QCAR |conform|)) - (SPADLET |r| (QCDR |conform|)) - 'T)) - (COND - ((BOOT-EQUAL |op| '|Join|) - (|domainDescendantsOf,jfn| - (|delete| '(|Type| |Object|) |r|) - (|delete| '(|Type| |Object|) (IFCDR |domform|)))) - ((BOOT-EQUAL |op| 'CATEGORY) NIL) - ('T (|domainsOf| |conform| |domform|)))) - ('T (|domainsOf| |conform| |domform|)))))) - -;--======================================================================= -;-- Branches of Constructor Page -;--======================================================================= -;kiPage(htPage,junk) == -; [kind,name,nargs,xflag,sig,args,abbrev,comments] := htpProperty(htPage,'parts) -; conform := mkConform(kind,name,args) -; domname := kDomainName(htPage,kind,name,nargs) -; domname is ['error,:.] => errorPage(htPage,domname) -; heading := ['"Description of ", capitalize kind,'" {\sf ",name,args,'"}"] -; page := htInitPage(heading,htCopyProplist htPage) -; $conformsAreDomains := domname -; dbShowConsDoc1(htPage,conform,nil) -; htShowPage() - -(DEFUN |kiPage| (|htPage| |junk|) - (declare (ignore |junk|)) - (PROG (|LETTMP#1| |kind| |name| |nargs| |xflag| |sig| |args| |abbrev| - |comments| |conform| |domname| |heading| |page|) - (declare (special |$conformsAreDomains|)) - (RETURN - (PROGN - (SPADLET |LETTMP#1| (|htpProperty| |htPage| '|parts|)) - (SPADLET |kind| (CAR |LETTMP#1|)) - (SPADLET |name| (CADR |LETTMP#1|)) - (SPADLET |nargs| (CADDR |LETTMP#1|)) - (SPADLET |xflag| (CADDDR |LETTMP#1|)) - (SPADLET |sig| (CAR (CDDDDR |LETTMP#1|))) - (SPADLET |args| (CADR (CDDDDR |LETTMP#1|))) - (SPADLET |abbrev| (CADDR (CDDDDR |LETTMP#1|))) - (SPADLET |comments| (CADDDR (CDDDDR |LETTMP#1|))) - (SPADLET |conform| (|mkConform| |kind| |name| |args|)) - (SPADLET |domname| - (|kDomainName| |htPage| |kind| |name| |nargs|)) - (COND - ((AND (CONSP |domname|) (EQ (QCAR |domname|) '|error|)) - (|errorPage| |htPage| |domname|)) - ('T - (SPADLET |heading| - (CONS "Description of " - (CONS (|capitalize| |kind|) - (CONS " {\\sf " - (CONS |name| - (CONS |args| - (CONS "}" NIL))))))) - (SPADLET |page| - (|htInitPage| |heading| - (|htCopyProplist| |htPage|))) - (SPADLET |$conformsAreDomains| |domname|) - (|dbShowConsDoc1| |htPage| |conform| NIL) (|htShowPage|))))))) - ;kePage(htPage,junk) == ; [kind,name,nargs,xflag,sig,args,abbrev,comments] := htpProperty(htPage,'parts) ; constring := STRCONC(name,args)