diff --git a/books/bookvol9.pamphlet b/books/bookvol9.pamphlet index 9a3cf30..0ee6bf9 100644 --- a/books/bookvol9.pamphlet +++ b/books/bookvol9.pamphlet @@ -6199,6 +6199,312 @@ $\rightarrow$ \end{chunk} +\defun{compDefineCategory1}{compDefineCategory1} +\calls{compDefineCategory1}{compDefineCategory2} +\calls{compDefineCategory1}{makeCategoryPredicates} +\calls{compDefineCategory1}{compDefine1} +\calls{compDefineCategory1}{mkCategoryPackage} +\usesdollar{compDefineCategory1}{insideCategoryPackageIfTrue} +\usesdollar{compDefineCategory1}{EmptyMode} +\usesdollar{compDefineCategory1}{categoryPredicateList} +\usesdollar{compDefineCategory1}{lisplibCategory} +\usesdollar{compDefineCategory1}{bootStrapMode} +\begin{chunk}{defun compDefineCategory1} +(defun |compDefineCategory1| (df mode env prefix fal) + (let (|$insideCategoryPackageIfTrue| |$categoryPredicateList| form + sig sc cat body categoryCapsule d tmp1 tmp3) + (declare (special |$insideCategoryPackageIfTrue| |$EmptyMode| + |$categoryPredicateList| |$lisplibCategory| + |$bootStrapMode|)) + ;; a category is a DEF form with 4 parts: + ;; ((DEF (|BasicType|) ((|Category|)) (NIL) + ;; (|add| (CATEGORY |domain| (SIGNATURE = ((|Boolean|) $ $)) + ;; (SIGNATURE ~= ((|Boolean|) $ $))) + ;; (CAPSULE (DEF (~= |x| |y|) ((|Boolean|) $ $) (NIL NIL NIL) + ;; (IF (= |x| |y|) |false| |true|)))))) + (setq form (second df)) + (setq sig (third df)) + (setq sc (fourth df)) + (setq body (fifth df)) + (setq categoryCapsule + (when (and (pairp body) (eq (qcar body) '|add|) + (pairp (qcdr body)) (pairp (qcdr (qcdr body))) + (eq (qcdr (qcdr (qcdr body))) nil)) + (setq tmp1 (third body)) + (setq body (second body)) + tmp1)) + (setq tmp3 (|compDefineCategory2| form sig sc body mode env prefix fal)) + (setq d (first tmp3)) + (setq mode (second tmp3)) + (setq env (third tmp3)) + (when (and categoryCapsule (null |$bootStrapMode|)) + (setq |$insideCategoryPackageIfTrue| t) + (setq |$categoryPredicateList| + (|makeCategoryPredicates| form |$lisplibCategory|)) + (setq env (third + (|compDefine1| + (|mkCategoryPackage| form cat categoryCapsule) |$EmptyMode| env)))) + (list d mode env))) + +\end{chunk} + +\defun{makeCategoryPredicates}{makeCategoryPredicates} +\usesdollar{makeCategoryPredicates}{FormalMapVariableList} +\usesdollar{makeCategoryPredicates}{TriangleVariableList} +\usesdollar{makeCategoryPredicates}{mvl} +\usesdollar{makeCategoryPredicates}{tvl} +\begin{chunk}{defun makeCategoryPredicates} +(defun |makeCategoryPredicates| (form u) + (labels ( + (fn (u pl) + (declare (special |$tvl| |$mvl|)) + (cond + ((and (pairp u) (eq (qcar u) '|Join|) (pairp (qcdr u))) + (fn (car (reverse (qcdr u))) pl)) + ((and (pairp u) (eq (qcar u) '|has|)) + (|insert| (eqsubstlist |$mvl| |$tvl| u) pl)) + ((and (pairp u) (member (qcar u) '(signature attribute))) pl) + ((atom u) pl) + (t (fnl u pl)))) + (fnl (u pl) + (dolist (x u) (setq pl (fn x pl))) + pl)) + (declare (special |$FormalMapVariableList| |$mvl| |$tvl| + |$TriangleVariableList|)) + (setq |$tvl| (take (|#| (cdr form)) |$TriangleVariableList|)) + (setq |$mvl| (take (|#| (cdr form)) (cdr |$FormalMapVariableList|))) + (fn u nil))) + +\end{chunk} + +\defun{mkCategoryPackage}{mkCategoryPackage} +\calls{mkCategoryPackage}{strconc} +\calls{mkCategoryPackage}{pname} +\calls{mkCategoryPackage}{getdatabase} +\calls{mkCategoryPackage}{abbreviationsSpad2Cmd} +\calls{mkCategoryPackage}{JoinInner} +\calls{mkCategoryPackage}{assoc} +\calls{mkCategoryPackage}{sublislis} +\calls{mkCategoryPackage}{msubst} +\usesdollar{mkCategoryPackage}{options} +\usesdollar{mkCategoryPackage}{categoryPredicateList} +\usesdollar{mkCategoryPackage}{e} +\usesdollar{mkCategoryPackage}{FormalMapVariableList} +\begin{chunk}{defun mkCategoryPackage} +(defun |mkCategoryPackage| (form cat def) + (labels ( + (fn (x oplist) + (cond + ((atom x) oplist) + ((and (pairp x) (eq (qcar x) 'def) (pairp (qcdr x))) + (cons (second x) oplist)) + (t + (fn (cdr x) (fn (car x) oplist))))) + (gn (cat) + (cond + ((and (pairp cat) (eq (qcar cat) 'category)) (cddr cat)) + ((and (pairp cat) (eq (qcar cat) '|Join|)) (gn (|last| (qcdr cat)))) + (t nil)))) + (let (|$options| op argl packageName packageAbb nameForDollar packageArgl + capsuleDefAlist explicitCatPart catvec fullCatOpList op1 sig + catOpList packageCategory nils packageSig) + (declare (special |$options| |$categoryPredicateList| |$e| + |$FormalMapVariableList|)) + (setq op (car form)) + (setq argl (cdr form)) + (setq packageName (intern (strconc (pname op) "&"))) + (setq packageAbb (intern (strconc (getdatabase op 'abbreviation) "-"))) + (setq |$options| nil) + (|abbreviationsSpad2Cmd| (list '|domain| packageAbb packageName)) + (setq nameForDollar (car (setdifference '(s a b c d e f g h i) argl))) + (setq packageArgl (cons nameForDollar argl)) + (setq capsuleDefAlist (fn def nil)) + (setq explicitCatPart (gn cat)) + (setq catvec (|eval| (|mkEvalableCategoryForm| form))) + (setq fullCatOpList (elt (|JoinInner| (list catvec) |$e|) 1)) + (setq catOpList + (loop for x in fullCatOpList do + (setq op1 (caar x)) + (setq sig (cadar x)) + when (|assoc| op1 capsuleDefAlist) + collect (list 'signature op1 sig))) + (when catOpList + (setq packageCategory + (cons 'category + (cons '|domain| (sublislis argl |$FormalMapVariableList| catOpList)))) + (setq nils (loop for x in argl collect nil)) + (setq packageSig (cons packageCategory (cons form nils))) + (setq |$categoryPredicateList| + (msubst nameForDollar '$ |$categoryPredicateList|)) + (msubst nameForDollar '$ + (list 'def (cons packageName packageArgl) + packageSig (cons nil nils) def)))))) + +\end{chunk} + +\defun{compDefineCategory2}{compDefineCategory2} +\calls{compDefineCategory2}{addBinding} +\calls{compDefineCategory2}{getArgumentModeOrMoan} +\calls{compDefineCategory2}{giveFormalParametersValues} +\calls{compDefineCategory2}{take} +\calls{compDefineCategory2}{sublis} +\calls{compDefineCategory2}{compMakeDeclaration} +\calls{compDefineCategory2}{nequal} +\calls{compDefineCategory2}{opOf} +\calls{compDefineCategory2}{optFunctorBody} +\calls{compDefineCategory2}{compOrCroak} +\calls{compDefineCategory2}{mkConstructor} +\calls{compDefineCategory2}{compile} +\calls{compDefineCategory2}{lisplibWrite} +\calls{compDefineCategory2}{removeZeroOne} +\calls{compDefineCategory2}{mkq} +\calls{compDefineCategory2}{evalAndRwriteLispForm} +\calls{compDefineCategory2}{eval} +\calls{compDefineCategory2}{getParentsFor} +\calls{compDefineCategory2}{computeAncestorsOf} +\calls{compDefineCategory2}{constructor?} +\calls{compDefineCategory2}{augLisplibModemapsFromCategory} +\usesdollar{compDefineCategory2}{prefix} +\usesdollar{compDefineCategory2}{formalArgList} +\usesdollar{compDefineCategory2}{insideCategoryIfTrue} +\usesdollar{compDefineCategory2}{top-level} +\usesdollar{compDefineCategory2}{definition} +\usesdollar{compDefineCategory2}{form} +\usesdollar{compDefineCategory2}{op} +\usesdollar{compDefineCategory2}{extraParms} +\usesdollar{compDefineCategory2}{functionStats} +\usesdollar{compDefineCategory2}{functorStats} +\usesdollar{compDefineCategory2}{frontier} +\usesdollar{compDefineCategory2}{getDomainCode} +\usesdollar{compDefineCategory2}{addForm} +\usesdollar{compDefineCategory2}{lisplibAbbreviation} +\usesdollar{compDefineCategory2}{lisplibAncestors} +\usesdollar{compDefineCategory2}{lisplibCategory} +\usesdollar{compDefineCategory2}{FormalMapVariableList} +\usesdollar{compDefineCategory2}{lisplibParents} +\usesdollar{compDefineCategory2}{lisplibModemap} +\usesdollar{compDefineCategory2}{lisplibKind} +\usesdollar{compDefineCategory2}{lisplibForm} +\usesdollar{compDefineCategory2}{lisplib} +\usesdollar{compDefineCategory2}{domainShell} +\usesdollar{compDefineCategory2}{libFile} +\usesdollar{compDefineCategory2}{TriangleVariableList} +\begin{chunk}{defun compDefineCategory2} +(defun |compDefineCategory2| + (form signature specialCases body mode env |$prefix| |$formalArgList|) + (declare (special |$prefix| |$formalArgList|) (ignore specialCases)) + (let (|$insideCategoryIfTrue| $TOP_LEVEL |$definition| |$form| |$op| + |$extraParms| |$functionStats| |$functorStats| |$frontier| + |$getDomainCode| |$addForm| argl sargl aList + signaturep tmp1 opp formalBody formals + actuals g fun pairlis parSignature parForm + modemap formp) + (declare (special |$insideCategoryIfTrue| $top_level |$definition| + |$form| |$op| |$extraParms| |$functionStats| + |$functorStats| |$frontier| |$getDomainCode| + |$addForm| |$lisplibAbbreviation| + |$lisplibAncestors| |$lisplibCategory| + |$FormalMapVariableList| |$lisplibParents| + |$lisplibModemap| |$lisplibKind| |$lisplibForm| + $lisplib |$domainShell| |$libFile| + |$TriangleVariableList|)) +; 1. bind global variables + (setq |$insideCategoryIfTrue| t) + (setq $top_level nil) + (setq |$definition| nil) + (setq |$form| nil) + (setq |$op| nil) + (setq |$extraParms| nil) +; 1.1 augment e to add declaration $: