diff --git a/books/bookvol9.pamphlet b/books/bookvol9.pamphlet index fe5d500..238f2ec 100644 --- a/books/bookvol9.pamphlet +++ b/books/bookvol9.pamphlet @@ -10289,6 +10289,84 @@ An angry JHD - August 15th., 1984 \end{chunk} +\defun{compCategoryItem}{compCategoryItem} +\calls{compCategoryItem}{pairp} +\calls{compCategoryItem}{qcar} +\calls{compCategoryItem}{qcdr} +\calls{compCategoryItem}{compCategoryItem} +\calls{compCategoryItem}{mkpf} +\refsdollar{compCategoryItem}{sigList} +\refsdollar{compCategoryItem}{atList} +\begin{chunk}{defun compCategoryItem} +(defun |compCategoryItem| (x predl) + (let (p e a tmp2 b tmp3 c predlp pred tmp1 y z op sig) + (declare (special |$sigList| |$atList|)) + (cond + ((null x) nil) +; 1. if x is a conditional expression, recurse; otherwise, form the predicate + ((and (pairp x) (eq (qcar x) 'cond) + (pairp (qcdr x)) (eq (qcdr (qcdr x)) nil) + (pairp (qcar (qcdr x))) + (pairp (qcdr (qcar (qcdr x)))) + (eq (qcdr (qcdr (qcar (qcdr x)))) nil)) + (setq p (qcar (qcar (qcdr x)))) + (setq e (qcar (qcdr (qcar (qcdr x))))) + (setq predlp (cons p predl)) + (cond + ((and (pairp e) (eq (qcar e) 'progn)) + (setq z (qcdr e)) + (dolist (y z) (|compCategoryItem| y predlp))) + (t (|compCategoryItem| e predlp)))) + ((and (pairp x) (eq (qcar x) 'if) (pairp (qcdr x)) + (pairp (qcdr (qcdr x))) (pairp (qcdr (qcdr (qcdr x)))) + (eq (qcdr (qcdr (qcdr (qcdr x)))) nil)) + (setq a (qcar (qcdr x))) + (setq b (qcar (qcdr (qcdr x)))) + (setq c (qcar (qcdr (qcdr (qcdr x))))) + (setq predlp (cons a predl)) + (unless (eq b '|noBranch|) + (cond + ((and (pairp b) (eq (qcar b) 'progn)) + (setq z (qcdr b)) + (dolist (y z) (|compCategoryItem| y predlp))) + (t (|compCategoryItem| b predlp)))) + (cond + ((eq c '|noBranch|) nil) + (t + (setq predlp (cons (list '|not| a) predl)) + (cond + ((and (pairp c) (eq (qcar c) 'progn)) + (setq z (qcdr c)) + (dolist (y z) (|compCategoryItem| y predlp))) + (t (|compCategoryItem| c predlp)))))) + (t + (setq pred (if predl (mkpf predl 'and) t)) + (cond +; 2. if attribute, push it and return + ((and (pairp x) (eq (qcar x) 'attribute) + (pairp (qcdr x)) (eq (qcdr (qcdr x)) nil)) + (setq y (qcar (qcdr x))) + (push (mkq (list y pred)) |$atList|)) +; 3. it may be a list, with PROGN as the CAR, and some information as the CDR + ((and (pairp x) (eq (qcar x) 'progn)) + (setq z (qcdr x)) + (dolist (u z) (|compCategoryItem| u predl))) + (t +; 4. otherwise, x gives a signature for a single operator name or a list of +; names; if a list of names, recurse + (cond ((eq (car x) 'signature) (car x))) + (setq op (cadr x)) + (setq sig (cddr x)) + (cond + ((null (atom op)) + (dolist (y op) + (|compCategoryItem| (cons 'signature (cons y sig)) predl))) + (t +; 5. branch on a single type or a signature %with source and target + (push (mkq (list (cdr x) pred)) |$sigList|))))))))) + +\end{chunk} + \defun{mkExplicitCategoryFunction}{mkExplicitCategoryFunction} \calls{mkExplicitCategoryFunction}{mkq} \calls{mkExplicitCategoryFunction}{union} @@ -10332,6 +10410,23 @@ An angry JHD - August 15th., 1984 \end{chunk} +;mustInstantiate D == +; D is [fn,:.] and ^(member(fn,$DummyFunctorNames) or GET(fn,"makeFunctionList")) + +\defun{mustInstantiate}{mustInstantiate} +\calls{mustInstantiate}{pairp} +\calls{mustInstantiate}{qcar} +\calls{mustInstantiate}{getl} +\refsdollar{mustInstantiate}{DummyFunctorNames} +\begin{chunk}{defun mustInstantiate} +(defun |mustInstantiate| (d) + (declare (special |$DummyFunctorNames|)) + (and (pairp d) + (null (or (member (qcar d) |$DummyFunctorNames|) + (getl (qcar d) '|makeFunctionList|))))) + +\end{chunk} + \defun{wrapDomainSub}{wrapDomainSub} \begin{chunk}{defun wrapDomainSub} (defun |wrapDomainSub| (parameters x) @@ -21353,6 +21448,7 @@ The current input line. \getchunk{defun compCase1} \getchunk{defun compCat} \getchunk{defun compCategory} +\getchunk{defun compCategoryItem} \getchunk{defun compCoerce} \getchunk{defun compCoerce1} \getchunk{defun compColon} @@ -21584,6 +21680,7 @@ The current input line. \getchunk{defun modeEqualSubst} \getchunk{defun modemapPattern} \getchunk{defun moveORsOutside} +\getchunk{defun mustInstantiate} \getchunk{defun ncINTERPFILE} \getchunk{defun next-char} diff --git a/changelog b/changelog index 03b75cc..05ac2f4 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,9 @@ +20110826 tpd src/axiom-website/patches.html 20110826.01.tpd.patch +20110826 tpd src/interp/Makefile remove define.lisp +20110826 tpd src/interp/define.lisp removed +20110826 tpd src/interp/functor.lisp treeshake compiler +20110826 tpd src/interp/package.lisp treeshake compiler +20110826 tpd books/bookvol9 treeshake compiler 20110825 tpd src/axiom-website/patches.html 20110825.01.tpd.patch 20110825 tpd src/interp/define.lisp treeshake compiler 20110825 tpd books/bookvol9 treeshake compiler diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index a7da462..7750cc0 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -3596,5 +3596,7 @@ src/interp/Makefile remove foam_l
books/bookvol9 treeshake compiler
20110825.01.tpd.patch books/bookvol9 treeshake compiler
+20110826.01.tpd.patch +books/bookvol9 treeshake compiler
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index f1184e1..634e3b3 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -178,7 +178,7 @@ OBJS= ${OUT}/vmlisp.${O} \ ${OUT}/apply.${O} ${OUT}/c-doc.${O} \ ${OUT}/c-util.${O} ${OUT}/profile.${O} \ ${OUT}/category.${O} \ - ${OUT}/define.${O} ${OUT}/functor.${O} \ + ${OUT}/functor.${O} \ ${OUT}/info.${O} ${OUT}/iterator.${O} \ ${OUT}/nruncomp.${O} \ ${OUT}/package.${O} ${OUT}/htcheck.${O} @@ -1662,30 +1662,6 @@ ${MID}/compress.lisp: ${IN}/compress.lisp.pamphlet @ -\subsection{define.lisp} -<>= -${OUT}/define.${O}: ${MID}/define.lisp - @ echo 136 making ${OUT}/define.${O} from ${MID}/define.lisp - @ ( cd ${MID} ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/define.lisp"' \ - ':output-file "${OUT}/define.${O}") (${BYE}))' | ${DEPSYS} ; \ - else \ - echo '(progn (compile-file "${MID}/define.lisp"' \ - ':output-file "${OUT}/define.${O}") (${BYE}))' | ${DEPSYS} \ - >${TMP}/trace ; \ - fi ) - -@ -<>= -${MID}/define.lisp: ${IN}/define.lisp.pamphlet - @ echo 137 making ${MID}/define.lisp from ${IN}/define.lisp.pamphlet - @ (cd ${MID} ; \ - echo '(tangle "${IN}/define.lisp.pamphlet" "*" "define.lisp")' \ - | ${OBJ}/${SYS}/bin/lisp ) - -@ - \subsection{format.lisp} <>= ${OUT}/format.${O}: ${MID}/format.lisp @@ -3202,9 +3178,6 @@ clean: <> -<> -<> - <> <> diff --git a/src/interp/define.lisp.pamphlet b/src/interp/define.lisp.pamphlet deleted file mode 100644 index 4e41b9f..0000000 --- a/src/interp/define.lisp.pamphlet +++ /dev/null @@ -1,407 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp define.lisp} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\begin{chunk}{*} -(IN-PACKAGE "BOOT" ) - - -;canCacheLocalDomain(dom,elt)== -; dom is [op,'_$,n] and MEMQ(op,'(ELT QREFELT)) => nil -; domargsglobal(dom) => -; $functorLocalParameters:= [:$functorLocalParameters,dom] -; PUSH([dom,GENVAR(),[elt,$selector,$funcLocLen]],$usedDomList) -; $selcount:= $selcount+1 -; $funcLocLen:= $funcLocLen+1 -; nil -; where -; domargsglobal(dom) == -; dom='_$ => true -; IDENTP dom => MEMQ(dom,$functorLocalParameters) -; ATOM dom => true -; and/[domargsglobal(arg) for arg in rest dom] - -(DEFUN |canCacheLocalDomain,domargsglobal| (|dom|) - (PROG () - (declare (special |$functorLocalParameters|)) - (RETURN - (SEQ (IF (BOOT-EQUAL |dom| '$) (EXIT 'T)) - (IF (IDENTP |dom|) - (EXIT (member |dom| |$functorLocalParameters|))) - (IF (ATOM |dom|) (EXIT 'T)) - (EXIT (PROG (G168996) - (SPADLET G168996 'T) - (RETURN - (DO ((G169002 NIL (NULL G168996)) - (G169003 (CDR |dom|) (CDR G169003)) - (|arg| NIL)) - ((OR G169002 (ATOM G169003) - (PROGN (SETQ |arg| (CAR G169003)) NIL)) - G168996) - (SEQ (EXIT (SETQ G168996 - (AND G168996 - (|canCacheLocalDomain,domargsglobal| - |arg|))))))))))))) - -(DEFUN |canCacheLocalDomain| (|dom| |elt|) - (PROG (|op| |ISTMP#1| |ISTMP#2| |n|) - (declare (special |$funcLocLen| |$selcount| |$usedDomList| |$selector| - |$functorLocalParameters|)) - (RETURN - (COND - ((AND (PAIRP |dom|) - (PROGN - (SPADLET |op| (QCAR |dom|)) - (SPADLET |ISTMP#1| (QCDR |dom|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) '$) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |n| (QCAR |ISTMP#2|)) 'T))))) - (member |op| '(ELT QREFELT))) - NIL) - ((|canCacheLocalDomain,domargsglobal| |dom|) - (SPADLET |$functorLocalParameters| - (APPEND |$functorLocalParameters| (CONS |dom| NIL))) - (PUSH (CONS |dom| - (CONS (GENVAR) - (CONS (CONS |elt| - (CONS |$selector| - (CONS |$funcLocLen| NIL))) - NIL))) - |$usedDomList|) - (SPADLET |$selcount| (PLUS |$selcount| 1)) - (SPADLET |$funcLocLen| (PLUS |$funcLocLen| 1))) - ('T NIL))))) - -;listInitialSegment(u,v) == -; null u => true -; null v => nil -; first u=first v and listInitialSegment(rest u,rest v) - -(DEFUN |listInitialSegment| (|u| |v|) - (COND - ((NULL |u|) 'T) - ((NULL |v|) NIL) - ('T - (AND (BOOT-EQUAL (CAR |u|) (CAR |v|)) - (|listInitialSegment| (CDR |u|) (CDR |v|)))))) - - -;--% PROCESS FUNCTOR CODE -; -;processFunctor(form,signature,data,localParList,e) == -; form is ["CategoryDefaults"] => -; error "CategoryDefaults is a reserved name" -; buildFunctor(form,signature,data,localParList,e) - -(DEFUN |processFunctor| (|form| |signature| |data| |localParList| |e|) - (COND - ((AND (PAIRP |form|) (EQ (QCDR |form|) NIL) - (EQ (QCAR |form|) '|CategoryDefaults|)) - (|error| '|CategoryDefaults is a reserved name|)) - ('T (|buildFunctor| |form| |signature| |data| |localParList| |e|)))) - -;--compSingleCapsuleIf(x,predl,e,$functorLocalParameters) == -;-- compSingleCapsuleItem(x,predl,e) -; -;--% CATEGORY AND DOMAIN FUNCTIONS -;compContained(["CONTAINED",a,b],m,e) == -; [a,ma,e]:= comp(a,$EmptyMode,e) or return nil -; [b,mb,e]:= comp(b,$EmptyMode,e) or return nil -; isCategoryForm(ma,e) and isCategoryForm(mb,e) => -; (T:= [["CONTAINED",a,b],$Boolean,e]; convert(T,m)) -; nil - -(DEFUN |compContained| (G170279 |m| |e|) - (PROG (|a| |ma| |LETTMP#1| |b| |mb| T$) - (declare (special |$Boolean| |$EmptyMode|)) - (RETURN - (PROGN - (COND ((EQ (CAR G170279) 'CONTAINED) (CAR G170279))) - (SPADLET |a| (CADR G170279)) - (SPADLET |b| (CADDR G170279)) - (SPADLET |LETTMP#1| - (OR (|comp| |a| |$EmptyMode| |e|) (RETURN NIL))) - (SPADLET |a| (CAR |LETTMP#1|)) - (SPADLET |ma| (CADR |LETTMP#1|)) - (SPADLET |e| (CADDR |LETTMP#1|)) - (SPADLET |LETTMP#1| - (OR (|comp| |b| |$EmptyMode| |e|) (RETURN NIL))) - (SPADLET |b| (CAR |LETTMP#1|)) - (SPADLET |mb| (CADR |LETTMP#1|)) - (SPADLET |e| (CADDR |LETTMP#1|)) - (COND - ((AND (|isCategoryForm| |ma| |e|) - (|isCategoryForm| |mb| |e|)) - (SPADLET T$ - (CONS (CONS 'CONTAINED (CONS |a| (CONS |b| NIL))) - (CONS |$Boolean| (CONS |e| NIL)))) - (|convert| T$ |m|)) - ('T NIL)))))) - -;wrapDomainSub(parameters,x) == -; ["DomainSubstitutionMacro",parameters,x] - -(DEFUN |wrapDomainSub| (|parameters| |x|) - (CONS '|DomainSubstitutionMacro| (CONS |parameters| (CONS |x| NIL)))) - -;mustInstantiate D == -; D is [fn,:.] and ^(member(fn,$DummyFunctorNames) or GET(fn,"makeFunctionList")) - -(DEFUN |mustInstantiate| (D) - (PROG (|fn|) - (declare (special |$DummyFunctorNames|)) - (RETURN - (AND (PAIRP D) (PROGN (SPADLET |fn| (QCAR D)) 'T) - (NULL (OR (member |fn| |$DummyFunctorNames|) - (GETL |fn| '|makeFunctionList|))))))) - -;DomainSubstitutionFunction(parameters,body) == -; --see definition of DomainSubstitutionMacro in SPAD LISP -; if parameters then -; (body:= Subst(parameters,body)) where -; Subst(parameters,body) == -; ATOM body => -; MEMQ(body,parameters) => MKQ body -; body -; MEMBER(body,parameters) => -; g:=GENSYM() -; $extraParms:=PUSH([g,:body],$extraParms) -; --Used in SetVector12 to generate a substitution list -; --bound in buildFunctor -; --For categories, bound and used in compDefineCategory -; MKQ g -; first body="QUOTE" => body -; PAIRP $definition and -; isFunctor first body and -; first body ^= first $definition -; => ['QUOTE,optimize body] -; [Subst(parameters,u) for u in body] -; not (body is ["Join",:.]) => body -; atom $definition => body -; null rest $definition => body -; --should not bother if it will only be called once -; name:= INTERN STRCONC(KAR $definition,";CAT") -; SETANDFILE(name,nil) -; body:= ["COND",[name],['(QUOTE T),['SETQ,name,body]]] -; body - -(DEFUN |DomainSubstitutionFunction,Subst| (|parameters| |body|) - (PROG (|g|) - (declare (special |$definition| |$extraParms|)) - (RETURN - (SEQ (IF (ATOM |body|) - (EXIT (SEQ (IF (member |body| |parameters|) - (EXIT (MKQ |body|))) - (EXIT |body|)))) - (IF (|member| |body| |parameters|) - (EXIT (SEQ (SPADLET |g| (GENSYM)) - (SPADLET |$extraParms| - (PUSH (CONS |g| |body|) - |$extraParms|)) - (EXIT (MKQ |g|))))) - (IF (BOOT-EQUAL (CAR |body|) 'QUOTE) (EXIT |body|)) - (IF (AND (AND (PAIRP |$definition|) - (|isFunctor| (CAR |body|))) - (NEQUAL (CAR |body|) (CAR |$definition|))) - (EXIT (CONS 'QUOTE (CONS (|optimize| |body|) NIL)))) - (EXIT (PROG (G170613) - (SPADLET G170613 NIL) - (RETURN - (DO ((G170618 |body| (CDR G170618)) (|u| NIL)) - ((OR (ATOM G170618) - (PROGN (SETQ |u| (CAR G170618)) NIL)) - (NREVERSE0 G170613)) - (SEQ (EXIT (SETQ G170613 - (CONS - (|DomainSubstitutionFunction,Subst| - |parameters| |u|) - G170613)))))))))))) - -(DEFUN |DomainSubstitutionFunction| (|parameters| |body|) - (PROG (|name|) - (declare (special |$definition|)) - (RETURN - (PROGN - (COND - (|parameters| - (SPADLET |body| - (|DomainSubstitutionFunction,Subst| |parameters| - |body|)))) - (COND - ((NULL (AND (PAIRP |body|) (EQ (QCAR |body|) '|Join|))) - |body|) - ((ATOM |$definition|) |body|) - ((NULL (CDR |$definition|)) |body|) - ('T - (SPADLET |name| - (INTERN (STRCONC (KAR |$definition|) '|;CAT|))) - (SETANDFILE |name| NIL) - (SPADLET |body| - (CONS 'COND - (CONS (CONS |name| NIL) - (CONS (CONS ''T - (CONS - (CONS 'SETQ - (CONS |name| - (CONS |body| NIL))) - NIL)) - NIL)))) - |body|)))))) - -;compCategoryItem(x,predl) == -; x is nil => nil -; --1. if x is a conditional expression, recurse; otherwise, form the predicate -; x is ["COND",[p,e]] => -; predl':= [p,:predl] -; e is ["PROGN",:l] => for y in l repeat compCategoryItem(y,predl') -; compCategoryItem(e,predl') -; x is ["IF",a,b,c] => -; predl':= [a,:predl] -; if b^="noBranch" then -; b is ["PROGN",:l] => for y in l repeat compCategoryItem(y,predl') -; compCategoryItem(b,predl') -; c="noBranch" => nil -; predl':= [["not",a],:predl] -; c is ["PROGN",:l] => for y in l repeat compCategoryItem(y,predl') -; compCategoryItem(c,predl') -; pred:= (predl => MKPF(predl,"AND"); true) -; -; --2. if attribute, push it and return -; x is ["ATTRIBUTE",y] => PUSH(MKQ [y,pred],$atList) -; -; --3. it may be a list, with PROGN as the CAR, and some information as the CDR -; x is ["PROGN",:l] => for u in l repeat compCategoryItem(u,predl) -; -;-- 4. otherwise, x gives a signature for a -;-- single operator name or a list of names; if a list of names, -;-- recurse -; ["SIGNATURE",op,:sig]:= x -; null atom op => -; for y in op repeat compCategoryItem(["SIGNATURE",y,:sig],predl) -; -; --4. branch on a single type or a signature %with source and target -; PUSH(MKQ [rest x,pred],$sigList) -; - -(DEFUN |compCategoryItem| (|x| |predl|) - (PROG (|p| |e| |a| |ISTMP#2| |b| |ISTMP#3| |c| |predl'| |pred| - |ISTMP#1| |y| |l| |op| |sig|) - (declare (special |$sigList| |$atList|)) - (RETURN - (SEQ (COND - ((NULL |x|) NIL) - ((AND (PAIRP |x|) (EQ (QCAR |x|) 'COND) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN - (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |p| (QCAR |ISTMP#2|)) - (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN - (SPADLET |e| (QCAR |ISTMP#3|)) - 'T)))))))) - (SPADLET |predl'| (CONS |p| |predl|)) - (COND - ((AND (PAIRP |e|) (EQ (QCAR |e|) 'PROGN) - (PROGN (SPADLET |l| (QCDR |e|)) 'T)) - (DO ((G170713 |l| (CDR G170713)) (|y| NIL)) - ((OR (ATOM G170713) - (PROGN (SETQ |y| (CAR G170713)) NIL)) - NIL) - (SEQ (EXIT (|compCategoryItem| |y| |predl'|))))) - ('T (|compCategoryItem| |e| |predl'|)))) - ((AND (PAIRP |x|) (EQ (QCAR |x|) 'IF) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |b| (QCAR |ISTMP#2|)) - (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN - (SPADLET |c| (QCAR |ISTMP#3|)) - 'T)))))))) - (SPADLET |predl'| (CONS |a| |predl|)) - (COND - ((NEQUAL |b| '|noBranch|) - (COND - ((AND (PAIRP |b|) (EQ (QCAR |b|) 'PROGN) - (PROGN (SPADLET |l| (QCDR |b|)) 'T)) - (DO ((G170722 |l| (CDR G170722)) (|y| NIL)) - ((OR (ATOM G170722) - (PROGN (SETQ |y| (CAR G170722)) NIL)) - NIL) - (SEQ (EXIT (|compCategoryItem| |y| |predl'|))))) - ('T (|compCategoryItem| |b| |predl'|))))) - (COND - ((BOOT-EQUAL |c| '|noBranch|) NIL) - ('T - (SPADLET |predl'| - (CONS (CONS '|not| (CONS |a| NIL)) |predl|)) - (COND - ((AND (PAIRP |c|) (EQ (QCAR |c|) 'PROGN) - (PROGN (SPADLET |l| (QCDR |c|)) 'T)) - (DO ((G170731 |l| (CDR G170731)) (|y| NIL)) - ((OR (ATOM G170731) - (PROGN (SETQ |y| (CAR G170731)) NIL)) - NIL) - (SEQ (EXIT (|compCategoryItem| |y| |predl'|))))) - ('T (|compCategoryItem| |c| |predl'|)))))) - ('T - (SPADLET |pred| - (COND (|predl| (MKPF |predl| 'AND)) ('T 'T))) - (COND - ((AND (PAIRP |x|) (EQ (QCAR |x|) 'ATTRIBUTE) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |y| (QCAR |ISTMP#1|)) 'T)))) - (PUSH (MKQ (CONS |y| (CONS |pred| NIL))) |$atList|)) - ((AND (PAIRP |x|) (EQ (QCAR |x|) 'PROGN) - (PROGN (SPADLET |l| (QCDR |x|)) 'T)) - (DO ((G170740 |l| (CDR G170740)) (|u| NIL)) - ((OR (ATOM G170740) - (PROGN (SETQ |u| (CAR G170740)) NIL)) - NIL) - (SEQ (EXIT (|compCategoryItem| |u| |predl|))))) - ('T (COND ((EQ (CAR |x|) 'SIGNATURE) (CAR |x|))) - (SPADLET |op| (CADR |x|)) (SPADLET |sig| (CDDR |x|)) - (COND - ((NULL (ATOM |op|)) - (DO ((G170749 |op| (CDR G170749)) (|y| NIL)) - ((OR (ATOM G170749) - (PROGN (SETQ |y| (CAR G170749)) NIL)) - NIL) - (SEQ (EXIT (|compCategoryItem| - (CONS 'SIGNATURE (CONS |y| |sig|)) - |predl|))))) - ('T - (PUSH (MKQ (CONS (CDR |x|) (CONS |pred| NIL))) - |$sigList|))))))))))) - -\end{chunk} -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/functor.lisp.pamphlet b/src/interp/functor.lisp.pamphlet index 26a87ba..75bd567 100644 --- a/src/interp/functor.lisp.pamphlet +++ b/src/interp/functor.lisp.pamphlet @@ -902,6 +902,99 @@ (CONS (|optFunctorBody| |u|) G166542))))))))))))) +;DomainSubstitutionFunction(parameters,body) == +; --see definition of DomainSubstitutionMacro in SPAD LISP +; if parameters then +; (body:= Subst(parameters,body)) where +; Subst(parameters,body) == +; ATOM body => +; MEMQ(body,parameters) => MKQ body +; body +; MEMBER(body,parameters) => +; g:=GENSYM() +; $extraParms:=PUSH([g,:body],$extraParms) +; --Used in SetVector12 to generate a substitution list +; --bound in buildFunctor +; --For categories, bound and used in compDefineCategory +; MKQ g +; first body="QUOTE" => body +; PAIRP $definition and +; isFunctor first body and +; first body ^= first $definition +; => ['QUOTE,optimize body] +; [Subst(parameters,u) for u in body] +; not (body is ["Join",:.]) => body +; atom $definition => body +; null rest $definition => body +; --should not bother if it will only be called once +; name:= INTERN STRCONC(KAR $definition,";CAT") +; SETANDFILE(name,nil) +; body:= ["COND",[name],['(QUOTE T),['SETQ,name,body]]] +; body + +(DEFUN |DomainSubstitutionFunction,Subst| (|parameters| |body|) + (PROG (|g|) + (declare (special |$definition| |$extraParms|)) + (RETURN + (SEQ (IF (ATOM |body|) + (EXIT (SEQ (IF (member |body| |parameters|) + (EXIT (MKQ |body|))) + (EXIT |body|)))) + (IF (|member| |body| |parameters|) + (EXIT (SEQ (SPADLET |g| (GENSYM)) + (SPADLET |$extraParms| + (PUSH (CONS |g| |body|) + |$extraParms|)) + (EXIT (MKQ |g|))))) + (IF (BOOT-EQUAL (CAR |body|) 'QUOTE) (EXIT |body|)) + (IF (AND (AND (PAIRP |$definition|) + (|isFunctor| (CAR |body|))) + (NEQUAL (CAR |body|) (CAR |$definition|))) + (EXIT (CONS 'QUOTE (CONS (|optimize| |body|) NIL)))) + (EXIT (PROG (G170613) + (SPADLET G170613 NIL) + (RETURN + (DO ((G170618 |body| (CDR G170618)) (|u| NIL)) + ((OR (ATOM G170618) + (PROGN (SETQ |u| (CAR G170618)) NIL)) + (NREVERSE0 G170613)) + (SEQ (EXIT (SETQ G170613 + (CONS + (|DomainSubstitutionFunction,Subst| + |parameters| |u|) + G170613)))))))))))) + +(DEFUN |DomainSubstitutionFunction| (|parameters| |body|) + (PROG (|name|) + (declare (special |$definition|)) + (RETURN + (PROGN + (COND + (|parameters| + (SPADLET |body| + (|DomainSubstitutionFunction,Subst| |parameters| + |body|)))) + (COND + ((NULL (AND (PAIRP |body|) (EQ (QCAR |body|) '|Join|))) + |body|) + ((ATOM |$definition|) |body|) + ((NULL (CDR |$definition|)) |body|) + ('T + (SPADLET |name| + (INTERN (STRCONC (KAR |$definition|) '|;CAT|))) + (SETANDFILE |name| NIL) + (SPADLET |body| + (CONS 'COND + (CONS (CONS |name| NIL) + (CONS (CONS ''T + (CONS + (CONS 'SETQ + (CONS |name| + (CONS |body| NIL))) + NIL)) + NIL)))) + |body|)))))) + ;optFunctorBodyQuotable u == ; null u => true ; NUMBERP u => true diff --git a/src/interp/package.lisp.pamphlet b/src/interp/package.lisp.pamphlet index c35bc1f..e95a3ac 100644 --- a/src/interp/package.lisp.pamphlet +++ b/src/interp/package.lisp.pamphlet @@ -29,6 +29,18 @@ (declare (ignore |m|)) (|processFunctor| |form| |signature| |data| |localParList| |e|)) +;processFunctor(form,signature,data,localParList,e) == +; form is ["CategoryDefaults"] => +; error "CategoryDefaults is a reserved name" +; buildFunctor(form,signature,data,localParList,e) + +(DEFUN |processFunctor| (|form| |signature| |data| |localParList| |e|) + (COND + ((AND (PAIRP |form|) (EQ (QCDR |form|) NIL) + (EQ (QCAR |form|) '|CategoryDefaults|)) + (|error| '|CategoryDefaults is a reserved name|)) + ('T (|buildFunctor| |form| |signature| |data| |localParList| |e|)))) + ;processPackage($definition is [name,:args],[$catsig,:argssig],code,locals,$e) == ; $GENNO: local:= 0 --for GENVAR() ; $catsig: local := nil