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 $:
+ (setq |$definition| form) + (setq |$op| (car |$definition|)) + (setq argl (cdr |$definition|)) + (setq env (|addBinding| '$ (list (cons '|mode| |$definition|)) env)) +; 2. obtain signature + (setq signaturep + (cons (car signature) + (loop for a in argl + collect (|getArgumentModeOrMoan| a |$definition| env)))) + (setq env (|giveFormalParametersValues| argl env)) +; 3. replace arguments by $1,..., substitute into body, +; and introduce declarations into environment + (setq sargl (take (|#| argl) |$TriangleVariableList|)) + (setq |$form| (cons |$op| sargl)) + (setq |$functorForm| |$form|) + (setq |$formalArgList| (append sargl |$formalArgList|)) + (setq aList (loop for a in argl for sa in sargl collect (cons a sa))) + (setq formalBody (sublis aList body)) + (setq signaturep (sublis aList signaturep)) + ; Begin lines for category default definitions + (setq |$functionStats| (list 0 0)) + (setq |$functorStats| (list 0 0)) + (setq |$frontier| 0) + (setq |$getDomainCode| nil) + (setq |$addForm| nil) + (loop for x in sargl for r in (rest signaturep) + do (setq env (third (|compMakeDeclaration| (list '|:| x r) mode env)))) +; 4. compile body in environment of %type declarations for arguments + (setq opp |$op|) + (when (and (nequal (|opOf| formalBody) '|Join|) + (nequal (|opOf| formalBody) '|mkCategory|)) + (setq formalBody (list '|Join| formalBody))) + (setq body + (|optFunctorBody| (car (|compOrCroak| formalBody (car signaturep) env)))) + (when |$extraParms| + (setq actuals nil) + (setq formals nil) + (loop for u in |$extraParms| do + (setq formals (cons (car u) formals)) + (setq actuals (cons (mkq (cdr u)) actuals))) + (setq body + (list '|sublisV| (list 'pair (list 'quote formals) (cons 'list actuals)) + body))) +; always subst for args after extraparms + (when argl + (setq body + (list '|sublisV| + (list 'pair + (list 'quote sargl) + (cons 'list (loop for u in sargl collect (list '|devaluate| u)))) + body))) + (setq body + (list 'prog1 (list 'let (setq g (gensym)) body) + (list 'setelt g 0 (|mkConstructor| |$form|)))) + (setq fun (|compile| (list opp (list 'lam sargl body)))) +; 5. give operator a 'modemap property + (setq pairlis + (loop for a in argl for v in |$FormalMapVariableList| + collect (cons a v))) + (setq parSignature (sublis pairlis signaturep)) + (setq parForm (sublis pairlis form)) + (|lisplibWrite| "compilerInfo" + (|removeZeroOne| + (list 'setq '|$CategoryFrame| + (list '|put| (list 'quote opp) ''|isCategory| t + (list '|addModemap| (mkq opp) (mkq parForm) + (mkq parSignature) t (mkq fun) '|$CategoryFrame|)))) + |$libFile|) + (unless sargl + (|evalAndRwriteLispForm| 'niladic + (list 'makeprop (list 'quote opp) ''niladic t))) +;; 6 put modemaps into InteractiveModemapFrame + (setq |$domainShell| (|eval| (cons opp (mapcar 'mkq sargl)))) + (setq |$lisplibCategory| formalBody) + (when $lisplib + (setq |$lisplibForm| form) + (setq |$lisplibKind| '|category|) + (setq modemap (list (cons parForm parSignature) (list t opp))) + (setq |$lisplibModemap| modemap) + (setq |$lisplibParents| + (|getParentsFor| |$op| |$FormalMapVariableList| |$lisplibCategory|)) + (setq |$lisplibAncestors| (|computeAncestorsOf| |$form| nil)) + (setq |$lisplibAbbreviation| (|constructor?| |$op|)) + (setq formp (cons opp sargl)) + (|augLisplibModemapsFromCategory| formp formalBody signaturep)) + (list fun '(|Category|) env))) + +\end{chunk} + \section{Indirect called comp routines} In the {\bf compExpression} function there is the code: \begin{verbatim} @@ -15333,6 +15639,7 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun compCase1} \getchunk{defun compCat} \getchunk{defun compCategory} +\getchunk{defun compDefineCategory1} \getchunk{defun compCoerce} \getchunk{defun compCoerce1} \getchunk{defun compColon} @@ -15344,6 +15651,7 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun compDefine} \getchunk{defun compDefine1} \getchunk{defun compDefineAddSignature} +\getchunk{defun compDefineCategory2} \getchunk{defun compElt} \getchunk{defun compExit} \getchunk{defun compExpression} @@ -15454,6 +15762,7 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun macroExpand} \getchunk{defun macroExpandInPlace} \getchunk{defun macroExpandList} +\getchunk{defun makeCategoryPredicates} \getchunk{defun makeSimplePredicateOrNil} \getchunk{defun make-string-adjustable} \getchunk{defun make-symbol-of} @@ -15463,6 +15772,7 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun match-string} \getchunk{defun match-token} \getchunk{defun meta-syntax-error} +\getchunk{defun mkCategoryPackage} \getchunk{defun modifyModeStack} \getchunk{defun ncINTERPFILE} diff --git a/changelog b/changelog index 830251b..f67a158 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,6 @@ +20110517 tpd src/axiom-website/patches.html 20110517.01.tpd.patch +20110517 tpd src/interp/define.lisp treeshake compiler +20110517 tpd books/bookvol9 treeshake compiler 20110516 tpd src/axiom-website/patches.html 20110516.01.tpd.patch 20110516 tpd src/interp/define.lisp treeshake compiler 20110516 tpd books/bookvol9 treeshake compiler diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index b85195a..ba85357 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -3478,5 +3478,7 @@ books/bookvol9 normalize argument names to top level functions
books/bookvol9 treeshake compiler
20110516.01.tpd.patch books/bookvol9 treeshake compiler
+20110517.01.tpd.patch +books/bookvol9 treeshake compiler
diff --git a/src/interp/define.lisp.pamphlet b/src/interp/define.lisp.pamphlet index d1537eb..0bcad45 100644 --- a/src/interp/define.lisp.pamphlet +++ b/src/interp/define.lisp.pamphlet @@ -15,627 +15,6 @@ ;--% FUNCTIONS WHICH MUNCH ON == STATEMENTS ; -;compDefineCategory1(df is ['DEF,form,sig,sc,body],m,e,prefix,fal) == -; categoryCapsule := -;--+ -; body is ['add,cat,capsule] => -; body := cat -; capsule -; nil -; [d,m,e]:= compDefineCategory2(form,sig,sc,body,m,e,prefix,fal) -;--+ next two lines -; if categoryCapsule and not $bootStrapMode then [.,.,e] := -; $insideCategoryPackageIfTrue: local := true --see NRTmakeSlot1 -;--> -; $categoryPredicateList: local := -; makeCategoryPredicates(form,$lisplibCategory) -; compDefine1(mkCategoryPackage(form,cat,categoryCapsule),$EmptyMode,e) -; [d,m,e] - -(DEFUN |compDefineCategory1| (|df| |m| |e| |prefix| |fal|) - (PROG (|$insideCategoryPackageIfTrue| |$categoryPredicateList| |form| - |sig| |sc| |ISTMP#1| |cat| |ISTMP#2| |capsule| |body| - |categoryCapsule| |d| |LETTMP#1|) - (DECLARE (SPECIAL |$insideCategoryPackageIfTrue| |$EmptyMode| - |$categoryPredicateList| |$lisplibCategory| - |$bootStrapMode|)) - (RETURN - (PROGN - (SPADLET |form| (CADR |df|)) - (SPADLET |sig| (CADDR |df|)) - (SPADLET |sc| (CADDDR |df|)) - (SPADLET |body| (CAR (CDDDDR |df|))) - (SPADLET |categoryCapsule| - (COND - ((AND (PAIRP |body|) (EQ (QCAR |body|) '|add|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |body|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |cat| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |capsule| - (QCAR |ISTMP#2|)) - 'T)))))) - (SPADLET |body| |cat|) |capsule|) - ('T NIL))) - (SPADLET |LETTMP#1| - (|compDefineCategory2| |form| |sig| |sc| |body| |m| - |e| |prefix| |fal|)) - (SPADLET |d| (CAR |LETTMP#1|)) - (SPADLET |m| (CADR |LETTMP#1|)) - (SPADLET |e| (CADDR |LETTMP#1|)) - (COND - ((AND |categoryCapsule| (NULL |$bootStrapMode|)) - (SPADLET |LETTMP#1| - (PROGN - (SPADLET |$insideCategoryPackageIfTrue| 'T) - (SPADLET |$categoryPredicateList| - (|makeCategoryPredicates| |form| - |$lisplibCategory|)) - (|compDefine1| - (|mkCategoryPackage| |form| |cat| - |categoryCapsule|) - |$EmptyMode| |e|))) - (SPADLET |e| (CADDR |LETTMP#1|)) |LETTMP#1|)) - (CONS |d| (CONS |m| (CONS |e| NIL))))))) - -;makeCategoryPredicates(form,u) == -; $tvl := TAKE(#rest form,$TriangleVariableList) -; $mvl := TAKE(#rest form,rest $FormalMapVariableList) -; fn(u,nil) where -; fn(u,pl) == -; u is ['Join,:.,a] => fn(a,pl) -; u is ['has,:.] => insert(EQSUBSTLIST($mvl,$tvl,u),pl) -; u is [op,:.] and MEMQ(op,'(SIGNATURE ATTRIBUTE)) => pl -; atom u => pl -; fnl(u,pl) -; fnl(u,pl) == -; for x in u repeat pl := fn(x,pl) -; pl - -(DEFUN |makeCategoryPredicates,fnl| (|u| |pl|) - (SEQ (DO ((G166465 |u| (CDR G166465)) (|x| NIL)) - ((OR (ATOM G166465) - (PROGN (SETQ |x| (CAR G166465)) NIL)) - NIL) - (SEQ (EXIT (SPADLET |pl| - (|makeCategoryPredicates,fn| |x| |pl|))))) - (EXIT |pl|))) - -(DEFUN |makeCategoryPredicates,fn| (|u| |pl|) - (PROG (|ISTMP#1| |ISTMP#2| |a| |op|) - (declare (special |$tvl| |$mvl|)) - (RETURN - (SEQ (IF (AND (PAIRP |u|) (EQ (QCAR |u|) '|Join|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |u|)) - (AND (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| - (REVERSE |ISTMP#1|)) - 'T)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#2|)) - 'T))))) - (EXIT (|makeCategoryPredicates,fn| |a| |pl|))) - (IF (AND (PAIRP |u|) (EQ (QCAR |u|) '|has|)) - (EXIT (|insert| (EQSUBSTLIST |$mvl| |$tvl| |u|) |pl|))) - (IF (AND (AND (PAIRP |u|) - (PROGN (SPADLET |op| (QCAR |u|)) 'T)) - (member |op| '(SIGNATURE ATTRIBUTE))) - (EXIT |pl|)) - (IF (ATOM |u|) (EXIT |pl|)) - (EXIT (|makeCategoryPredicates,fnl| |u| |pl|)))))) - -(DEFUN |makeCategoryPredicates| (|form| |u|) - (declare (special |$FormalMapVariableList| |$mvl| |$tvl| - |$TriangleVariableList|)) - (PROGN - (SPADLET |$tvl| (TAKE (|#| (CDR |form|)) |$TriangleVariableList|)) - (SPADLET |$mvl| - (TAKE (|#| (CDR |form|)) (CDR |$FormalMapVariableList|))) - (|makeCategoryPredicates,fn| |u| NIL))) - -;--+ the following function -;mkCategoryPackage(form is [op,:argl],cat,def) == -; packageName:= INTERN(STRCONC(PNAME op,'"&")) -; packageAbb := INTERN(STRCONC(GETDATABASE(op,'ABBREVIATION),'"-")) -; $options:local := [] -; -- This stops the next line from becoming confused -; abbreviationsSpad2Cmd ['domain,packageAbb,packageName] -; -- This is a little odd, but the parser insists on calling -; -- domains, rather than packages -; nameForDollar := first SETDIFFERENCE('(S A B C D E F G H I),argl) -; packageArgl := [nameForDollar,:argl] -; capsuleDefAlist := fn(def,nil) where fn(x,oplist) == -; atom x => oplist -; x is ['DEF,y,:.] => [y,:oplist] -; fn(rest x,fn(first x,oplist)) -; explicitCatPart := gn cat where gn cat == -; cat is ['CATEGORY,:.] => rest rest cat -; cat is ['Join,:u] => gn last u -; nil -; catvec := eval mkEvalableCategoryForm form -; fullCatOpList:=JoinInner([catvec],$e).1 -; catOpList := -; --note: this gets too many modemaps in general -; -- this is cut down in NRTmakeSlot1 -; [['SIGNATURE,op1,sig] for [[op1,sig],:.] in fullCatOpList -; --above line calls the category constructor just compiled -; | ASSOC(op1,capsuleDefAlist)] -; null catOpList => nil -; packageCategory := ['CATEGORY,'domain, -; :SUBLISLIS(argl,$FormalMapVariableList,catOpList)] -; nils:= [nil for x in argl] -; packageSig := [packageCategory,form,:nils] -; $categoryPredicateList := SUBST(nameForDollar,'$,$categoryPredicateList) -; SUBST(nameForDollar,'$, -; ['DEF,[packageName,:packageArgl],packageSig,[nil,:nils],def]) - -(DEFUN |mkCategoryPackage,fn| (|x| |oplist|) - (PROG (|ISTMP#1| |y|) - (RETURN - (SEQ (IF (ATOM |x|) (EXIT |oplist|)) - (IF (AND (PAIRP |x|) (EQ (QCAR |x|) 'DEF) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN (SPADLET |y| (QCAR |ISTMP#1|)) 'T)))) - (EXIT (CONS |y| |oplist|))) - (EXIT (|mkCategoryPackage,fn| (CDR |x|) - (|mkCategoryPackage,fn| (CAR |x|) |oplist|))))))) - -(DEFUN |mkCategoryPackage,gn| (|cat|) - (PROG (|u|) - (RETURN - (SEQ (IF (AND (PAIRP |cat|) (EQ (QCAR |cat|) 'CATEGORY)) - (EXIT (CDR (CDR |cat|)))) - (IF (AND (PAIRP |cat|) (EQ (QCAR |cat|) '|Join|) - (PROGN (SPADLET |u| (QCDR |cat|)) 'T)) - (EXIT (|mkCategoryPackage,gn| (|last| |u|)))) - (EXIT NIL))))) - -(DEFUN |mkCategoryPackage| (|form| |cat| |def|) - (PROG (|$options| |op| |argl| |packageName| |packageAbb| - |nameForDollar| |packageArgl| |capsuleDefAlist| - |explicitCatPart| |catvec| |fullCatOpList| |op1| |sig| - |catOpList| |packageCategory| |nils| |packageSig|) - (DECLARE (SPECIAL |$options| |$categoryPredicateList| |$e| |$options| - |$FormalMapVariableList|)) - (RETURN - (SEQ (PROGN - (SPADLET |op| (CAR |form|)) - (SPADLET |argl| (CDR |form|)) - (SPADLET |packageName| - (INTERN (STRCONC (PNAME |op|) "&"))) - (SPADLET |packageAbb| - (INTERN (STRCONC (GETDATABASE |op| 'ABBREVIATION) - "-"))) - (SPADLET |$options| NIL) - (|abbreviationsSpad2Cmd| - (CONS '|domain| - (CONS |packageAbb| (CONS |packageName| NIL)))) - (SPADLET |nameForDollar| - (CAR (SETDIFFERENCE '(S A B C D E F G H I) - |argl|))) - (SPADLET |packageArgl| (CONS |nameForDollar| |argl|)) - (SPADLET |capsuleDefAlist| - (|mkCategoryPackage,fn| |def| NIL)) - (SPADLET |explicitCatPart| (|mkCategoryPackage,gn| |cat|)) - (SPADLET |catvec| - (|eval| (|mkEvalableCategoryForm| |form|))) - (SPADLET |fullCatOpList| - (ELT (|JoinInner| (CONS |catvec| NIL) |$e|) 1)) - (SPADLET |catOpList| - (PROG (G166528) - (SPADLET G166528 NIL) - (RETURN - (DO ((G166535 |fullCatOpList| - (CDR G166535)) - (G166506 NIL)) - ((OR (ATOM G166535) - (PROGN - (SETQ G166506 (CAR G166535)) - NIL) - (PROGN - (PROGN - (SPADLET |op1| (CAAR G166506)) - (SPADLET |sig| - (CADAR G166506)) - G166506) - NIL)) - (NREVERSE0 G166528)) - (SEQ (EXIT (COND - ((|assoc| |op1| - |capsuleDefAlist|) - (SETQ G166528 - (CONS - (CONS 'SIGNATURE - (CONS |op1| - (CONS |sig| NIL))) - G166528)))))))))) - (COND - ((NULL |catOpList|) NIL) - ('T - (SPADLET |packageCategory| - (CONS 'CATEGORY - (CONS '|domain| - (SUBLISLIS |argl| - |$FormalMapVariableList| - |catOpList|)))) - (SPADLET |nils| - (PROG (G166546) - (SPADLET G166546 NIL) - (RETURN - (DO ((G166551 |argl| (CDR G166551)) - (|x| NIL)) - ((OR (ATOM G166551) - (PROGN - (SETQ |x| (CAR G166551)) - NIL)) - (NREVERSE0 G166546)) - (SEQ (EXIT - (SETQ G166546 - (CONS NIL G166546)))))))) - (SPADLET |packageSig| - (CONS |packageCategory| (CONS |form| |nils|))) - (SPADLET |$categoryPredicateList| - (MSUBST |nameForDollar| '$ - |$categoryPredicateList|)) - (MSUBST |nameForDollar| '$ - (CONS 'DEF - (CONS (CONS |packageName| |packageArgl|) - (CONS |packageSig| - (CONS (CONS NIL |nils|) - (CONS |def| NIL))))))))))))) - -;compDefineCategory2(form,signature,specialCases,body,m,e, -; $prefix,$formalArgList) == -; --1. bind global variables -; $insideCategoryIfTrue: local:= true -; $TOP__LEVEL: local := nil -; $definition: local := nil -; --used by DomainSubstitutionFunction -; $form: local := nil -; $op: local := nil -; $extraParms: local := nil -; --Set in DomainSubstitutionFunction, used further down -;-- 1.1 augment e to add declaration $: -; [$op,:argl]:= $definition:= form -; e:= addBinding("$",[['mode,:$definition]],e) -; -;-- 2. obtain signature -; signature':= -; [first signature,:[getArgumentModeOrMoan(a,$definition,e) for a in argl]] -; e:= giveFormalParametersValues(argl,e) -; -;-- 3. replace arguments by $1,..., substitute into body, -;-- and introduce declarations into environment -; sargl:= TAKE(# argl, $TriangleVariableList) -; $functorForm:= $form:= [$op,:sargl] -; $formalArgList:= [:sargl,:$formalArgList] -; aList:= [[a,:sa] for a in argl for sa in sargl] -; formalBody:= SUBLIS(aList,body) -; signature' := SUBLIS(aList,signature') -;--Begin lines for category default definitions -; $functionStats: local:= [0,0] -; $functorStats: local:= [0,0] -; $frontier: local := 0 -; $getDomainCode: local := nil -; $addForm: local:= nil -; for x in sargl for t in rest signature' repeat -; [.,.,e]:= compMakeDeclaration([":",x,t],m,e) -; -;-- 4. compile body in environment of %type declarations for arguments -; op':= $op -; -- following line causes cats with no with or Join to be fresh copies -; if opOf(formalBody)^='Join and opOf(formalBody)^='mkCategory then -; formalBody := ['Join, formalBody] -; body:= optFunctorBody (compOrCroak(formalBody,signature'.target,e)).expr -; if $extraParms then -; formals:=actuals:=nil -; for u in $extraParms repeat -; formals:=[CAR u,:formals] -; actuals:=[MKQ CDR u,:actuals] -; body := ['sublisV,['PAIR,['QUOTE,formals],['LIST,:actuals]],body] -; if argl then body:= -- always subst for args after extraparms -; ['sublisV,['PAIR,['QUOTE,sargl],['LIST,: -; [['devaluate,u] for u in sargl]]],body] -; body:= -; ['PROG1,['LET,g:= GENSYM(),body],['SETELT,g,0,mkConstructor $form]] -; fun:= compile [op',['LAM,sargl,body]] -; -;-- 5. give operator a 'modemap property -; pairlis:= [[a,:v] for a in argl for v in $FormalMapVariableList] -; parSignature:= SUBLIS(pairlis,signature') -; parForm:= SUBLIS(pairlis,form) -; lisplibWrite('"compilerInfo", -; removeZeroOne ['SETQ,'$CategoryFrame, -; ['put,['QUOTE,op'],' -; (QUOTE isCategory),true,['addModemap,MKQ op',MKQ parForm, -; MKQ parSignature,true,MKQ fun,'$CategoryFrame]]],$libFile) -; --Equivalent to the following two lines, we hope -; if null sargl then -; evalAndRwriteLispForm('NILADIC, -; ['MAKEPROP,['QUOTE,op'],'(QUOTE NILADIC),true]) -; -;-- 6. put modemaps into InteractiveModemapFrame -; $domainShell := eval [op',:MAPCAR('MKQ,sargl)] -; $lisplibCategory:= formalBody -; if $LISPLIB then -; $lisplibForm:= form -; $lisplibKind:= 'category -; modemap:= [[parForm,:parSignature],[true,op']] -; $lisplibModemap:= modemap -; $lisplibParents := -; getParentsFor($op,$FormalMapVariableList,$lisplibCategory) -; $lisplibAncestors := computeAncestorsOf($form,nil) -; $lisplibAbbreviation := constructor? $op -; form':=[op',:sargl] -; augLisplibModemapsFromCategory(form',formalBody,signature') -; [fun,'(Category),e] - -(DEFUN |compDefineCategory2| (|form| |signature| |specialCases| |body| |m| |e| - |$prefix| |$formalArgList|) - (DECLARE (SPECIAL |$prefix| |$formalArgList|) (ignore |specialCases|)) - (PROG (|$insideCategoryIfTrue| $TOP_LEVEL |$definition| |$form| |$op| - |$extraParms| |$functionStats| |$functorStats| |$frontier| - |$getDomainCode| |$addForm| |argl| |sargl| |aList| - |signature'| |LETTMP#1| |op'| |formalBody| |formals| - |actuals| |g| |fun| |pairlis| |parSignature| |parForm| - |modemap| |form'|) - (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| )) - (RETURN - (SEQ (PROGN - (SPADLET |$insideCategoryIfTrue| 'T) - (SPADLET $TOP_LEVEL NIL) - (SPADLET |$definition| NIL) - (SPADLET |$form| NIL) - (SPADLET |$op| NIL) - (SPADLET |$extraParms| NIL) - (SPADLET |$definition| |form|) - (SPADLET |$op| (CAR |$definition|)) - (SPADLET |argl| (CDR |$definition|)) - (SPADLET |e| - (|addBinding| '$ - (CONS (CONS '|mode| |$definition|) NIL) |e|)) - (SPADLET |signature'| - (CONS (CAR |signature|) - (PROG (G166602) - (SPADLET G166602 NIL) - (RETURN - (DO ((G166607 |argl| (CDR G166607)) - (|a| NIL)) - ((OR (ATOM G166607) - (PROGN - (SETQ |a| (CAR G166607)) - NIL)) - (NREVERSE0 G166602)) - (SEQ (EXIT - (SETQ G166602 - (CONS - (|getArgumentModeOrMoan| |a| - |$definition| |e|) - G166602))))))))) - (SPADLET |e| (|giveFormalParametersValues| |argl| |e|)) - (SPADLET |sargl| - (TAKE (|#| |argl|) |$TriangleVariableList|)) - (SPADLET |$functorForm| - (SPADLET |$form| (CONS |$op| |sargl|))) - (SPADLET |$formalArgList| - (APPEND |sargl| |$formalArgList|)) - (SPADLET |aList| - (PROG (G166618) - (SPADLET G166618 NIL) - (RETURN - (DO ((G166624 |argl| (CDR G166624)) - (|a| NIL) - (G166625 |sargl| (CDR G166625)) - (|sa| NIL)) - ((OR (ATOM G166624) - (PROGN - (SETQ |a| (CAR G166624)) - NIL) - (ATOM G166625) - (PROGN - (SETQ |sa| (CAR G166625)) - NIL)) - (NREVERSE0 G166618)) - (SEQ (EXIT (SETQ G166618 - (CONS (CONS |a| |sa|) - G166618)))))))) - (SPADLET |formalBody| (SUBLIS |aList| |body|)) - (SPADLET |signature'| (SUBLIS |aList| |signature'|)) - (SPADLET |$functionStats| (CONS 0 (CONS 0 NIL))) - (SPADLET |$functorStats| (CONS 0 (CONS 0 NIL))) - (SPADLET |$frontier| 0) - (SPADLET |$getDomainCode| NIL) - (SPADLET |$addForm| NIL) - (DO ((G166641 |sargl| (CDR G166641)) (|x| NIL) - (G166642 (CDR |signature'|) (CDR G166642)) - (|t| NIL)) - ((OR (ATOM G166641) - (PROGN (SETQ |x| (CAR G166641)) NIL) - (ATOM G166642) - (PROGN (SETQ |t| (CAR G166642)) NIL)) - NIL) - (SEQ (EXIT (PROGN - (SPADLET |LETTMP#1| - (|compMakeDeclaration| - (CONS '|:| - (CONS |x| (CONS |t| NIL))) - |m| |e|)) - (SPADLET |e| (CADDR |LETTMP#1|)) - |LETTMP#1|)))) - (SPADLET |op'| |$op|) - (COND - ((AND (NEQUAL (|opOf| |formalBody|) '|Join|) - (NEQUAL (|opOf| |formalBody|) '|mkCategory|)) - (SPADLET |formalBody| - (CONS '|Join| (CONS |formalBody| NIL))))) - (SPADLET |body| - (|optFunctorBody| - (CAR (|compOrCroak| |formalBody| - (CAR |signature'|) |e|)))) - (COND - (|$extraParms| - (SPADLET |formals| (SPADLET |actuals| NIL)) - (DO ((G166656 |$extraParms| (CDR G166656)) - (|u| NIL)) - ((OR (ATOM G166656) - (PROGN (SETQ |u| (CAR G166656)) NIL)) - NIL) - (SEQ (EXIT (PROGN - (SPADLET |formals| - (CONS (CAR |u|) |formals|)) - (SPADLET |actuals| - (CONS (MKQ (CDR |u|)) - |actuals|)))))) - (SPADLET |body| - (CONS '|sublisV| - (CONS (CONS 'PAIR - (CONS - (CONS 'QUOTE - (CONS |formals| NIL)) - (CONS (CONS 'LIST |actuals|) - NIL))) - (CONS |body| NIL)))))) - (COND - (|argl| (SPADLET |body| - (CONS '|sublisV| - (CONS - (CONS 'PAIR - (CONS - (CONS 'QUOTE - (CONS |sargl| NIL)) - (CONS - (CONS 'LIST - (PROG (G166666) - (SPADLET G166666 NIL) - (RETURN - (DO - ((G166671 |sargl| - (CDR G166671)) - (|u| NIL)) - ((OR (ATOM G166671) - (PROGN - (SETQ |u| - (CAR G166671)) - NIL)) - (NREVERSE0 G166666)) - (SEQ - (EXIT - (SETQ G166666 - (CONS - (CONS '|devaluate| - (CONS |u| NIL)) - G166666)))))))) - NIL))) - (CONS |body| NIL)))))) - (SPADLET |body| - (CONS 'PROG1 - (CONS (CONS 'LET - (CONS (SPADLET |g| (GENSYM)) - (CONS |body| NIL))) - (CONS (CONS 'SETELT - (CONS |g| - (CONS 0 - (CONS - (|mkConstructor| |$form|) - NIL)))) - NIL)))) - (SPADLET |fun| - (|compile| - (CONS |op'| - (CONS (CONS 'LAM - (CONS |sargl| (CONS |body| NIL))) - NIL)))) - (SPADLET |pairlis| - (PROG (G166682) - (SPADLET G166682 NIL) - (RETURN - (DO ((G166688 |argl| (CDR G166688)) - (|a| NIL) - (G166689 |$FormalMapVariableList| - (CDR G166689)) - (|v| NIL)) - ((OR (ATOM G166688) - (PROGN - (SETQ |a| (CAR G166688)) - NIL) - (ATOM G166689) - (PROGN - (SETQ |v| (CAR G166689)) - NIL)) - (NREVERSE0 G166682)) - (SEQ (EXIT (SETQ G166682 - (CONS (CONS |a| |v|) G166682)))))))) - (SPADLET |parSignature| (SUBLIS |pairlis| |signature'|)) - (SPADLET |parForm| (SUBLIS |pairlis| |form|)) - (|lisplibWrite| "compilerInfo" - (|removeZeroOne| - (CONS 'SETQ - (CONS '|$CategoryFrame| - (CONS (CONS '|put| - (CONS - (CONS 'QUOTE (CONS |op'| NIL)) - (CONS ''|isCategory| - (CONS 'T - (CONS - (CONS '|addModemap| - (CONS (MKQ |op'|) - (CONS (MKQ |parForm|) - (CONS - (MKQ |parSignature|) - (CONS 'T - (CONS (MKQ |fun|) - (CONS - '|$CategoryFrame| - NIL))))))) - NIL))))) - NIL)))) - |$libFile|) - (COND - ((NULL |sargl|) - (|evalAndRwriteLispForm| 'NILADIC - (CONS 'MAKEPROP - (CONS (CONS 'QUOTE (CONS |op'| NIL)) - (CONS ''NILADIC (CONS 'T NIL))))))) - (SPADLET |$domainShell| - (|eval| (CONS |op'| (MAPCAR 'MKQ |sargl|)))) - (SPADLET |$lisplibCategory| |formalBody|) - (COND - ($LISPLIB (SPADLET |$lisplibForm| |form|) - (SPADLET |$lisplibKind| '|category|) - (SPADLET |modemap| - (CONS (CONS |parForm| |parSignature|) - (CONS (CONS 'T (CONS |op'| NIL)) NIL))) - (SPADLET |$lisplibModemap| |modemap|) - (SPADLET |$lisplibParents| - (|getParentsFor| |$op| - |$FormalMapVariableList| - |$lisplibCategory|)) - (SPADLET |$lisplibAncestors| - (|computeAncestorsOf| |$form| NIL)) - (SPADLET |$lisplibAbbreviation| - (|constructor?| |$op|)) - (SPADLET |form'| (CONS |op'| |sargl|)) - (|augLisplibModemapsFromCategory| |form'| - |formalBody| |signature'|))) - (CONS |fun| (CONS '(|Category|) (CONS |e| NIL)))))))) - ;mkConstructor form == ; atom form => ['devaluate,form] ; null rest form => ['QUOTE,[first form]]