diff --git a/books/bookvol5.pamphlet b/books/bookvol5.pamphlet index 1e8bbac..bc6bc63 100644 --- a/books/bookvol5.pamphlet +++ b/books/bookvol5.pamphlet @@ -51419,6 +51419,478 @@ There are 8 parts of an htPage: \end{chunk} +\defun{kcdePage}{kcdePage} +\calls{kcdePage}{htpProperty} +\calls{kcdePage}{concat} +\calls{kcdePage}{nequal} +\calls{kcdePage}{ncParseFromString} +\calls{kcdePage}{opOf} +\calls{kcdePage}{getDependentsOfConstructor} +\calls{kcdePage}{getConstructorForm} +\calls{kcdePage}{htpSetProperty} +\calls{kcdePage}{dbShowCons} +\begin{chunk}{defun kcdePage} +(defun |kcdePage| (htPage junk) + (declare (ignore junk)) + (let (lt1 kind name args conname constring conform pakname domlist cAlist) + (setq lt1 (|htpProperty| htPage '|parts|)) + (setq kind (first lt1)) + (setq name (second lt1)) + (setq args (sixth lt1)) + (setq conname (intern name)) + (setq constring (concat name args)) + (setq conform + (if (nequal kind "default package") + (|ncParseFromString| constring) + (cons (intern name) (cdr (|ncParseFromString| (concat #\d args)))))) + (setq pakname (|opOf| conform)) + (setq domlist (|getDependentsOfConstructor| pakname)) + (setq cAlist + (loop for x in domList collect (cons (|getConstructorForm| x) t))) + (|htpSetProperty| htPage '|cAlist| cAlist) + (|htpSetProperty| htPage '|thing| "dependent") + (|dbShowCons| htPage '|names|))) + +\end{chunk} + +\defun{getDependentsOfConstructor}{getDependentsOfConstructor} +\calls{getDependentsOfConstructor}{readLibPathFast} +\calls{getDependentsOfConstructor}{pathname} +\calls{getDependentsOfConstructor}{rread} +\calls{getDependentsOfConstructor}{rshut} +\begin{chunk}{defun getDependentsOfConstructor} +(defun |getDependentsOfConstructor| (con) + (let (stream val) + (setq stream + (|readLibPathFast| (|pathname| (list '|dependents| 'database '|a|)))) + (setq val (|rread| con stream nil)) + (rshut stream) + val)) + +\end{chunk} + +\defun{kcuPage}{kcuPage} +\calls{kcuPage}{htpProperty} +\calls{kcuPage}{concat} +\calls{kcuPage}{nequal} +\calls{kcuPage}{ncParseFromString} +\calls{kcuPage}{opOf} +\calls{kcuPage}{getUsersOfConstructor} +\calls{kcuPage}{getConstructorForm} +\calls{kcuPage}{htpSetProperty} +\calls{kcuPage}{dbShowCons} +\begin{chunk}{defun kcuPage} +(defun |kcuPage| (htPage junk) + (declare (ignore junk)) + (let (lt1 kind name args conname constring conform pakname domlist cAlist) + (setq lt1 (|htpProperty| htPage '|parts|)) + (setq kind (first lt1)) + (setq name (second lt1)) + (setq args (sixth lt1)) + (setq conname (intern name)) + (setq constring (concat name args)) + (setq conform + (if (nequal kind "default package") + (|ncParseFromString| constring) + (cons (intern name) + (cdr (|ncParseFromString| (concat #\d args)))))) + (setq pakname + (if (string= kind "category") + (intern (concat name #\&)) + (|opOf| conform))) + (setq domlist (|getUsersOfConstructor| pakname)) + (setq cAlist + (loop for x in domlist collect (cons (|getConstructorForm| x) t))) + (|htpSetProperty| htPage '|cAlist| cAlist) + (|htpSetProperty| htPage '|thing| "user") + (|dbShowCons| htPage '|names|))) + +\end{chunk} + +\defun{getUsersOfConstructor}{getUsersOfConstructor} +\calls{getUsersOfConstructor}{readLibPathFast} +\calls{getUsersOfConstructor}{pathname} +\calls{getUsersOfConstructor}{rread} +\calls{getUsersOfConstructor}{rshut} +\begin{chunk}{defun getUsersOfConstructor} +(defun |getUsersOfConstructor| (con) + (let (stream val) + (setq stream (|readLibPathFast| (|pathname| (list '|users| 'database '|a|)))) + (setq val (|rread| con stream nil)) + (rshut stream) + val)) + +\end{chunk} + +\defun{kcnPage}{kcnPage} +\calls{kcnPage}{kDomainName} +\calls{kcnPage}{qcar} +\calls{kcnPage}{errorPage} +\calls{kcnPage}{htpProperty} +\calls{kcnPage}{form2HtString} +\calls{kcnPage}{htpSetProperty} +\calls{kcnPage}{concat} +\calls{kcnPage}{pname} +\calls{kcnPage}{opOf} +\calls{kcnPage}{getImports} +\calls{kcnPage}{sublislis} +\calls{kcnPage}{dbShowCons} +\begin{chunk}{defun kcnPage} +(defun |kcnPage| (htPage junk) + (declare (ignore junk)) + (let (lt1 kind name nargs domname heading conform pakname domlist cAlist) + (setq lt1 (|htpProperty| htPage '|parts|)) + (setq kind (first lt1)) + (setq name (second lt1)) + (setq nargs (third lt1)) + (setq domname (|kDomainName| htPage kind name nargs)) + (cond + ((and (consp domname) (eq (qcar domname) '|error|)) + (|errorPage| htPage domname)) + (t + (setq heading + (if (null domname) + (|htpProperty| htPage '|heading|) + (list "{\\sf " (|form2HtString| domname nil t) "}"))) + (if domname + (|htpSetProperty| htPage '|domname| domname) + (|htpSetProperty| htPage '|heading| heading)) + (setq conform (|htpProperty| htPage '|conform|)) + (setq pakname + (if (string= kind "category") + (intern (concat (pname conname) #\&)) + (|opOf| conform))) + (setq domlist (|getImports| pakname)) + (when domname + (setq domlist + (sublislis (cons domname (cdr domname)) + (cons '$ (cdr conform)) domlist))) + (setq cAlist (loop for x in domList collect (cons x t))) + (|htpSetProperty| htPage '|cAlist| cAlist) + (|htpSetProperty| htPage '|thing| "benefactor") + (|dbShowCons| htPage '|names|))))) + +\end{chunk} + +\defun{koPageInputAreaUnchanged?}{koPageInputAreaUnchanged?} +\calls{koPageInputAreaUnchanged?}{htpLabelInputString} +\calls{koPageInputAreaUnchanged?}{concat} +\calls{koPageInputAreaUnchanged?}{stringimage} +\calls{koPageInputAreaUnchanged?}{htpProperty} +\begin{chunk}{defun koPageInputAreaUnchanged?} +(defun |koPageInputAreaUnchanged?| (htPage nargs) + (equal + (loop for i from 1 to nargs + collect + (|htpLabelInputString| htPage (intern (concat "*" (stringimage i))))) + (|htpProperty| htPage '|inputAreaList|))) + +\end{chunk} + +\defun{kDomainName}{kDomainName} +\calls{kDomainName}{htpSetProperty} +\calls{kDomainName}{htpLabelInputString} +\calls{kDomainName}{getdatabase} +\calls{kDomainName}{kArgumentCheck} +\calls{kDomainName}{kdr} +\calls{kDomainName}{concat} +\calls{kDomainName}{unabbrev} +\calls{kDomainName}{mkConform} +\calls{kDomainName}{kisValidType} +\calls{kDomainName}{dbMkEvalable} +\catches{kDomainName}{spad-reader} +\usesdollar{kDomainName}{PatternVariableList} +\begin{chunk}{defun kDomainName} +(defun |kDomainName| (htPage kind name nargs) + (let (inputAreaList conname args n argTailPart argString typeForm + evaluatedTypeForm) + (|htpSetProperty| htPage '|domname| nil) + (setq inputAreaList + (loop for i from 1 to nargs for var in |$PatternVariableList| do + collect (|htpLabelInputString| htPage var))) + (|htpSetProperty| htPage '|inputAreaList| inputAreaList) + (setq conname (intern name)) + (setq args + (loop for x in inputAreaList + for domain? in (cdr (getdatabase conname 'cosig)) + collect (or (|kArgumentCheck| domain? x) nil))) + (when (some #'identity (loop for x in args collect (null x))) + (cond + ((> (setq n (apply #'+ (loop for x in args collect (if x 1 0)))) 0) + (list '|error| nil "\\centerline{You gave values for only {\\em " + n " } of the {\\em " (|#| args) "}}" + "\\centerline{parameters of {\\sf " name + "}}\\vspace{1}\\centerline{Please enter either {\\em all} or " + "{\\em none} of the type parameters}") + nil) + (t + (setq argString + (cond + ((null args) "()") + (t + (setq argTailPart + (apply #'concat + (loop for x in (kdr args) collect (concat (cons "," x))))) + (apply #'concat (list "(" (car args) argTailPart ")"))))) + (setq typeForm + (or (catch 'spad_reader (|unabbrev| (|mkConform| kind name argString))) + (list '|error| '|invalidType| (concat name argString)))) + (if (null (setq evaluatedTypeForm (|kisValidType| typeForm))) + (list '|error| '|invalidType| (concat name argString)) + (|dbMkEvalable| evaluatedTypeForm))))))) + +\end{chunk} + +\defun{kArgumentCheck}{kArgumentCheck} +\calls{kArgumentCheck}{conSpecialString?} +\calls{kArgumentCheck}{kdr} +\calls{kArgumentCheck}{stringimage} +\calls{kArgumentCheck}{opOf} +\calls{kArgumentCheck}{form2String} +\begin{chunk}{defun kArgumentCheck} +(defun |kArgumentCheck| (domain? s) + (let (form) + (cond + ((string= s "") nil) + ((and domain? (setq form (|conSpecialString?| s))) + (if (null (kdr form)) + (list (stringimage (|opOf| form))) + (|form2String| form))) + (t (list s))))) + +\end{chunk} + +\defun{dbMkEvalable}{dbMkEvalable} +\calls{dbMkEvalable}{getdatabase} +\calls{dbMkEvalable}{mkEvalable} +\begin{chunk}{defun dbMkEvalable} +(defun |dbMkEvalable| (form) + (let (op kind) + (setq op (car form)) + (setq kind (getdatabase op 'constructorkind)) + (if (eq kind '|category|) + form + (|mkEvalable| form)))) + +\end{chunk} + +\defun{topLevelInterpEval}{topLevelInterpEval} +\calls{topLevelInterpEval}{processInteractive} +\usesdollar{topLevelInterpEval}{ProcessInteractiveValue} +\usesdollar{topLevelInterpEval}{noEvalTypeMsg} +\begin{chunk}{defun topLevelInterpEval} +(defun |topLevelInterpEval| (x) + (let (|$ProcessInteractiveValue| |$noEvalTypeMsg|) + (declare (special |$ProcessInteractiveValue| |$noEvalTypeMsg|)) + (setq |$ProcessInteractiveValue| t) + (setq |$noEvalTypeMsg| t) + (|processInteractive| x nil))) + +\end{chunk} + +\defun{kisValidType}{kisValidType} +\calls{kisValidType}{processInteractive} +\calls{kisValidType}{member} +\calls{kisValidType}{kCheckArgumentNumbers} +\usesdollar{kisValidType}{ProcessInteractiveValue} +\usesdollar{kisValidType}{noEvalTypeMsg} +\catches{kisValidType}{spad-reader} +\begin{chunk}{defun kisValidType} +(defun |kisValidType| (typeForm) + (let (|$ProcessInteractiveValue| |$noEvalTypeMsg| it1) + (declare (special |$ProcessInteractiveValue| |$noEvalTypeMsg|)) + (setq |$ProcessInteractiveValue| t) + (setq |$noEvalTypeMsg| t) + (setq it1 (catch 'spad_reader (|processInteractive| typeForm nil))) + (when (and (consp it1) (consp (qcar it1))) + (|member| (caar it1) '(domain |SubDomain|))) + (and (|kCheckArgumentNumbers| (qcdr it1)) (qcdr it1)))) + +\end{chunk} + +\defun{kCheckArgumentNumbers}{kCheckArgumentNumbers} +\calls{kCheckArgumentNumbers}{kdr} +\calls{kCheckArgumentNumbers}{getdatabase} +\calls{kCheckArgumentNumbers}{kCheckArgumentNumber} +\begin{chunk}{defun kCheckArgumentNumbers} +(defun |kCheckArgumentNumbers| (tt) + (let (conname args cosig) + (setq conname (car tt)) + (setq args (cdr tt)) + (setq cosig (kdr (getdatabase conname 'cosig))) + (every #'identity + (loop for domain? in cosig for x in args + collect (if domain? (|kCheckArgumentNumbers| x) t))))) + +\end{chunk} + +\defun{parseNoMacroFromString}{parseNoMacroFromString} +\calls{parseNoMacroFromString}{next} +\calls{parseNoMacroFromString}{function} +\calls{parseNoMacroFromString}{ncloopParse} +\calls{parseNoMacroFromString}{lineoftoks} +\calls{parseNoMacroFromString}{incString} +\calls{parseNoMacroFromString}{StreamNull} +\calls{parseNoMacroFromString}{pf2Sex} +\begin{chunk}{defun parseNoMacroFromString} +(defun |parseNoMacroFromString| (s) + (setq s + (|next| (|function| |ncloopParse|) + (|next| (|function| |lineoftoks|) + (|incString| s)))) + (if (|StreamNull| s) + nil + (|pf2Sex| (cadar s)))) + +\end{chunk} + +\defun{mkConform}{mkConform} +\calls{mkConform}{nequal} +\calls{mkConform}{parseNoMacroFromString} +\calls{mkConform}{sayBrightlyNT} +\calls{mkConform}{pp} +\calls{mkConform}{systemError} +\calls{mkConform}{ncParseFromString} +\calls{mkConform}{concat} +\begin{chunk}{defun mkConform} +(defun |mkConform| (kind name argString) + (let (form parse) + (cond + ((nequal kind "default package") + (setq form (concat name argString)) + (setq parse (|parseNoMacroFromString| form)) + (cond + ((null parse) + (|sayBrightlyNT| "Won't parse: ") + (|pp| form) + (|systemError| "Keywords in argument list?")) + ((atom parse) (cons parse nil)) + (t parse))) + (t + (cons (intern name) (cdr (|ncParseFromString| (concat #\d argString)))))))) + +\end{chunk} + +\defun{conOpPage}{conOpPage} +\calls{conOpPage}{dbCompositeWithMap} +\calls{conOpPage}{htpProperty} +\calls{conOpPage}{conOpPage1} +\calls{conOpPage}{dbExtractUnderlyingDomain} +\begin{chunk}{defun conOpPage} +(defun |conOpPage| (htPage conform) + (declare (ignore conform)) + (let (updown domname) + (setq updown (|dbCompositeWithMap| htPage)) + (cond + ((string= updown "DOWN") + (setq domname (|htpProperty| htPage '|domname|)) + (|conOpPage1| (|dbExtractUnderlyingDomain| domname) + (list (cons '|updomain| domname)))) + (t + (setq domname (|htpProperty| htPage '|updomain|)) + (|conOpPage1| domname nil))))) + +\end{chunk} + +\defun{conOpPage1}{conOpPage1} +\calls{conOpPage1}{ifcar} +\calls{conOpPage1}{opOf} +\calls{conOpPage1}{dbSpecialOperations} +\calls{conOpPage1}{conPageFastPath} +\calls{conOpPage1}{dbXParts} +\calls{conOpPage1}{concat} +\calls{conOpPage1}{mkConform} +\calls{conOpPage1}{captialize} +\calls{conOpPage1}{ncParseFromString} +\calls{conOpPage1}{dbSourceFile} +\calls{conOpPage1}{isExposedConstructor} +\calls{conOpPage1}{htInitPage} +\calls{conOpPage1}{htpSetProperty} +\calls{conOpPage1}{lassoc} +\calls{conOpPage1}{ifcdr} +\calls{conOpPage1}{koPage} +\usesdollar{conOpPage1}{Primitives} +\begin{chunk}{defun conOpPage1} +(defun |conOpPage1| (&rest args) + (let (bindingsAlist conname domname line parts name sig args isFile kind + constring capitalKind signature sourceFileName emString heading page + selectedOperation a b options conform) + (declare (special |$Primitives|)) + (setq conform (car args)) + (setq options (cdr args)) + (setq bindingsAlist (ifcar options)) + (setq conname (|opOf| conform)) + (cond + ((member conname |$Primitives|) (|dbSpecialOperations| conname)) + (t + (setq domname (unless (atom conform) conform)) + (setq line (|conPageFastPath| conname)) + (setq parts (|dbXParts| line 7 1)) + (setq kind (first parts)) + (setq name (second parts)) + (setq sig (fifth parts)) + (setq args (sixth parts)) + (setq isFile (null kind)) + (setq kind (or kind "package")) + (rplaca parts kind) + (setq constring (concat name args)) + (setq conform (|mkConform| kind name args)) + (setq capitalKind (|capitalize| kind)) + (setq signature (|ncParseFromString| sig)) + (setq sourceFileName (|dbSourceFile| (intern name))) + (setq emString (list "{\\sf " constring "}")) + (setq heading (cons capitalKind (cons " " emString))) + (unless (|isExposedConstructor| conname) + (setq heading (cons "Unexposed " heading))) + (setq page (|htInitPage| heading nil)) + (|htpSetProperty| page '|isFile| t) + (|htpSetProperty| page '|fromConOpPage1| t) + (|htpSetProperty| page '|parts| parts) + (|htpSetProperty| page '|heading| heading) + (|htpSetProperty| page '|kind| kind) + (|htpSetProperty| page '|domname| domname) + (|htpSetProperty| page '|conform| conform) + (|htpSetProperty| page '|signature| signature) + (when + (setq selectedOperation (lassoc '|selectedOperation| (ifcdr options))) + (|htpSetProperty| page '|selectedOperation| selectedOperation)) + (loop for item in bindingsAlist + collect (|htpSetProperty| page (car item) (cdr item))) + (|koPage| page "operation"))))) + +\end{chunk} + +\defun{dbCompositeWithMap}{dbCompositeWithMap} +\calls{dbCompositeWithMap}{htpProperty} +\calls{dbCompositeWithMap}{dbExtractUnderlyingDomain} +\begin{chunk}{defun dbCompositeWithMap} +(defun |dbCompositeWithMap| (htPage) + (let (domain opAlist) + (cond + ((|htpProperty| htPage '|updomain|) "UP") + (t + (setq domain (|htpProperty| htPage '|domname|)) + (cond + ((null domain) nil) + (t + (setq opAlist (|htpProperty| htPage '|opAlist|)) + (when + (|dbExtractUnderlyingDomain| (|htpProperty| htPage '|domname|)) + "DOWN"))))))) + +\end{chunk} + +\defun{dbExtractUnderlyingDomain}{dbExtractUnderlyingDomain} +\calls{dbExtractUnderlyingDomain}{kdr} +\calls{dbExtractUnderlyingDomain}{isValidType} +\begin{chunk}{defun dbExtractUnderlyingDomain} +(defun |dbExtractUnderlyingDomain| (domain) + (some #'identity + (loop for x in (kdr domain) when (|isValidType| x) collect x))) + +\end{chunk} + + \chapter{The Interpreter} \begin{chunk}{Interpreter} (setq *print-array* nil) @@ -52004,6 +52476,8 @@ There are 8 parts of an htPage: \getchunk{defun compressOpen} \getchunk{defun computeDomainVariableAlist} \getchunk{defun condErrorMsg} +\getchunk{defun conOpPage} +\getchunk{defun conOpPage1} \getchunk{defun conPage} \getchunk{defun conPageConEntry} \getchunk{defun conPageFastPath} @@ -52015,6 +52489,8 @@ There are 8 parts of an htPage: \getchunk{defun countCache} \getchunk{defun DaaseName} +\getchunk{defun dbCompositeWithMap} +\getchunk{defun dbExtractUnderlyingDomain} \getchunk{defun dbNonEmptyPattern} \getchunk{defun dbSearchOrder} \getchunk{defun decideHowMuch} @@ -52130,6 +52606,7 @@ There are 8 parts of an htPage: \getchunk{defun getBpiNameIfTracedMap} \getchunk{defun getBrowseDatabase} \getchunk{defun getdatabase} +\getchunk{defun getDependentsOfConstructor} \getchunk{defun getDirectoryList} \getchunk{defun getFirstWord} \getchunk{defun getKeyedMsg} @@ -52156,6 +52633,7 @@ There are 8 parts of an htPage: \getchunk{defun getTraceOption} \getchunk{defun getTraceOption,hn} \getchunk{defun getTraceOptions} +\getchunk{defun getUsersOfConstructor} \getchunk{defun getWorkspaceNames} \getchunk{defun handleNoParseCommands} @@ -52387,20 +52865,28 @@ There are 8 parts of an htPage: \getchunk{defun justifyMyType} \getchunk{defun kArgPage} +\getchunk{defun kArgumentCheck} \getchunk{defun kcaPage} \getchunk{defun kcaPage1} \getchunk{defun kccPage} +\getchunk{defun kcdePage} \getchunk{defun kcdPage} \getchunk{defun kcdoPage} +\getchunk{defun kCheckArgumentNumbers} +\getchunk{defun kcnPage} \getchunk{defun kcPage} \getchunk{defun kcpPage} +\getchunk{defun kDomainName} \getchunk{defun kdPageInfo} \getchunk{defun KeepPart?} \getchunk{defun kePage} \getchunk{defun kePageDisplay} \getchunk{defun kePageOpAlist} \getchunk{defun kiPage} +\getchunk{defun kisValidType} +\getchunk{defun koPageInputAreaUnchanged?} \getchunk{defun ksPage} +\getchunk{defun kcuPage} \getchunk{defun lassocSub} \getchunk{defun lastTokPosn} @@ -52468,6 +52954,7 @@ There are 8 parts of an htPage: \getchunk{defun messageprint} \getchunk{defun messageprint-1} \getchunk{defun messageprint-2} +\getchunk{defun mkConform} \getchunk{defun mkCurryFun} \getchunk{defun mkDomPvar} \getchunk{defun mkDomTypeForm} @@ -52771,6 +53258,7 @@ There are 8 parts of an htPage: \getchunk{defun parseAndEval1} \getchunk{defun parseAndInterpret} \getchunk{defun parseFromString} +\getchunk{defun parseNoMacroFromString} \getchunk{defun parseSystemCmd} \getchunk{defun parseWord} \getchunk{defun pathname} @@ -53235,6 +53723,7 @@ There are 8 parts of an htPage: \getchunk{defun tokPosn} \getchunk{defun tokTran} \getchunk{defun tokType} +\getchunk{defun topLevelInterpEval} \getchunk{defun toScreen?} \getchunk{defun trace} \getchunk{defun trace1} diff --git a/changelog b/changelog index fd73f38..ec8b45f 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,6 @@ +20130607 tpd src/axiom-website/patches.html 20130607.03.tpd.patch +20130607 tpd src/interp/br-con.lisp move functions to bookvol5 +20130607 tpd books/bookvol5 move functions from br-con.lisp 20130607 tpd src/axiom-website/patches.html 20130607.02.tpd.patch 20130607 tpd books/bookvol0 fix typos 20130607 tpd books/bookvol1 fix typos diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index dd689e8..ae49d5f 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -4195,6 +4195,8 @@ books/bookvol5 rewrite code from br-con books/bookvol8.1 add crc test cases 20130607.02.tpd.patch books/bookvol{0,1,2,4} fix typos +20130607.03.tpd.patch +books/bookvol5 move functions from br-con.lisp diff --git a/src/interp/br-con.lisp.pamphlet b/src/interp/br-con.lisp.pamphlet index c3ebdfb..5d3062c 100644 --- a/src/interp/br-con.lisp.pamphlet +++ b/src/interp/br-con.lisp.pamphlet @@ -12,849 +12,6 @@ \begin{chunk}{*} (IN-PACKAGE "BOOT" ) -;kcdePage(htPage,junk) == -; [kind,name,nargs,xflag,sig,args,abbrev,comments] := htpProperty(htPage,'parts) -; conname := INTERN name -; constring := STRCONC(name,args) -; conform := -; kind ^= '"default package" => ncParseFromString constring -; [INTERN name,:rest ncParseFromString STRCONC(char 'd,args)] --because of & -; pakname := -;-- kind = '"category" => INTERN STRCONC(name,char '_&) -; opOf conform -; domList := getDependentsOfConstructor pakname -; cAlist := [[getConstructorForm x,:true] for x in domList] -; htpSetProperty(htPage,'cAlist,cAlist) -; htpSetProperty(htPage,'thing,'"dependent") -; dbShowCons(htPage,'names) - -(DEFUN |kcdePage| (|htPage| |junk|) - (declare (ignore |junk|)) - (PROG (|LETTMP#1| |kind| |name| |nargs| |xflag| |sig| |args| |abbrev| - |comments| |conname| |constring| |conform| |pakname| - |domList| |cAlist|) - (RETURN - (SEQ (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 |conname| (INTERN |name|)) - (SPADLET |constring| (STRCONC |name| |args|)) - (SPADLET |conform| - (COND - ((NEQUAL |kind| "default package") - (|ncParseFromString| |constring|)) - ('T - (CONS (INTERN |name|) - (CDR (|ncParseFromString| - (STRCONC (|char| '|d|) |args|))))))) - (SPADLET |pakname| (|opOf| |conform|)) - (SPADLET |domList| - (|getDependentsOfConstructor| |pakname|)) - (SPADLET |cAlist| - (PROG (G166636) - (SPADLET G166636 NIL) - (RETURN - (DO ((G166641 |domList| (CDR G166641)) - (|x| NIL)) - ((OR (ATOM G166641) - (PROGN - (SETQ |x| (CAR G166641)) - NIL)) - (NREVERSE0 G166636)) - (SEQ (EXIT (SETQ G166636 - (CONS - (CONS - (|getConstructorForm| |x|) - 'T) - G166636)))))))) - (|htpSetProperty| |htPage| '|cAlist| |cAlist|) - (|htpSetProperty| |htPage| '|thing| - "dependent") - (|dbShowCons| |htPage| '|names|)))))) - -;getDependentsOfConstructor(con) == -; stream := readLib1('dependents, 'DATABASE, 'a) -; val := rread(con, stream, nil) -; RSHUT stream -; val - -(DEFUN |getDependentsOfConstructor| (|con|) - (PROG (|stream| |val|) - (RETURN - (PROGN - (SPADLET |stream| - (|readLibPathFast| (|pathname| (list '|dependents| 'DATABASE '|a|)))) - (SPADLET |val| (|rread| |con| |stream| NIL)) - (RSHUT |stream|) - |val|)))) - -;kcuPage(htPage,junk) == -; [kind,name,nargs,xflag,sig,args,abbrev,comments] := htpProperty(htPage,'parts) -; conname := INTERN name -; constring := STRCONC(name,args) -; conform := -; kind ^= '"default package" => ncParseFromString constring -; [INTERN name,:rest ncParseFromString STRCONC(char 'd,args)] --because of & -; pakname := -; kind = '"category" => INTERN STRCONC(name,char '_&) -; opOf conform -; domList := getUsersOfConstructor pakname -; cAlist := [[getConstructorForm x,:true] for x in domList] -; htpSetProperty(htPage,'cAlist,cAlist) -; htpSetProperty(htPage,'thing,'"user") -; dbShowCons(htPage,'names) - -(DEFUN |kcuPage| (|htPage| |junk|) - (declare (ignore |junk|)) - (PROG (|LETTMP#1| |kind| |name| |nargs| |xflag| |sig| |args| |abbrev| - |comments| |conname| |constring| |conform| |pakname| - |domList| |cAlist|) - (RETURN - (SEQ (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 |conname| (INTERN |name|)) - (SPADLET |constring| (STRCONC |name| |args|)) - (SPADLET |conform| - (COND - ((NEQUAL |kind| "default package") - (|ncParseFromString| |constring|)) - ('T - (CONS (INTERN |name|) - (CDR (|ncParseFromString| - (STRCONC (|char| '|d|) |args|))))))) - (SPADLET |pakname| - (COND - ((BOOT-EQUAL |kind| "category") - (INTERN (STRCONC |name| (|char| '&)))) - ('T (|opOf| |conform|)))) - (SPADLET |domList| (|getUsersOfConstructor| |pakname|)) - (SPADLET |cAlist| - (PROG (G166692) - (SPADLET G166692 NIL) - (RETURN - (DO ((G166697 |domList| (CDR G166697)) - (|x| NIL)) - ((OR (ATOM G166697) - (PROGN - (SETQ |x| (CAR G166697)) - NIL)) - (NREVERSE0 G166692)) - (SEQ (EXIT (SETQ G166692 - (CONS - (CONS - (|getConstructorForm| |x|) - 'T) - G166692)))))))) - (|htpSetProperty| |htPage| '|cAlist| |cAlist|) - (|htpSetProperty| |htPage| '|thing| "user") - (|dbShowCons| |htPage| '|names|)))))) - -;getUsersOfConstructor(con) == -; stream := readLib1('users, 'DATABASE, 'a) -; val := rread(con, stream, nil) -; RSHUT stream -; val - -(DEFUN |getUsersOfConstructor| (|con|) - (PROG (|stream| |val|) - (RETURN - (PROGN - (SPADLET |stream| - (|readLibPathFast| (|pathname| (list '|users| 'DATABASE '|a|)))) - (SPADLET |val| (|rread| |con| |stream| NIL)) - (RSHUT |stream|) - |val|)))) - -;kcnPage(htPage,junk) == -;--if reached by a category, that category has a default package -; [kind,name,nargs,xpart,sig,args,abbrev,comments] := htpProperty(htPage,'parts) -; domname := kDomainName(htPage,kind,name,nargs) -; domname is ['error,:.] => errorPage(htPage,domname) -; heading := -; null domname => htpProperty(htPage,'heading) -; ['"{\sf ",form2HtString(domname,nil,true),'"}"] -; if domname then -; htpSetProperty(htPage,'domname,domname) -; htpSetProperty(htPage,'heading,heading) -; conform:= htpProperty(htPage,'conform) -; pakname := -; kind = '"category" => INTERN STRCONC(PNAME conname,char '_&) -; opOf conform -; domList := getImports pakname -; if domname then -; domList := SUBLISLIS([domname,:rest domname],['$,:rest conform],domList) -; cAlist := [[x,:true] for x in domList] -; htpSetProperty(htPage,'cAlist,cAlist) -; htpSetProperty(htPage,'thing,'"benefactor") -; dbShowCons(htPage,'names) - -(DEFUN |kcnPage| (|htPage| |junk|) - (declare (ignore |junk|)) - (PROG (|LETTMP#1| |kind| |name| |nargs| |xpart| |sig| |args| |abbrev| - |comments| |domname| |heading| |conform| |pakname| - |domList| |cAlist|) - (RETURN - (SEQ (PROGN - (SPADLET |LETTMP#1| (|htpProperty| |htPage| '|parts|)) - (SPADLET |kind| (CAR |LETTMP#1|)) - (SPADLET |name| (CADR |LETTMP#1|)) - (SPADLET |nargs| (CADDR |LETTMP#1|)) - (SPADLET |xpart| (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 |domname| - (|kDomainName| |htPage| |kind| |name| |nargs|)) - (COND - ((AND (CONSP |domname|) (EQ (QCAR |domname|) '|error|)) - (|errorPage| |htPage| |domname|)) - ('T - (SPADLET |heading| - (COND - ((NULL |domname|) - (|htpProperty| |htPage| '|heading|)) - ('T - (CONS "{\\sf " - (CONS (|form2HtString| |domname| NIL - 'T) - (CONS "}" NIL)))))) - (COND - (|domname| - (|htpSetProperty| |htPage| '|domname| |domname|) - (|htpSetProperty| |htPage| '|heading| |heading|))) - (SPADLET |conform| (|htpProperty| |htPage| '|conform|)) - (SPADLET |pakname| - (COND - ((BOOT-EQUAL |kind| "category") - (INTERN (STRCONC (PNAME |conname|) - (|char| '&)))) - ('T (|opOf| |conform|)))) - (SPADLET |domList| (|getImports| |pakname|)) - (COND - (|domname| - (SPADLET |domList| - (SUBLISLIS - (CONS |domname| (CDR |domname|)) - (CONS '$ (CDR |conform|)) |domList|)))) - (SPADLET |cAlist| - (PROG (G166749) - (SPADLET G166749 NIL) - (RETURN - (DO ((G166754 |domList| (CDR G166754)) - (|x| NIL)) - ((OR (ATOM G166754) - (PROGN - (SETQ |x| (CAR G166754)) - NIL)) - (NREVERSE0 G166749)) - (SEQ (EXIT - (SETQ G166749 - (CONS (CONS |x| 'T) G166749)))))))) - (|htpSetProperty| |htPage| '|cAlist| |cAlist|) - (|htpSetProperty| |htPage| '|thing| - "benefactor") - (|dbShowCons| |htPage| '|names|)))))))) - -;koPageInputAreaUnchanged?(htPage, nargs) == -; [htpLabelInputString(htPage,INTERN STRCONC('"*",STRINGIMAGE i)) for i in 1..nargs] -; = htpProperty(htPage,'inputAreaList) - -(DEFUN |koPageInputAreaUnchanged?| (|htPage| |nargs|) - (PROG () - (RETURN - (SEQ (BOOT-EQUAL - (PROG (G166784) - (SPADLET G166784 NIL) - (RETURN - (DO ((|i| 1 (QSADD1 |i|))) - ((QSGREATERP |i| |nargs|) (NREVERSE0 G166784)) - (SEQ (EXIT (SETQ G166784 - (CONS - (|htpLabelInputString| |htPage| - (INTERN - (STRCONC "*" - (STRINGIMAGE |i|)))) - G166784))))))) - (|htpProperty| |htPage| '|inputAreaList|)))))) - -;kDomainName(htPage,kind,name,nargs) == -; htpSetProperty(htPage,'domname,nil) -; inputAreaList := -; [htpLabelInputString(htPage,var) for i in 1..nargs for var in $PatternVariableList] -; htpSetProperty(htPage,'inputAreaList,inputAreaList) -; conname := INTERN name -; args := [kArgumentCheck(domain?,x) or nil for x in inputAreaList -; for domain? in rest GETDATABASE(conname,'COSIG)] -; or/[null x for x in args] => -; (n := +/[1 for x in args | x]) > 0 => -; ['error,nil,'"\centerline{You gave values for only {\em ",n,'" } of the {\em ",#args,'"}}",'"\centerline{parameters of {\sf ",name,'"}}\vspace{1}\centerline{Please enter either {\em all} or {\em none} of the type parameters}"] -; nil -; argString := -; null args => '"()" -; argTailPart := -; "STRCONC"/["STRCONC"/ ['",",:x] for x in KDR args] -; "STRCONC"/['"(",:first args,argTailPart,'")"] -; typeForm := CATCH('SPAD__READER, unabbrev mkConform(kind,name,argString)) or -; ['error,'invalidType,STRCONC(name,argString)] -; null (evaluatedTypeForm := kisValidType typeForm) => -; ['error,'invalidType,STRCONC(name,argString)] -; dbMkEvalable evaluatedTypeForm - -(DEFUN |kDomainName| (|htPage| |kind| |name| |nargs|) - (PROG (|inputAreaList| |conname| |args| |n| |argTailPart| |argString| - |typeForm| |evaluatedTypeForm|) - (RETURN - (SEQ (PROGN - (|htpSetProperty| |htPage| '|domname| NIL) - (SPADLET |inputAreaList| - (PROG (G166806) - (SPADLET G166806 NIL) - (RETURN - (DO ((|i| 1 (QSADD1 |i|)) - (G166812 |$PatternVariableList| - (CDR G166812)) - (|var| NIL)) - ((OR (QSGREATERP |i| |nargs|) - (ATOM G166812) - (PROGN - (SETQ |var| (CAR G166812)) - NIL)) - (NREVERSE0 G166806)) - (SEQ (EXIT (SETQ G166806 - (CONS - (|htpLabelInputString| - |htPage| |var|) - G166806)))))))) - (|htpSetProperty| |htPage| '|inputAreaList| - |inputAreaList|) - (SPADLET |conname| (INTERN |name|)) - (SPADLET |args| - (PROG (G166824) - (SPADLET G166824 NIL) - (RETURN - (DO ((G166830 |inputAreaList| - (CDR G166830)) - (|x| NIL) - (G166831 - (CDR (GETDATABASE |conname| 'COSIG)) - (CDR G166831)) - (|domain?| NIL)) - ((OR (ATOM G166830) - (PROGN - (SETQ |x| (CAR G166830)) - NIL) - (ATOM G166831) - (PROGN - (SETQ |domain?| (CAR G166831)) - NIL)) - (NREVERSE0 G166824)) - (SEQ (EXIT (SETQ G166824 - (CONS - (OR - (|kArgumentCheck| |domain?| - |x|) - NIL) - G166824)))))))) - (COND - ((PROG (G166840) - (SPADLET G166840 NIL) - (RETURN - (DO ((G166846 NIL G166840) - (G166847 |args| (CDR G166847)) (|x| NIL)) - ((OR G166846 (ATOM G166847) - (PROGN (SETQ |x| (CAR G166847)) NIL)) - G166840) - (SEQ (EXIT (SETQ G166840 - (OR G166840 (NULL |x|)))))))) - (COND - ((> (SPADLET |n| - (PROG (G166854) - (SPADLET G166854 0) - (RETURN - (DO - ((G166860 |args| (CDR G166860)) - (|x| NIL)) - ((OR (ATOM G166860) - (PROGN - (SETQ |x| (CAR G166860)) - NIL)) - G166854) - (SEQ - (EXIT - (COND - (|x| - (SETQ G166854 - (PLUS G166854 1)))))))))) - 0) - (CONS '|error| - (CONS NIL - (CONS "\\centerline{You gave values for only {\\em " - (CONS |n| - (CONS - " } of the {\\em " - (CONS (|#| |args|) - (CONS "}}" - (CONS - "\\centerline{parameters of {\\sf " - (CONS |name| - (CONS - "}}\\vspace{1}\\centerline{Please enter either {\\em all} or {\\em none} of the type parameters}" - NIL))))))))))) - ('T NIL))) - ('T - (SPADLET |argString| - (COND - ((NULL |args|) "()") - ('T - (SPADLET |argTailPart| - (PROG (G166866) - (SPADLET G166866 "") - (RETURN - (DO - ((G166871 (KDR |args|) - (CDR G166871)) - (|x| NIL)) - ((OR (ATOM G166871) - (PROGN - (SETQ |x| - (CAR G166871)) - NIL)) - G166866) - (SEQ - (EXIT - (SETQ G166866 - (STRCONC G166866 - (PROG (G166877) - (SPADLET G166877 "") - (RETURN - (DO - ((G166882 - (CONS - "," - |x|) - (CDR G166882)) - (G166796 NIL)) - ((OR - (ATOM G166882) - (PROGN - (SETQ G166796 - (CAR - G166882)) - NIL)) - G166877) - (SEQ - (EXIT - (SETQ G166877 - (STRCONC - G166877 - G166796))))))))))))))) - (PROG (G166888) - (SPADLET G166888 "") - (RETURN - (DO ((G166893 - (CONS "(" - (APPEND (CAR |args|) - (CONS |argTailPart| - (CONS ")" NIL)))) - (CDR G166893)) - (G166797 NIL)) - ((OR (ATOM G166893) - (PROGN - (SETQ G166797 - (CAR G166893)) - NIL)) - G166888) - (SEQ (EXIT - (SETQ G166888 - (STRCONC G166888 G166797)))))))))) - (SPADLET |typeForm| - (OR (CATCH 'SPAD_READER - (|unabbrev| - (|mkConform| |kind| |name| - |argString|))) - (CONS '|error| - (CONS '|invalidType| - (CONS (STRCONC |name| |argString|) - NIL))))) - (COND - ((NULL (SPADLET |evaluatedTypeForm| - (|kisValidType| |typeForm|))) - (CONS '|error| - (CONS '|invalidType| - (CONS (STRCONC |name| |argString|) NIL)))) - ('T (|dbMkEvalable| |evaluatedTypeForm|)))))))))) - -;kArgumentCheck(domain?,s) == -; s = '"" => nil -; domain? and (form := conSpecialString? s) => -; null KDR form => [STRINGIMAGE opOf form] -; form2String form -; [s] - -(DEFUN |kArgumentCheck| (|domain?| |s|) - (PROG (|form|) - (RETURN - (COND - ((BOOT-EQUAL |s| "") NIL) - ((AND |domain?| (SPADLET |form| (|conSpecialString?| |s|))) - (COND - ((NULL (KDR |form|)) - (CONS (STRINGIMAGE (|opOf| |form|)) NIL)) - ('T (|form2String| |form|)))) - ('T (CONS |s| NIL)))))) - -;dbMkEvalable form == -;--like mkEvalable except that it does NOT quote domains -;--does not do "loadIfNecessary" -; [op,:.] := form -; kind := GETDATABASE(op,'CONSTRUCTORKIND) -; kind = 'category => form -; mkEvalable form - -(DEFUN |dbMkEvalable| (|form|) - (PROG (|op| |kind|) - (RETURN - (PROGN - (SPADLET |op| (CAR |form|)) - (SPADLET |kind| (GETDATABASE |op| 'CONSTRUCTORKIND)) - (COND - ((BOOT-EQUAL |kind| '|category|) |form|) - ('T (|mkEvalable| |form|))))))) - -;topLevelInterpEval x == -; $ProcessInteractiveValue: fluid := true -; $noEvalTypeMsg: fluid := true -; processInteractive(x,nil) - -(DEFUN |topLevelInterpEval| (|x|) - (PROG (|$ProcessInteractiveValue| |$noEvalTypeMsg|) - (DECLARE (SPECIAL |$ProcessInteractiveValue| |$noEvalTypeMsg|)) - (RETURN - (PROGN - (SPADLET |$ProcessInteractiveValue| 'T) - (SPADLET |$noEvalTypeMsg| 'T) - (|processInteractive| |x| NIL))))) - -;kisValidType typeForm == -; $ProcessInteractiveValue: fluid := true -; $noEvalTypeMsg: fluid := true -; CATCH('SPAD__READER, processInteractive(typeForm,nil)) -; is [[h,:.],:t] and MEMBER(h,'(Domain SubDomain)) => -; kCheckArgumentNumbers t and t -; false - -(DEFUN |kisValidType| (|typeForm|) - (PROG (|$ProcessInteractiveValue| |$noEvalTypeMsg| |ISTMP#1| - |ISTMP#2| |h| |t|) - (DECLARE (SPECIAL |$ProcessInteractiveValue| |$noEvalTypeMsg|)) - (RETURN - (PROGN - (SPADLET |$ProcessInteractiveValue| 'T) - (SPADLET |$noEvalTypeMsg| 'T) - (COND - ((AND (PROGN - (SPADLET |ISTMP#1| - (CATCH 'SPAD_READER - (|processInteractive| |typeForm| NIL))) - (AND (CONSP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (PROGN - (SPADLET |h| (QCAR |ISTMP#2|)) - 'T))) - (PROGN (SPADLET |t| (QCDR |ISTMP#1|)) 'T))) - (|member| |h| '(|Domain| |SubDomain|))) - (AND (|kCheckArgumentNumbers| |t|) |t|)) - ('T NIL)))))) - -;kCheckArgumentNumbers t == -; [conname,:args] := t -; cosig := KDR GETDATABASE(conname,'COSIG) -; #cosig ^= #args => false -; and/[foo for domain? in cosig for x in args] where foo == -; domain? => kCheckArgumentNumbers x -; true - -(DEFUN |kCheckArgumentNumbers| (|t|) - (PROG (|conname| |args| |cosig|) - (RETURN - (SEQ (PROGN - (SPADLET |conname| (CAR |t|)) - (SPADLET |args| (CDR |t|)) - (SPADLET |cosig| (KDR (GETDATABASE |conname| 'COSIG))) - (COND - ((NEQUAL (|#| |cosig|) (|#| |args|)) NIL) - ('T - (PROG (G166973) - (SPADLET G166973 'T) - (RETURN - (DO ((G166980 NIL (NULL G166973)) - (G166981 |cosig| (CDR G166981)) - (|domain?| NIL) - (G166982 |args| (CDR G166982)) (|x| NIL)) - ((OR G166980 (ATOM G166981) - (PROGN - (SETQ |domain?| (CAR G166981)) - NIL) - (ATOM G166982) - (PROGN (SETQ |x| (CAR G166982)) NIL)) - G166973) - (SEQ (EXIT (SETQ G166973 - (AND G166973 - (COND - (|domain?| - (|kCheckArgumentNumbers| - |x|)) - ('T 'T)))))))))))))))) - -;parseNoMacroFromString(s) == -; s := next(function ncloopParse, -; next(function lineoftoks,incString s)) -; StreamNull s => nil -; pf2Sex first rest first s - -(DEFUN |parseNoMacroFromString| (|s|) - (PROGN - (SPADLET |s| - (|next| (|function| |ncloopParse|) - (|next| (|function| |lineoftoks|) - (|incString| |s|)))) - (COND - ((|StreamNull| |s|) NIL) - ('T (|pf2Sex| (CAR (CDR (CAR |s|)))))))) - -; -;mkConform(kind,name,argString) == -; kind ^= '"default package" => -; form := STRCONC(name,argString) -; parse := parseNoMacroFromString form -; null parse => -; sayBrightlyNT '"Won't parse: " -; pp form -; systemError '"Keywords in argument list?" -; ATOM parse => [parse] -; parse -; [INTERN name,:rest ncParseFromString STRCONC(char 'd,argString)] --& case - -(DEFUN |mkConform| (|kind| |name| |argString|) - (PROG (|form| |parse|) - (RETURN - (COND - ((NEQUAL |kind| "default package") - (SPADLET |form| (STRCONC |name| |argString|)) - (SPADLET |parse| (|parseNoMacroFromString| |form|)) - (COND - ((NULL |parse|) - (|sayBrightlyNT| "Won't parse: ") - (|pp| |form|) - (|systemError| "Keywords in argument list?")) - ((ATOM |parse|) (CONS |parse| NIL)) - ('T |parse|))) - ('T - (CONS (INTERN |name|) - (CDR (|ncParseFromString| - (STRCONC (|char| '|d|) |argString|))))))))) - -;--======================================================================= -;-- Operation Page for a Domain Form from Scratch -;--======================================================================= -;conOpPage(htPage,conform) == -; updown := dbCompositeWithMap htPage -; updown = '"DOWN" => -; domname := htpProperty(htPage,'domname) -; conOpPage1(dbExtractUnderlyingDomain domname,[['updomain,:domname]]) -; domname := htpProperty(htPage,'updomain) -; conOpPage1(domname,nil) - -(DEFUN |conOpPage| (|htPage| |conform|) - (declare (ignore |conform|)) - (PROG (|updown| |domname|) - (RETURN - (PROGN - (SPADLET |updown| (|dbCompositeWithMap| |htPage|)) - (COND - ((BOOT-EQUAL |updown| "DOWN") - (SPADLET |domname| (|htpProperty| |htPage| '|domname|)) - (|conOpPage1| (|dbExtractUnderlyingDomain| |domname|) - (CONS (CONS '|updomain| |domname|) NIL))) - ('T (SPADLET |domname| (|htpProperty| |htPage| '|updomain|)) - (|conOpPage1| |domname| NIL))))))) - -;dbCompositeWithMap htPage == -; htpProperty(htPage,'updomain) => '"UP" -; domain := htpProperty(htPage,'domname) -; null domain => false -; opAlist := htpProperty(htPage,'opAlist) -;--not LASSOC('map,opAlist) => false -; dbExtractUnderlyingDomain htpProperty(htPage,'domname) => '"DOWN" -; false - -(DEFUN |dbCompositeWithMap| (|htPage|) - (PROG (|domain| |opAlist|) - (RETURN - (COND - ((|htpProperty| |htPage| '|updomain|) "UP") - ('T (SPADLET |domain| (|htpProperty| |htPage| '|domname|)) - (COND - ((NULL |domain|) NIL) - ('T (SPADLET |opAlist| (|htpProperty| |htPage| '|opAlist|)) - (COND - ((|dbExtractUnderlyingDomain| - (|htpProperty| |htPage| '|domname|)) - "DOWN") - ('T NIL))))))))) - -;dbExtractUnderlyingDomain domain == or/[x for x in KDR domain | isValidType x] - -(DEFUN |dbExtractUnderlyingDomain| (|domain|) - (PROG () - (RETURN - (SEQ (PROG (G167026) - (SPADLET G167026 NIL) - (RETURN - (DO ((G167033 NIL G167026) - (G167034 (KDR |domain|) (CDR G167034)) - (|x| NIL)) - ((OR G167033 (ATOM G167034) - (PROGN (SETQ |x| (CAR G167034)) NIL)) - G167026) - (SEQ (EXIT (COND - ((|isValidType| |x|) - (SETQ G167026 (OR G167026 |x|))))))))))))) - -;--conform is atomic if no parameters, otherwise must be valid domain form -;conOpPage1(conform,:options) == -;--constructors Cname\#\E\sig \args \abb \comments (C is C, D, P, X) -; bindingsAlist := IFCAR options -; conname := opOf conform -; MEMQ(conname,$Primitives) => -; dbSpecialOperations conname -; domname := --> !!note!! <-- -; null atom conform => conform -; nil -; line := conPageFastPath conname -; [kind,name,nargs,xflag,sig,args,abbrev,comments]:=parts:= dbXParts(line,7,1) -; isFile := null kind -; kind := kind or '"package" -; RPLACA(parts,kind) -; constring := STRCONC(name,args) -; conform := mkConform(kind,name,args) -; capitalKind := capitalize kind -; signature := ncParseFromString sig -; sourceFileName := dbSourceFile INTERN name -; emString := ['"{\sf ",constring,'"}"] -; heading := [capitalKind,'" ",:emString] -; if not isExposedConstructor conname then heading := ['"Unexposed ",:heading] -; page := htInitPage(heading,nil) -; htpSetProperty(page,'isFile,true) -; htpSetProperty(page,'fromConOpPage1,true) -; htpSetProperty(page,'parts,parts) -; htpSetProperty(page,'heading,heading) -; htpSetProperty(page,'kind,kind) -; htpSetProperty(page,'domname,domname) --> !!note!! <-- -; htpSetProperty(page,'conform,conform) -; htpSetProperty(page,'signature,signature) -; if selectedOperation := LASSOC('selectedOperation,IFCDR options) then -; htpSetProperty(page,'selectedOperation,selectedOperation) -; for [a,:b] in bindingsAlist repeat htpSetProperty(page,a,b) -; koPage(page,'"operation") - -(DEFUN |conOpPage1| (&REST G167111 &AUX |options| |conform|) - (DSETQ (|conform| . |options|) G167111) - (PROG (|bindingsAlist| |conname| |domname| |line| |parts| |name| - |nargs| |xflag| |sig| |args| |abbrev| |comments| |isFile| - |kind| |constring| |capitalKind| |signature| - |sourceFileName| |emString| |heading| |page| - |selectedOperation| |a| |b|) - (declare (special |$Primitives|)) - (RETURN - (SEQ (PROGN - (SPADLET |bindingsAlist| (IFCAR |options|)) - (SPADLET |conname| (|opOf| |conform|)) - (COND - ((member |conname| |$Primitives|) - (|dbSpecialOperations| |conname|)) - ('T - (SPADLET |domname| - (COND - ((NULL (ATOM |conform|)) |conform|) - ('T NIL))) - (SPADLET |line| (|conPageFastPath| |conname|)) - (SPADLET |parts| (|dbXParts| |line| 7 1)) - (SPADLET |kind| (CAR |parts|)) - (SPADLET |name| (CADR |parts|)) - (SPADLET |nargs| (CADDR |parts|)) - (SPADLET |xflag| (CADDDR |parts|)) - (SPADLET |sig| (CAR (CDDDDR |parts|))) - (SPADLET |args| (CADR (CDDDDR |parts|))) - (SPADLET |abbrev| (CADDR (CDDDDR |parts|))) - (SPADLET |comments| (CADDDR (CDDDDR |parts|))) - (SPADLET |isFile| (NULL |kind|)) - (SPADLET |kind| (OR |kind| "package")) - (RPLACA |parts| |kind|) - (SPADLET |constring| (STRCONC |name| |args|)) - (SPADLET |conform| (|mkConform| |kind| |name| |args|)) - (SPADLET |capitalKind| (|capitalize| |kind|)) - (SPADLET |signature| (|ncParseFromString| |sig|)) - (SPADLET |sourceFileName| - (|dbSourceFile| (INTERN |name|))) - (SPADLET |emString| - (CONS "{\\sf " - (CONS |constring| - (CONS "}" NIL)))) - (SPADLET |heading| - (CONS |capitalKind| - (CONS " " |emString|))) - (COND - ((NULL (|isExposedConstructor| |conname|)) - (SPADLET |heading| - (CONS "Unexposed " |heading|)))) - (SPADLET |page| (|htInitPage| |heading| NIL)) - (|htpSetProperty| |page| '|isFile| 'T) - (|htpSetProperty| |page| '|fromConOpPage1| 'T) - (|htpSetProperty| |page| '|parts| |parts|) - (|htpSetProperty| |page| '|heading| |heading|) - (|htpSetProperty| |page| '|kind| |kind|) - (|htpSetProperty| |page| '|domname| |domname|) - (|htpSetProperty| |page| '|conform| |conform|) - (|htpSetProperty| |page| '|signature| |signature|) - (COND - ((SPADLET |selectedOperation| - (LASSOC '|selectedOperation| - (IFCDR |options|))) - (|htpSetProperty| |page| '|selectedOperation| - |selectedOperation|))) - (DO ((G167074 |bindingsAlist| (CDR G167074)) - (G167065 NIL)) - ((OR (ATOM G167074) - (PROGN (SETQ G167065 (CAR G167074)) NIL) - (PROGN - (PROGN - (SPADLET |a| (CAR G167065)) - (SPADLET |b| (CDR G167065)) - G167065) - NIL)) - NIL) - (SEQ (EXIT (|htpSetProperty| |page| |a| |b|)))) - (|koPage| |page| "operation")))))))) - ;--======================================================================= ;-- Operation Page from Main Page ;--=======================================================================