diff --git a/books/bookvol9.pamphlet b/books/bookvol9.pamphlet index 1b8cccd..290baf5 100644 --- a/books/bookvol9.pamphlet +++ b/books/bookvol9.pamphlet @@ -6381,8 +6381,6 @@ $\rightarrow$ \calls{compile}{userError} \calls{compile}{encodeItem} \calls{compile}{strconc} -\calls{compile}{encodeItem} -\calls{compile}{isPackageFunction} \calls{compile}{nequal} \calls{compile}{kar} \calls{compile}{encodeFunctionName} @@ -6456,18 +6454,6 @@ $\rightarrow$ (when opexport (|userError| (list '|%b| op '|%d| " is local and exported"))) (intern (strconc (|encodeItem| |$prefix|) ";" (|encodeItem| op)))) -; ((and (|isPackageFunction|) -; (nequal (kar |$functorForm|) '|CategoryDefaults|)) -; (when (null opmodes) (|userError| (list "no modemap for " op))) -; (cond -; ((and (pairp opmodes) (eq (qcdr opmodes) nil) (pairp (qcar opmodes)) -; (eq (qcar (qcar opmodes)) 'pac) (pairp (qcdr (qcar opmodes))) -; (pairp (qcdr (qcdr (qcar opmodes)))) -; (eq (qcdr (qcdr (qcdr (qcar opmodes)))) nil)) -; (qcar (qcdr (qcdr (qcar opmodes))))) -; (t -; (|encodeFunctionName| op |$functorForm| |$signatureOfForm| -; '|;| |$suffix|)))) (t (|encodeFunctionName| op |$functorForm| |$signatureOfForm| '|;| |$suffix|))))) @@ -6518,6 +6504,132 @@ $\rightarrow$ \end{chunk} +\defun{encodeFunctionName}{encodeFunctionName} +Code for encoding function names inside package or domain +\calls{encodeFunctionName}{msubst} +\calls{encodeFunctionName}{mkRepititionAssoc} +\calls{encodeFunctionName}{encodeItem} +\calls{encodeFunctionName}{stringimage} +\calls{encodeFunctionName}{internl} +\calls{encodeFunctionName}{getAbbreviation} +\calls{encodeFunctionName}{length} +\refsdollar{encodeFunctionName}{lisplib} +\refsdollar{encodeFunctionName}{lisplibSignatureAlist} +\defsdollar{encodeFunctionName}{lisplibSignatureAlist} +\begin{chunk}{defun encodeFunctionName} +(defun |encodeFunctionName| (fun package signature sep count) + (let (packageName arglist signaturep reducedSig n x encodedSig encodedName) + (declare (special |$lisplibSignatureAlist| $lisplib)) + (setq packageName (car package)) + (setq arglist (cdr package)) + (setq signaturep (msubst '$ package signature)) + (setq reducedSig + (|mkRepititionAssoc| (append (cdr signaturep) (list (car signaturep))))) + (setq encodedSig + (let ((result "")) + (loop for item in reducedSig + do + (setq n (car item)) + (setq x (cdr item)) + (setq result + (strconc result + (if (eql n 1) + (|encodeItem| x) + (strconc (stringimage n) (|encodeItem| x)))))) + result)) + (setq encodedName + (internl (|getAbbreviation| packageName (|#| arglist)) + '|;| (|encodeItem| fun) '|;| encodedSig sep (stringimage count))) + (when $lisplib + (setq |$lisplibSignatureAlist| + (cons (cons encodedName signaturep) |$lisplibSignatureAlist|))) + encodedName)) + +\end{chunk} + +\defun{mkRepititionAssoc}{mkRepititionAssoc} +\calls{mkRepititionAssoc}{pairp} +\calls{mkRepititionAssoc}{qcar} +\calls{mkRepititionAssoc}{qcdr} +\begin{chunk}{defun mkRepititionAssoc} +(defun |mkRepititionAssoc| (z) + (labels ( + (mkRepfun (z n) + (let (x) + (cond + ((null z) nil) + ((and (pairp z) (eq (qcdr z) nil) (list (cons n (qcar z))))) + ((and (pairp z) (pairp (qcdr z)) (equal (qcar (qcdr z)) (qcar z))) + (mkRepfun (cdr z) (1+ n))) + (t (cons (cons n (car z)) (mkRepfun (cdr z) 1))))))) + (mkRepfun z 1))) + +\end{chunk} + +\defun{splitEncodedFunctionName}{splitEncodedFunctionName} +\calls{splitEncodedFunctionName}{stringimage} +\calls{splitEncodedFunctionName}{strpos} +\begin{chunk}{defun splitEncodedFunctionName} +(defun |splitEncodedFunctionName| (encodedName sep) + (let (sep0 p1 p2 p3 s1 s2 s3 s4) + ; sep0 is the separator used in "encodeFunctionName". + (setq sep0 ";") + (unless (stringp encodedName) (setq encodedName (stringimage encodedName))) + (cond + ((null (setq p1 (strpos sep0 encodedName 0 "*"))) nil) + ; This is picked up in compile for inner functions in partial compilation + ((null (setq p2 (strpos sep0 encodedName (1+ p1) "*"))) '|inner|) + ((null (setq p3 (strpos sep encodedName (1+ p2) "*"))) nil) + (t + (setq s1 (substring encodedName 0 p1)) + (setq s2 (substring encodedName (1+ p1) (- p2 p1 1))) + (setq s3 (substring encodedName (1+ p2) (- p3 p2 1))) + (setq s4 (substring encodedName (1+ p3) nil)) + (list s1 s2 s3 s4))))) + +\end{chunk} + +\defun{encodeItem}{encodeItem} +\calls{encodeItem}{getCaps} +\calls{encodeItem}{identp} +\calls{encodeItem}{pairp} +\calls{encodeItem}{qcar} +\calls{encodeItem}{pname} +\calls{encodeItem}{stringimage} +\begin{chunk}{defun encodeItem} +(defun |encodeItem| (x) + (cond + ((pairp x) (|getCaps| (qcar x))) + ((identp x) (pname x)) + (t (stringimage x)))) + +\end{chunk} + +\defun{getCaps}{getCaps} +\calls{getCaps}{stringimage} +\calls{getCaps}{maxindex} +\calls{getCaps}{l-case} +\calls{getCaps}{strconc} +\begin{chunk}{defun getCaps} +(defun |getCaps| (x) + (let (s c clist tmp1) + (setq s (stringimage x)) + (setq clist + (loop for i from 0 to (maxindex s) + when (upper-case-p (setq c (elt s i))) + collect c)) + (cond + ((null clist) "_") + (t + (setq tmp1 + (cons (first clist) (loop for u in (rest clist) collect (l-case u)))) + (let ((result "")) + (loop for u in tmp1 + do (setq result (strconc result u))) + result))))) + +\end{chunk} + \defun{constructMacro}{constructMacro} constructMacro (form is [nam,[lam,vl,body]]) \calls{constructMacro}{stackSemanticError} @@ -7841,7 +7953,6 @@ where item has form \calls{compDefineFunctor1}{augModemapsFromCategoryRep} \calls{compDefineFunctor1}{augModemapsFromCategory} \calls{compDefineFunctor1}{sublis} -\calls{compDefineFunctor1}{isPackageFunction} \calls{compDefineFunctor1}{maxindex} \calls{compDefineFunctor1}{makeFunctorArgumentParameters} \calls{compDefineFunctor1}{compFunctorBody} @@ -8074,23 +8185,6 @@ where item has form (setq operationAlist (sublis |$pairlis| (elt |$domainShell| 1))) (setq parSignature (sublis |$pairlis| signaturep)) (setq parForm (sublis |$pairlis| form)) -; (when (|isPackageFunction|) -; (setq |$functorLocalParameters| -; (cons nil -; (let (tmp1 result) -; (loop for i from 6 to (maxindex |$domainShell|) do -; (setq tmp1 (elt |$domainShell| i)) -; (when -; (and (pairp tmp1) (pairp (qcdr tmp1)) (pairp (qcdr (qcdr tmp1))) -; (eq (qcdr (qcdr (qcdr tmp1))) nil) -; (pairp (qcar (qcdr (qcdr tmp1)))) -; (eq (qcar (qcar (qcdr (qcdr tmp1)))) 'elt) -; (pairp (qcdr (qcar (qcdr (qcdr tmp1))))) -; (eq (qcar (qcdr (qcar (qcdr (qcdr tmp1))))) '$) -; (pairp (qcdr (qcdr (qcar (qcdr (qcdr tmp1)))))) -; (eq (qcdr (qcdr (qcdr (qcar (qcdr (qcdr tmp1)))))) nil)) -; (push nil result))) -; result)))) (setq argPars (|makeFunctorArgumentParameters| argl (cdr signaturep) (car signaturep))) (setq |$functorLocalParameters| argl) @@ -9767,7 +9861,7 @@ in the body of the add. \defun{compCapsuleInner}{compCapsuleInner} \calls{compCapsuleInner}{addInformation} \calls{compCapsuleInner}{compCapsuleItems} -\calls{compCapsuleInner}{processFunctorOrPackage} +\calls{compCapsuleInner}{processFunctor} \calls{compCapsuleInner}{mkpf} \usesdollar{compCapsuleInner}{getDomainCode} \usesdollar{compCapsuleInner}{signature} @@ -9790,12 +9884,24 @@ in the body of the add. (setq code (if (and |$insideCategoryIfTrue| (null |$insideCategoryPackageIfTrue|)) data - (|processFunctorOrPackage| - |$form| |$signature| data localParList mode env))) + (|processFunctor| |$form| |$signature| data localParList env))) (cons (mkpf (append |$getDomainCode| (list code)) 'progn) (list mode env)))) \end{chunk} +\defun{processFunctor}{processFunctor} +\calls{processFunctor}{error} +\calls{processFunctor}{buildFunctor} +\begin{chunk}{defun processFunctor} +(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)))) + +\end{chunk} + \defun{compCapsuleItems}{compCapsuleItems} The variable data appears to be unbound at runtime. Optimized code won't check for this but interpreted code fails. We should @@ -10299,7 +10405,7 @@ An angry JHD - August 15th., 1984 \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) + (let (p e a b c predlp pred y z op sig) (declare (special |$sigList| |$atList|)) (cond ((null x) nil) @@ -10888,6 +10994,74 @@ An angry JHD - August 15th., 1984 \end{chunk} +\defun{getAbbreviation}{getAbbreviation} +\calls{getAbbreviation}{constructor?} +\calls{getAbbreviation}{assq} +\calls{getAbbreviation}{mkAbbrev} +\calls{getAbbreviation}{rplac} +\refsdollar{getAbbreviation}{abbreviationTable} +\defsdollar{getAbbreviation}{abbreviationTable} +\begin{chunk}{defun getAbbreviation} +(defun |getAbbreviation| (name c) + (let (cname x n upc newAbbreviation) + (declare (special |$abbreviationTable|)) + (setq cname (|constructor?| name)) + (cond + ((setq x (assq cname |$abbreviationTable|)) + (cond + ((setq n (assq name (cdr x))) + (cond + ((setq upc (assq c (cdr n))) + (cdr upc)) + (t + (setq newAbbreviation (|mkAbbrev| x cname)) + (rplac (cdr n) (cons (cons c newAbbreviation) (cdr n))) + newAbbreviation))) + (t + (setq newAbbreviation (|mkAbbrev| x x)) + (rplac (cdr x) + (cons (cons name (list (cons c newAbbreviation))) (cdr x))) + newAbbreviation))) + (t + (setq |$abbreviationTable| + (cons (list cname (list name (cons c cname))) |$abbreviationTable|)) + cname)))) + +\end{chunk} + +\defun{mkAbbrev}{mkAbbrev} +\calls{mkAbbrev}{addSuffix} +\calls{mkAbbrev}{alistSize} +\begin{chunk}{defun mkAbbrev} +(defun |mkAbbrev| (x z) + (|addSuffix| (|alistSize| (cdr x)) z)) + +\end{chunk} + +\defun{addSuffix}{addSuffix} +\begin{chunk}{defun addSuffix} +(defun |addSuffix| (n u) + (let (s) + (if (alpha-char-p (elt (spadlet s (stringimage u)) (maxindex s))) + (intern (strconc s (stringimage n))) + (internl (strconc s (stringimage '|;|) (stringimage n)))))) + +\end{chunk} + +\defun{alistSize}{alistSize} +\begin{chunk}{defun alistSize} +(defun |alistSize| (c) + (labels ( + (count (x level) + (cond + ((eql level 2) (|#| x)) + ((null x) 0) + (+ (count (cdar x) (1+ level)) + (count (cdr x) level))))) + (count c 1))) + +\end{chunk} + \defun{getSignatureFromMode}{getSignatureFromMode} \calls{getSignatureFromMode}{getmode} \calls{getSignatureFromMode}{opOf} @@ -11654,6 +11828,13 @@ is still more than one complain else return the only signature. \end{chunk} +\defun{mkList}{mkList} +\begin{chunk}{defun mkList} +(defun |mkList| (u) + (when u (cons 'list u))) + +\end{chunk} + \defplist{if}{compIf plist} \begin{chunk}{postvars} (eval-when (eval load) @@ -21398,8 +21579,10 @@ The current input line. \getchunk{defun addModemap1} \getchunk{defun addNewDomain} \getchunk{defun add-parens-and-semis-to-line} +\getchunk{defun addSuffix} \getchunk{defun Advance-Char} \getchunk{defun advance-token} +\getchunk{defun alistSize} \getchunk{defun allLASSOCs} \getchunk{defun aplTran} \getchunk{defun aplTran1} @@ -21560,6 +21743,8 @@ The current input line. \getchunk{defun drop} \getchunk{defun eltModemapFilter} +\getchunk{defun encodeItem} +\getchunk{defun encodeFunctionName} \getchunk{defun errhuh} \getchunk{defun escape-keywords} \getchunk{defun escaped} @@ -21576,8 +21761,10 @@ The current input line. \getchunk{defun freelist} \getchunk{defun get-a-line} +\getchunk{defun getAbbreviation} \getchunk{defun getArgumentMode} \getchunk{defun getArgumentModeOrMoan} +\getchunk{defun getCaps} \getchunk{defun getCategoryOpsAndAtts} \getchunk{defun getConstructorOpsAndAtts} \getchunk{defun getDomainsInScope} @@ -21666,14 +21853,17 @@ The current input line. \getchunk{defun mergeModemap} \getchunk{defun mergeSignatureAndLocalVarAlists} \getchunk{defun meta-syntax-error} +\getchunk{defun mkAbbrev} \getchunk{defun mkAlistOfExplicitCategoryOps} \getchunk{defun mkCategoryPackage} \getchunk{defun mkConstructor} \getchunk{defun mkDatabasePred} \getchunk{defun mkEvalableCategoryForm} \getchunk{defun mkExplicitCategoryFunction} +\getchunk{defun mkList} \getchunk{defun mkNewModemapList} \getchunk{defun mkOpVec} +\getchunk{defun mkRepititionAssoc} \getchunk{defun mkUnion} \getchunk{defun modifyModeStack} \getchunk{defun modeEqual} @@ -21886,6 +22076,7 @@ The current input line. \getchunk{defun preparseReadLine1} \getchunk{defun primitiveType} \getchunk{defun print-defun} +\getchunk{defun processFunctor} \getchunk{defun push-reduction} \getchunk{defun putDomainsInScope} \getchunk{defun putInLocalDomainReferences} @@ -21916,6 +22107,7 @@ The current input line. \getchunk{defun spad} \getchunk{defun spadCompileOrSetq} \getchunk{defun spad-fixed-arg} +\getchunk{defun splitEncodedFunctionName} \getchunk{defun stack-clear} \getchunk{defun stack-load} \getchunk{defun stack-pop} diff --git a/changelog b/changelog index be847c3..0d2269f 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,9 @@ +20110828 tpd src/axiom-website/patches.html 20110828.01.tpd.patch +20110828 tpd src/interp/Makefile remove package.lisp +20110828 tpd src/interp/package.lisp removed +20110828 tpd src/interp/g-opt.lisp treeshake compiler +20110828 tpd src/interp/category.lisp treeshake compiler +20110828 tpd books/bookvol9 treeshake compiler 20110827 tpd src/axiom-website/patches.html 20110827.01.tpd.patch 20110827 tpd src/interp/package.lisp remove isPackageFunction 20110827 tpd books/bookvol9 remove isPackageFunction diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 24028cb..ef7bcc0 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -3600,5 +3600,7 @@ books/bookvol9 treeshake compiler
books/bookvol9 treeshake compiler
20110827.01.tpd.patch src/interp/package.lisp remove isPackageFunction
+20110828.01.tpd.patch +books/bookvol9 treeshake compiler, remove package.lisp
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index 634e3b3..493e99a 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -181,7 +181,7 @@ OBJS= ${OUT}/vmlisp.${O} \ ${OUT}/functor.${O} \ ${OUT}/info.${O} ${OUT}/iterator.${O} \ ${OUT}/nruncomp.${O} \ - ${OUT}/package.${O} ${OUT}/htcheck.${O} + ${OUT}/htcheck.${O} @ @@ -2576,30 +2576,6 @@ ${MID}/nrunopt.lisp: ${IN}/nrunopt.lisp.pamphlet @ -\subsection{package.lisp} -<>= -${OUT}/package.${O}: ${MID}/package.lisp - @ echo 136 making ${OUT}/package.${O} from ${MID}/package.lisp - @ ( cd ${MID} ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/package.lisp"' \ - ':output-file "${OUT}/package.${O}") (${BYE}))' | ${DEPSYS} ; \ - else \ - echo '(progn (compile-file "${MID}/package.lisp"' \ - ':output-file "${OUT}/package.${O}") (${BYE}))' | ${DEPSYS} \ - >${TMP}/trace ; \ - fi ) - -@ -<>= -${MID}/package.lisp: ${IN}/package.lisp.pamphlet - @ echo 137 making ${MID}/package.lisp from ${IN}/package.lisp.pamphlet - @ (cd ${MID} ; \ - echo '(tangle "${IN}/package.lisp.pamphlet" "*" "package.lisp")' \ - | ${OBJ}/${SYS}/bin/lisp ) - -@ - \subsection{regress.lisp} <>= ${OUT}/regress.${O}: ${MID}/regress.${LISP} @@ -3372,9 +3348,6 @@ clean: <> <> -<> -<> - <> <> <> diff --git a/src/interp/category.lisp.pamphlet b/src/interp/category.lisp.pamphlet index b700bdf..23bb7e0 100644 --- a/src/interp/category.lisp.pamphlet +++ b/src/interp/category.lisp.pamphlet @@ -440,6 +440,49 @@ of category object. |v|))))) \end{chunk} +\subsection{mkOperatorEntry} +\begin{chunk}{*} +;mkOperatorEntry(domainOrPackage,opSig is [op,sig,:flag],pred,count) == +; domainOrPackage^="domain" => +; [opSig,pred,["PAC","$",name]] where +; name() == encodeFunctionName(op,domainOrPackage,sig,":",count) +; null flag => [opSig,pred,["ELT","$",count]] +; first flag="constant" => [[op,sig],pred,["CONST","$",count]] +; systemError ["unknown variable mode: ",flag] + +(DEFUN |mkOperatorEntry| (|domainOrPackage| |opSig| |pred| |count|) + (PROG (|op| |sig| |flag|) + (RETURN + (PROGN + (SPADLET |op| (CAR |opSig|)) + (SPADLET |sig| (CADR |opSig|)) + (SPADLET |flag| (CDDR |opSig|)) + (COND + ((NEQUAL |domainOrPackage| '|domain|) + (CONS |opSig| + (CONS |pred| + (CONS (CONS 'PAC + (CONS '$ + (CONS + (|encodeFunctionName| |op| + |domainOrPackage| |sig| '|:| + |count|) + NIL))) + NIL)))) + ((NULL |flag|) + (CONS |opSig| + (CONS |pred| + (CONS (CONS 'ELT (CONS '$ (CONS |count| NIL))) + NIL)))) + ((BOOT-EQUAL (CAR |flag|) '|constant|) + (CONS (CONS |op| (CONS |sig| NIL)) + (CONS |pred| + (CONS (CONS 'CONST (CONS '$ (CONS |count| NIL))) + NIL)))) + ('T + (|systemError| + (CONS '|unknown variable mode: | (CONS |flag| NIL))))))))) +\end{chunk} \subsection{isCategory} \begin{chunk}{*} ;isCategory a == REFVECP a and #a>5 and a.3=["Category"] diff --git a/src/interp/g-opt.lisp.pamphlet b/src/interp/g-opt.lisp.pamphlet index 2310744..6c5f60b 100644 --- a/src/interp/g-opt.lisp.pamphlet +++ b/src/interp/g-opt.lisp.pamphlet @@ -505,6 +505,23 @@ (RPLAC (CDR |x|) (APPEND |a| (CONS |fn| NIL))) |x|))) ('T (|systemErrorHere| "optCall"))))))))) +;optPackageCall(x,["PAC",packageVariableOrForm,functionName],arglist) == +; RPLACA(x,functionName) +; RPLACD(x,[:arglist,packageVariableOrForm]) +; x + +(DEFUN |optPackageCall| (|x| G166589 |arglist|) + (PROG (|packageVariableOrForm| |functionName|) + (RETURN + (PROGN + (COND ((EQ (CAR G166589) 'PAC) (CAR G166589))) + (SPADLET |packageVariableOrForm| (CADR G166589)) + (SPADLET |functionName| (CADDR G166589)) + (RPLACA |x| |functionName|) + (RPLACD |x| + (APPEND |arglist| (CONS |packageVariableOrForm| NIL))) + |x|)))) + ;optCallSpecially(q,x,n,R) == ; y:= LASSOC(R,$specialCaseKeyList) => optSpecialCall(x,y,n) ; MEMQ(KAR R,$optimizableConstructorNames) => optSpecialCall(x,R,n) diff --git a/src/interp/package.lisp.pamphlet b/src/interp/package.lisp.pamphlet deleted file mode 100644 index a9e9330..0000000 --- a/src/interp/package.lisp.pamphlet +++ /dev/null @@ -1,1034 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp package.lisp} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\begin{chunk}{*} - -(IN-PACKAGE "BOOT" ) - -;processFunctorOrPackage(form,signature,data,localParList,m,e) == -;--+ -; processFunctor(form,signature,data,localParList,e) - -(DEFUN |processFunctorOrPackage| - (|form| |signature| |data| |localParList| |m| |e|) - (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 -; --used in ProcessCond -; $maximalViews: local := nil -; --read by ProcessCond -; $ResetItems: local := nil -; --stores those items that get SETQed, and may need re-processing -; $catvecList: local:= [$domainShell] -; $catNames: local:= ["$"] -;--PRINT $definition -;--PRINT ($catsig,:argssig) -;--PRETTYPRINT code -; catvec:= $domainShell --from compDefineFunctor -; $getDomainCode:= optFunctorBody $getDomainCode -; --the purpose of this is so ProcessCond recognises such items -; code:= PackageDescendCode(code,true,nil) -; if DELETE(nil,locals) then code:=[:code,:(setPackageCode locals)] where -; setPackageCode locals == -; locals':=[[u,:i] for u in locals for i in 0.. | u] -; locals'' :=[] -; while locals' repeat -; for v in locals' repeat -; [u,:i]:=v -; if and/[EQ(v,v') or not subTree(u,CAR v') for v' in locals'] -; then -; locals'':=[v,:locals''] -; locals':=DELETE(v,locals') -; precomp:=code:=[] -; for elem in locals'' repeat -; [u,:i]:=elem -; if ATOM u then u':=u -; else -; u':=opt(u,precomp) where -; opt(u,alist) == -; ATOM u => u -; for v in u repeat -; if (a:=ASSOC(v,alist)) then -; [.,:i]:=a -; u:=replace(v,[($QuickCode=>'QREFELT;'ELT),"$",i],u) where -; replace(old,new,l) == -; l isnt [h,:t] => l -; h = old => [new,:t] -; [h,:replace(old,new,t)] -; v':=opt(v,alist) -; EQ(v,v') => nil -; u:=replace(v,v',u) -; u -; precomp:=[elem,:precomp] -; code:=[[($QuickCode=>'QSETREFV;'SETELT),"$",i,u'],:code] -; NREVERSE code -; code:= -; ["PROGN",:$getDomainCode,["LET","$",["GETREFV",#locals]], -; --It is important to place this code here, -; --after $ is set up -; --slam functor with shell -; --the order of steps in this PROGN are critical -; addToSlam($definition,"$"),code,[ -; "SETELT","$",0, mkDomainConstructor $definition],: -;-- If we call addMutableArg this early, then recurise calls to this domain -;-- (e.g. while testing predicates) will generate new domains => trouble -;-- "SETELT","$",0,addMutableArg mkDomainConstructor $definition],: -; [["SETELT","$",position(name,locals),name] -; for name in $ResetItems | MEMQ(name,locals)], -; :[($mutableDomain => '(RPLACD (LASTNODE (ELT $ 0)) -; (LIST (GENSYM)));[]) ], -; "$"] -; for u in $getDomainCode repeat -; u is ['LET,.,u'] and u' is ['getDomainView,.,u''] => -; $packagesUsed:=UNION(CategoriesFromGDC u'',$packagesUsed) -; $packagesUsed:=UNION($functorLocalParameters,$packagesUsed) -; $getDomainCode:= nil -; --if we didn't kill this, DEFINE would insert it in the wrong place -; optFunctorBody code - -(DEFUN |processPackage,replace| (|old| |new| |l|) - (PROG (|h| |t|) - (RETURN - (SEQ (IF (NULL (AND (PAIRP |l|) - (PROGN - (SPADLET |h| (QCAR |l|)) - (SPADLET |t| (QCDR |l|)) - 'T))) - (EXIT |l|)) - (IF (BOOT-EQUAL |h| |old|) (EXIT (CONS |new| |t|))) - (EXIT (CONS |h| (|processPackage,replace| |old| |new| |t|))))))) - -(DEFUN |processPackage,opt| (|u| |alist|) - (PROG (|a| |i| |v'|) - (declare (special |$QuickCode|)) - (RETURN - (SEQ (IF (ATOM |u|) (EXIT |u|)) - (DO ((G166092 |u| (CDR G166092)) (|v| NIL)) - ((OR (ATOM G166092) - (PROGN (SETQ |v| (CAR G166092)) NIL)) - NIL) - (SEQ (IF (SPADLET |a| (|assoc| |v| |alist|)) - (SEQ (PROGN (SPADLET |i| (CDR |a|)) |a|) - (EXIT (SPADLET |u| - (|processPackage,replace| |v| - (CONS - (SEQ - (IF |$QuickCode| - (EXIT 'QREFELT)) - (EXIT 'ELT)) - (CONS '$ (CONS |i| NIL))) - |u|)))) - NIL) - (SPADLET |v'| (|processPackage,opt| |v| |alist|)) - (IF (EQ |v| |v'|) (EXIT NIL)) - (EXIT (SPADLET |u| - (|processPackage,replace| |v| |v'| - |u|))))) - (EXIT |u|))))) - -(DEFUN |processPackage,setPackageCode| (|locals|) - (PROG (|locals''| |locals'| |u| |i| |u'| |precomp| |code|) - (declare (special |$QuickCode|)) - (RETURN - (SEQ (SPADLET |locals'| - (PROG (G166117) - (SPADLET G166117 NIL) - (RETURN - (DO ((G166124 |locals| (CDR G166124)) - (|u| NIL) (|i| 0 (QSADD1 |i|))) - ((OR (ATOM G166124) - (PROGN - (SETQ |u| (CAR G166124)) - NIL)) - (NREVERSE0 G166117)) - (SEQ (EXIT (COND - (|u| - (SETQ G166117 - (CONS (CONS |u| |i|) - G166117)))))))))) - (SPADLET |locals''| NIL) - (DO () ((NULL |locals'|) NIL) - (SEQ (EXIT (DO ((G166145 |locals'| (CDR G166145)) - (|v| NIL)) - ((OR (ATOM G166145) - (PROGN - (SETQ |v| (CAR G166145)) - NIL)) - NIL) - (SEQ (PROGN - (SPADLET |u| (CAR |v|)) - (SPADLET |i| (CDR |v|)) - |v|) - (EXIT (IF - (PROG (G166151) - (SPADLET G166151 'T) - (RETURN - (DO - ((G166157 NIL - (NULL G166151)) - (G166158 |locals'| - (CDR G166158)) - (|v'| NIL)) - ((OR G166157 - (ATOM G166158) - (PROGN - (SETQ |v'| - (CAR G166158)) - NIL)) - G166151) - (SEQ - (EXIT - (SETQ G166151 - (AND G166151 - (OR (EQ |v| |v'|) - (NULL - (|subTree| |u| - (CAR |v'|))))))))))) - (SEQ - (SPADLET |locals''| - (CONS |v| |locals''|)) - (EXIT - (SPADLET |locals'| - (|delete| |v| |locals'|)))) - NIL))))))) - (SPADLET |precomp| (SPADLET |code| NIL)) - (DO ((G166171 |locals''| (CDR G166171)) (|elem| NIL)) - ((OR (ATOM G166171) - (PROGN (SETQ |elem| (CAR G166171)) NIL)) - NIL) - (SEQ (PROGN - (SPADLET |u| (CAR |elem|)) - (SPADLET |i| (CDR |elem|)) - |elem|) - (IF (ATOM |u|) (SPADLET |u'| |u|) - (SEQ (SPADLET |u'| - (|processPackage,opt| |u| - |precomp|)) - (EXIT (SPADLET |precomp| - (CONS |elem| |precomp|))))) - (EXIT (SPADLET |code| - (CONS (CONS - (SEQ - (IF |$QuickCode| - (EXIT 'QSETREFV)) - (EXIT 'SETELT)) - (CONS '$ - (CONS |i| (CONS |u'| NIL)))) - |code|))))) - (EXIT (NREVERSE |code|)))))) - - -(DEFUN |processPackage| (|$definition| G166239 |code| |locals| |$e|) - (DECLARE (SPECIAL |$definition| |$e|)) - (PROG ($GENNO |$catsig| |$maximalViews| |$ResetItems| |$catvecList| - |$catNames| |argssig| |name| |args| |catvec| |u'| - |ISTMP#1| |ISTMP#2| |u''|) - (DECLARE (SPECIAL $GENNO |$catsig| |$maximalViews| |$ResetItems| - |$catvecList| |$catNames| |$getDomainCode| - |$packagesUsed| |$functorLocalParameters| - |$mutableDomain| |$domainShell|)) - (RETURN - (SEQ (PROGN - (SPADLET |$catsig| (CAR G166239)) - (SPADLET |argssig| (CDR G166239)) - (SPADLET |name| (CAR |$definition|)) - (SPADLET |args| (CDR |$definition|)) - (SPADLET $GENNO 0) - (SPADLET |$catsig| NIL) - (SPADLET |$maximalViews| NIL) - (SPADLET |$ResetItems| NIL) - (SPADLET |$catvecList| (CONS |$domainShell| NIL)) - (SPADLET |$catNames| (CONS '$ NIL)) - (SPADLET |catvec| |$domainShell|) - (SPADLET |$getDomainCode| - (|optFunctorBody| |$getDomainCode|)) - (SPADLET |code| (|PackageDescendCode| |code| 'T NIL)) - (COND - ((|delete| NIL |locals|) - (SPADLET |code| - (APPEND |code| - (|processPackage,setPackageCode| - |locals|))))) - (SPADLET |code| - (CONS 'PROGN - (APPEND |$getDomainCode| - (CONS - (CONS 'LET - (CONS '$ - (CONS - (CONS 'GETREFV - (CONS (|#| |locals|) NIL)) - NIL))) - (CONS - (|addToSlam| |$definition| '$) - (CONS |code| - (CONS - (CONS 'SETELT - (CONS '$ - (CONS 0 - (CONS - (|mkDomainConstructor| - |$definition|) - NIL)))) - (APPEND - (PROG (G166269) - (SPADLET G166269 NIL) - (RETURN - (DO - ((G166275 |$ResetItems| - (CDR G166275)) - (|name| NIL)) - ((OR (ATOM G166275) - (PROGN - (SETQ |name| - (CAR G166275)) - NIL)) - (NREVERSE0 G166269)) - (SEQ - (EXIT - (COND - ((member |name| - |locals|) - (SETQ G166269 - (CONS - (CONS 'SETELT - (CONS '$ - (CONS - (|position| - |name| - |locals|) - (CONS |name| - NIL)))) - G166269))))))))) - (APPEND - (CONS - (COND - (|$mutableDomain| - '(RPLACD - (LASTNODE (ELT $ 0)) - (LIST (GENSYM)))) - ('T NIL)) - NIL) - (CONS '$ NIL)))))))))) - (SEQ (DO ((G166296 |$getDomainCode| (CDR G166296)) - (|u| NIL)) - ((OR (ATOM G166296) - (PROGN (SETQ |u| (CAR G166296)) NIL)) - NIL) - (SEQ (EXIT (COND - ((AND (PAIRP |u|) (EQ (QCAR |u|) 'LET) - (PROGN - (SPADLET |ISTMP#1| (QCDR |u|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |u'| - (QCAR |ISTMP#2|)) - 'T))))) - (PAIRP |u'|) - (EQ (QCAR |u'|) - '|getDomainView|) - (PROGN - (SPADLET |ISTMP#1| - (QCDR |u'|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |u''| - (QCAR |ISTMP#2|)) - 'T)))))) - (EXIT (SPADLET |$packagesUsed| - (|union| - (|CategoriesFromGDC| |u''|) - |$packagesUsed|)))))))) - (SPADLET |$packagesUsed| - (|union| |$functorLocalParameters| - |$packagesUsed|)) - (SPADLET |$getDomainCode| NIL) - (|optFunctorBody| |code|))))))) - -;subTree(u,v) == -; v=u => true -; ATOM v => nil -; or/[subTree(u,v') for v' in v] - -(DEFUN |subTree| (|u| |v|) - (PROG () - (RETURN - (SEQ (COND - ((BOOT-EQUAL |v| |u|) 'T) - ((ATOM |v|) NIL) - ('T - (PROG (G166346) - (SPADLET G166346 NIL) - (RETURN - (DO ((G166352 NIL G166346) - (G166353 |v| (CDR G166353)) (|v'| NIL)) - ((OR G166352 (ATOM G166353) - (PROGN (SETQ |v'| (CAR G166353)) NIL)) - G166346) - (SEQ (EXIT (SETQ G166346 - (OR G166346 - (|subTree| |u| |v'|)))))))))))))) - -;mkList u == -; u => ["LIST",:u] -; nil - -(DEFUN |mkList| (|u|) (COND (|u| (CONS 'LIST |u|)) ('T NIL))) - -; -;setPackageLocals(pac,locs) == -; for var in locs for i in 0.. | var^=nil repeat pac.i:= var - -(DEFUN |setPackageLocals| (|pac| |locs|) - (SEQ (DO ((G166373 |locs| (CDR G166373)) (|var| NIL) - (|i| 0 (QSADD1 |i|))) - ((OR (ATOM G166373) - (PROGN (SETQ |var| (CAR G166373)) NIL)) - NIL) - (SEQ (EXIT (COND - ((NEQUAL |var| NIL) (SETELT |pac| |i| |var|)))))))) - -;PackageDescendCode(code,flag,viewAssoc) == -; --flag is true if we are walking down code always executed -; --nil if we are in conditional code -; code=nil => nil -; code="noBranch" => nil -; code is ["add",base,:codelist] => -; systemError '"packages may not have add clauses" -; code is ["PROGN",:codelist] => -; ["PROGN",: -; [v for u in codelist | (v:= PackageDescendCode(u,flag,viewAssoc))^=nil]] -; code is ["COND",:condlist] => -; c:= -; ["COND",: -; [[u2:= ProcessCond(first u,viewAssoc),: -; (if null u2 -; then nil -; else -; [PackageDescendCode(v,flag and TruthP u2, -; if first u is ["HasCategory",dom,cat] -; then [[dom,:cat],:viewAssoc] -; else viewAssoc) for v in rest u])] for u in condlist]] -; TruthP CAADR c => ["PROGN",:CDADR c] -; c -; code is ["LET",name,body,:.] => -; if not MEMQ(name,$ResetItems) then $ResetItems:= [name,:$ResetItems] -; if body is [a,:.] and isFunctor a -; then $packagesUsed:=[body,:$packagesUsed] -; code -; code is ["CodeDefine",sig,implem] => -; --Generated by doIt in COMPILER BOOT -; dom:= "$" -; dom:= -; u:= LASSOC(dom,viewAssoc) => ["getDomainView",dom,u] -; dom -; body:= ["CONS",implem,dom] -; SetFunctionSlots(sig,body,flag,"original") -; code is [":",:.] => (RPLACA(code,"LIST"); RPLACD(code,NIL)) -; --Yes, I know that's a hack, but how else do you kill a line? -; code is ["LIST",:.] => nil -; code is ["MDEF",:.] => nil -; code is ["devaluate",:.] => nil -; code is ["call",:.] => code -; code is ["SETELT",:.] => code -; code is ["QSETREFV",:.] => code -; stackWarning ["unknown Package code ",code] -; code - -(DEFUN |PackageDescendCode| (|code| |flag| |viewAssoc|) - (PROG (|base| |codelist| |v| |condlist| |u2| |ISTMP#3| |cat| |c| - |name| |a| |ISTMP#1| |sig| |ISTMP#2| |implem| |u| |dom| |body|) - (declare (special |$packagesUsed| |$ResetItems|)) - (RETURN - (SEQ (COND - ((NULL |code|) NIL) - ((BOOT-EQUAL |code| '|noBranch|) NIL) - ((AND (PAIRP |code|) (EQ (QCAR |code|) '|add|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |code|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |base| (QCAR |ISTMP#1|)) - (SPADLET |codelist| (QCDR |ISTMP#1|)) - 'T)))) - (|systemError| - "packages may not have add clauses")) - ((AND (PAIRP |code|) (EQ (QCAR |code|) 'PROGN) - (PROGN (SPADLET |codelist| (QCDR |code|)) 'T)) - (CONS 'PROGN - (PROG (G166458) - (SPADLET G166458 NIL) - (RETURN - (DO ((G166464 |codelist| (CDR G166464)) - (|u| NIL)) - ((OR (ATOM G166464) - (PROGN - (SETQ |u| (CAR G166464)) - NIL)) - (NREVERSE0 G166458)) - (SEQ (EXIT (COND - ((NEQUAL - (SPADLET |v| - (|PackageDescendCode| |u| - |flag| |viewAssoc|)) - NIL) - (SETQ G166458 - (CONS |v| G166458))))))))))) - ((AND (PAIRP |code|) (EQ (QCAR |code|) 'COND) - (PROGN (SPADLET |condlist| (QCDR |code|)) 'T)) - (SPADLET |c| - (CONS 'COND - (PROG (G166483) - (SPADLET G166483 NIL) - (RETURN - (DO ((G166497 |condlist| - (CDR G166497)) - (|u| NIL)) - ((OR (ATOM G166497) - (PROGN - (SETQ |u| (CAR G166497)) - NIL)) - (NREVERSE0 G166483)) - (SEQ - (EXIT - (SETQ G166483 - (CONS - (CONS - (SPADLET |u2| - (|ProcessCond| (CAR |u|) - |viewAssoc|)) - (COND - ((NULL |u2|) NIL) - ('T - (PROG (G166516) - (SPADLET G166516 NIL) - (RETURN - (DO - ((G166530 (CDR |u|) - (CDR G166530)) - (|v| NIL)) - ((OR (ATOM G166530) - (PROGN - (SETQ |v| - (CAR G166530)) - NIL)) - (NREVERSE0 G166516)) - (SEQ - (EXIT - (SETQ G166516 - (CONS - (|PackageDescendCode| - |v| - (AND |flag| - (|TruthP| |u2|)) - (COND - ((PROGN - (SPADLET - |ISTMP#1| - (CAR |u|)) - (AND - (PAIRP - |ISTMP#1|) - (EQ - (QCAR - |ISTMP#1|) - '|HasCategory|) - (PROGN - (SPADLET - |ISTMP#2| - (QCDR - |ISTMP#1|)) - (AND - (PAIRP - |ISTMP#2|) - (PROGN - (SPADLET - |dom| - (QCAR - |ISTMP#2|)) - (SPADLET - |ISTMP#3| - (QCDR - |ISTMP#2|)) - (AND - (PAIRP - |ISTMP#3|) - (EQ - (QCDR - |ISTMP#3|) - NIL) - (PROGN - (SPADLET - |cat| - (QCAR - |ISTMP#3|)) - 'T))))))) - (CONS - (CONS |dom| - |cat|) - |viewAssoc|)) - ('T - |viewAssoc|))) - G166516)))))))))) - G166483))))))))) - (COND - ((|TruthP| (CAADR |c|)) (CONS 'PROGN (CDADR |c|))) - ('T |c|))) - ((AND (PAIRP |code|) (EQ (QCAR |code|) 'LET) - (PROGN - (SPADLET |ISTMP#1| (QCDR |code|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |name| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |body| (QCAR |ISTMP#2|)) - 'T)))))) - (COND - ((NULL (member |name| |$ResetItems|)) - (SPADLET |$ResetItems| (CONS |name| |$ResetItems|)))) - (COND - ((AND (PAIRP |body|) - (PROGN (SPADLET |a| (QCAR |body|)) 'T) - (|isFunctor| |a|)) - (SPADLET |$packagesUsed| - (CONS |body| |$packagesUsed|)))) - |code|) - ((AND (PAIRP |code|) (EQ (QCAR |code|) '|CodeDefine|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |code|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |sig| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |implem| (QCAR |ISTMP#2|)) - 'T)))))) - (SPADLET |dom| '$) - (SPADLET |dom| - (COND - ((SPADLET |u| (LASSOC |dom| |viewAssoc|)) - (CONS '|getDomainView| - (CONS |dom| (CONS |u| NIL)))) - ('T |dom|))) - (SPADLET |body| - (CONS 'CONS (CONS |implem| (CONS |dom| NIL)))) - (|SetFunctionSlots| |sig| |body| |flag| '|original|)) - ((AND (PAIRP |code|) (EQ (QCAR |code|) '|:|)) - (RPLACA |code| 'LIST) (RPLACD |code| NIL)) - ((AND (PAIRP |code|) (EQ (QCAR |code|) 'LIST)) NIL) - ((AND (PAIRP |code|) (EQ (QCAR |code|) 'MDEF)) NIL) - ((AND (PAIRP |code|) (EQ (QCAR |code|) '|devaluate|)) NIL) - ((AND (PAIRP |code|) (EQ (QCAR |code|) '|call|)) |code|) - ((AND (PAIRP |code|) (EQ (QCAR |code|) 'SETELT)) |code|) - ((AND (PAIRP |code|) (EQ (QCAR |code|) 'QSETREFV)) |code|) - ('T - (|stackWarning| - (CONS '|unknown Package code | (CONS |code| NIL))) - |code|)))))) - -;mkOperatorEntry(domainOrPackage,opSig is [op,sig,:flag],pred,count) == -; domainOrPackage^="domain" => -; [opSig,pred,["PAC","$",name]] where -; name() == encodeFunctionName(op,domainOrPackage,sig,":",count) -; null flag => [opSig,pred,["ELT","$",count]] -; first flag="constant" => [[op,sig],pred,["CONST","$",count]] -; systemError ["unknown variable mode: ",flag] - -(DEFUN |mkOperatorEntry| (|domainOrPackage| |opSig| |pred| |count|) - (PROG (|op| |sig| |flag|) - (RETURN - (PROGN - (SPADLET |op| (CAR |opSig|)) - (SPADLET |sig| (CADR |opSig|)) - (SPADLET |flag| (CDDR |opSig|)) - (COND - ((NEQUAL |domainOrPackage| '|domain|) - (CONS |opSig| - (CONS |pred| - (CONS (CONS 'PAC - (CONS '$ - (CONS - (|encodeFunctionName| |op| - |domainOrPackage| |sig| '|:| - |count|) - NIL))) - NIL)))) - ((NULL |flag|) - (CONS |opSig| - (CONS |pred| - (CONS (CONS 'ELT (CONS '$ (CONS |count| NIL))) - NIL)))) - ((BOOT-EQUAL (CAR |flag|) '|constant|) - (CONS (CONS |op| (CONS |sig| NIL)) - (CONS |pred| - (CONS (CONS 'CONST (CONS '$ (CONS |count| NIL))) - NIL)))) - ('T - (|systemError| - (CONS '|unknown variable mode: | (CONS |flag| NIL))))))))) - -;optPackageCall(x,["PAC",packageVariableOrForm,functionName],arglist) == -; RPLACA(x,functionName) -; RPLACD(x,[:arglist,packageVariableOrForm]) -; x - -(DEFUN |optPackageCall| (|x| G166589 |arglist|) - (PROG (|packageVariableOrForm| |functionName|) - (RETURN - (PROGN - (COND ((EQ (CAR G166589) 'PAC) (CAR G166589))) - (SPADLET |packageVariableOrForm| (CADR G166589)) - (SPADLET |functionName| (CADDR G166589)) - (RPLACA |x| |functionName|) - (RPLACD |x| - (APPEND |arglist| (CONS |packageVariableOrForm| NIL))) - |x|)))) - -;--% Code for encoding function names inside package or domain -; -;encodeFunctionName(fun,package is [packageName,:arglist],signature,sep,count) -; == -; signature':= substitute("$",package,signature) -; reducedSig:= mkRepititionAssoc [:rest signature',first signature'] -; encodedSig:= -; ("STRCONC"/[encodedPair for [n,:x] in reducedSig]) where -; encodedPair() == -; n=1 => encodeItem x -; STRCONC(STRINGIMAGE n,encodeItem x) -; encodedName:= INTERNL(getAbbreviation(packageName,#arglist),";", -; encodeItem fun,";",encodedSig, sep,STRINGIMAGE count) -; if $LISPLIB then -; $lisplibSignatureAlist:= -; [[encodedName,:signature'],:$lisplibSignatureAlist] -; encodedName - -(DEFUN |encodeFunctionName| (|fun| |package| |signature| |sep| |count|) - (PROG (|packageName| |arglist| |signature'| |reducedSig| |n| |x| - |encodedSig| |encodedName|) - (declare (special |$lisplibSignatureAlist| $LISPLIB)) - (RETURN - (SEQ (PROGN - (SPADLET |packageName| (CAR |package|)) - (SPADLET |arglist| (CDR |package|)) - (SPADLET |signature'| (MSUBST '$ |package| |signature|)) - (SPADLET |reducedSig| - (|mkRepititionAssoc| - (APPEND (CDR |signature'|) - (CONS (CAR |signature'|) NIL)))) - (SPADLET |encodedSig| - (PROG (G166626) - (SPADLET G166626 "") - (RETURN - (DO ((G166632 |reducedSig| (CDR G166632)) - (G166606 NIL)) - ((OR (ATOM G166632) - (PROGN - (SETQ G166606 (CAR G166632)) - NIL) - (PROGN - (PROGN - (SPADLET |n| (CAR G166606)) - (SPADLET |x| (CDR G166606)) - G166606) - NIL)) - G166626) - (SEQ (EXIT (SETQ G166626 - (STRCONC G166626 - (COND - ((EQL |n| 1) - (|encodeItem| |x|)) - ('T - (STRCONC (STRINGIMAGE |n|) - (|encodeItem| |x|)))))))))))) - (SPADLET |encodedName| - (INTERNL (|getAbbreviation| |packageName| - (|#| |arglist|)) - '|;| (|encodeItem| |fun|) '|;| - |encodedSig| |sep| - (STRINGIMAGE |count|))) - (COND - ($LISPLIB - (SPADLET |$lisplibSignatureAlist| - (CONS (CONS |encodedName| |signature'|) - |$lisplibSignatureAlist|)))) - |encodedName|))))) - -;splitEncodedFunctionName(encodedName, sep) == -; -- [encodedPackage, encodedItem, encodedSig, sequenceNo] or NIL -; -- sep0 is the separator used in "encodeFunctionName". -; sep0 := '";" -; if not STRINGP encodedName then -; encodedName := STRINGIMAGE encodedName -; null (p1 := STRPOS(sep0, encodedName, 0, '"*")) => nil -; null (p2 := STRPOS(sep0, encodedName, p1+1, '"*")) => 'inner -;-- This is picked up in compile for inner functions in partial compilation -; null (p3 := STRPOS(sep, encodedName, p2+1, '"*")) => nil -; s1 := SUBSTRING(encodedName, 0, p1) -; s2 := SUBSTRING(encodedName, p1+1, p2-p1-1) -; s3 := SUBSTRING(encodedName, p2+1, p3-p2-1) -; s4 := SUBSTRING(encodedName, p3+1, nil) -; [s1, s2, s3, s4] - -(DEFUN |splitEncodedFunctionName| (|encodedName| |sep|) - (PROG (|sep0| |p1| |p2| |p3| |s1| |s2| |s3| |s4|) - (RETURN - (PROGN - (SPADLET |sep0| ";") - (COND - ((NULL (STRINGP |encodedName|)) - (SPADLET |encodedName| (STRINGIMAGE |encodedName|)))) - (COND - ((NULL (SPADLET |p1| - (STRPOS |sep0| |encodedName| 0 - "*"))) - NIL) - ((NULL (SPADLET |p2| - (STRPOS |sep0| |encodedName| (PLUS |p1| 1) - "*"))) - '|inner|) - ((NULL (SPADLET |p3| - (STRPOS |sep| |encodedName| (PLUS |p2| 1) - "*"))) - NIL) - ('T (SPADLET |s1| (SUBSTRING |encodedName| 0 |p1|)) - (SPADLET |s2| - (SUBSTRING |encodedName| (PLUS |p1| 1) - (SPADDIFFERENCE (SPADDIFFERENCE |p2| |p1|) 1))) - (SPADLET |s3| - (SUBSTRING |encodedName| (PLUS |p2| 1) - (SPADDIFFERENCE (SPADDIFFERENCE |p3| |p2|) 1))) - (SPADLET |s4| (SUBSTRING |encodedName| (PLUS |p3| 1) NIL)) - (CONS |s1| (CONS |s2| (CONS |s3| (CONS |s4| NIL)))))))))) - -;mkRepititionAssoc l == -; mkRepfun(l,1) where -; mkRepfun(l,n) == -; null l => nil -; l is [x] => [[n,:x]] -; l is [x, =x,:l'] => mkRepfun(rest l,n+1) -; [[n,:first l],:mkRepfun(rest l,1)] - -(DEFUN |mkRepititionAssoc,mkRepfun| (|l| |n|) - (PROG (|x| |ISTMP#1| |l'|) - (RETURN - (SEQ (IF (NULL |l|) (EXIT NIL)) - (IF (AND (PAIRP |l|) (EQ (QCDR |l|) NIL) - (PROGN (SPADLET |x| (QCAR |l|)) 'T)) - (EXIT (CONS (CONS |n| |x|) NIL))) - (IF (AND (PAIRP |l|) - (PROGN - (SPADLET |x| (QCAR |l|)) - (SPADLET |ISTMP#1| (QCDR |l|)) - (AND (PAIRP |ISTMP#1|) - (EQUAL (QCAR |ISTMP#1|) |x|) - (PROGN (SPADLET |l'| (QCDR |ISTMP#1|)) 'T)))) - (EXIT (|mkRepititionAssoc,mkRepfun| (CDR |l|) - (PLUS |n| 1)))) - (EXIT (CONS (CONS |n| (CAR |l|)) - (|mkRepititionAssoc,mkRepfun| (CDR |l|) 1))))))) - -(DEFUN |mkRepititionAssoc| (|l|) (|mkRepititionAssoc,mkRepfun| |l| 1)) - -;encodeItem x == -; x is [op,:argl] => getCaps op -; IDENTP x => PNAME x -; STRINGIMAGE x - -(DEFUN |encodeItem| (|x|) - (PROG (|op| |argl|) - (RETURN - (COND - ((AND (PAIRP |x|) - (PROGN - (SPADLET |op| (QCAR |x|)) - (SPADLET |argl| (QCDR |x|)) - 'T)) - (|getCaps| |op|)) - ((IDENTP |x|) (PNAME |x|)) - ('T (STRINGIMAGE |x|)))))) - -;getCaps x == -; s:= STRINGIMAGE x -; clist:= [c for i in 0..MAXINDEX s | UPPER_-CASE_-P (c:= s.i)] -; null clist => '"__" -; "STRCONC"/[first clist,:[L_-CASE u for u in rest clist]] - -(DEFUN |getCaps| (|x|) - (PROG (|s| |c| |clist|) - (RETURN - (SEQ (PROGN - (SPADLET |s| (STRINGIMAGE |x|)) - (SPADLET |clist| - (PROG (G166702) - (SPADLET G166702 NIL) - (RETURN - (DO ((G166708 (MAXINDEX |s|)) - (|i| 0 (QSADD1 |i|))) - ((QSGREATERP |i| G166708) - (NREVERSE0 G166702)) - (SEQ (EXIT (COND - ((UPPER-CASE-P - (SPADLET |c| (ELT |s| |i|))) - (SETQ G166702 - (CONS |c| G166702)))))))))) - (COND - ((NULL |clist|) "_") - ('T - (PROG (G166712) - (SPADLET G166712 "") - (RETURN - (DO ((G166717 - (CONS (CAR |clist|) - (PROG (G166727) - (SPADLET G166727 NIL) - (RETURN - (DO - ((G166732 (CDR |clist|) - (CDR G166732)) - (|u| NIL)) - ((OR (ATOM G166732) - (PROGN - (SETQ |u| (CAR G166732)) - NIL)) - (NREVERSE0 G166727)) - (SEQ - (EXIT - (SETQ G166727 - (CONS (L-CASE |u|) - G166727)))))))) - (CDR G166717)) - (G166695 NIL)) - ((OR (ATOM G166717) - (PROGN - (SETQ G166695 (CAR G166717)) - NIL)) - G166712) - (SEQ (EXIT (SETQ G166712 - (STRCONC G166712 G166695)))))))))))))) - -;--% abbreviation code -; -;getAbbreviation(name,c) == -; --returns abbreviation of name with c arguments -; x := constructor? name -; X := ASSQ(x,$abbreviationTable) => -; N:= ASSQ(name,rest X) => -; C:= ASSQ(c,rest N) => rest C --already there -; newAbbreviation:= mkAbbrev(X,x) -; RPLAC(rest N,[[c,:newAbbreviation],:rest N]) -; newAbbreviation -; newAbbreviation:= mkAbbrev(X,x) -; RPLAC(rest X,[[name,[c,:newAbbreviation]],:rest X]) -; newAbbreviation -; $abbreviationTable:= [[x,[name,[c,:x]]],:$abbreviationTable] -; x - -(DEFUN |getAbbreviation| (|name| |c|) - (PROG (|x| X N C |newAbbreviation|) - (declare (special |$abbreviationTable|)) - (RETURN - (PROGN - (SPADLET |x| (|constructor?| |name|)) - (COND - ((SPADLET X (ASSQ |x| |$abbreviationTable|)) - (COND - ((SPADLET N (ASSQ |name| (CDR X))) - (COND - ((SPADLET C (ASSQ |c| (CDR N))) (CDR C)) - ('T (SPADLET |newAbbreviation| (|mkAbbrev| X |x|)) - (RPLAC (CDR N) - (CONS (CONS |c| |newAbbreviation|) (CDR N))) - |newAbbreviation|))) - ('T (SPADLET |newAbbreviation| (|mkAbbrev| X |x|)) - (RPLAC (CDR X) - (CONS (CONS |name| - (CONS (CONS |c| |newAbbreviation|) - NIL)) - (CDR X))) - |newAbbreviation|))) - ('T - (SPADLET |$abbreviationTable| - (CONS (CONS |x| - (CONS (CONS |name| - (CONS (CONS |c| |x|) NIL)) - NIL)) - |$abbreviationTable|)) - |x|)))))) - -;mkAbbrev(X,x) == addSuffix(alistSize rest X,x) - -(DEFUN |mkAbbrev| (X |x|) (|addSuffix| (|alistSize| (CDR X)) |x|)) - -;alistSize c == -; count(c,1) where -; count(x,level) == -; level=2 => #x -; null x => 0 -; count(CDAR x,level+1)+count(rest x,level) - -(DEFUN |alistSize,count| (|x| |level|) - (SEQ (IF (EQL |level| 2) (EXIT (|#| |x|))) (IF (NULL |x|) (EXIT 0)) - (EXIT (PLUS (|alistSize,count| (CDAR |x|) (PLUS |level| 1)) - (|alistSize,count| (CDR |x|) |level|))))) - -(DEFUN |alistSize| (|c|) (|alistSize,count| |c| 1)) - -; -;addSuffix(n,u) == -; ALPHA_-CHAR_-P (s:= STRINGIMAGE u).(MAXINDEX s) => INTERN STRCONC(s,STRINGIMAGE n) -; INTERNL STRCONC(s,STRINGIMAGE ";",STRINGIMAGE n) -; - -(DEFUN |addSuffix| (|n| |u|) - (PROG (|s|) - (RETURN - (COND - ((ALPHA-CHAR-P - (ELT (SPADLET |s| (STRINGIMAGE |u|)) (MAXINDEX |s|))) - (INTERN (STRCONC |s| (STRINGIMAGE |n|)))) - ('T - (INTERNL (STRCONC |s| (STRINGIMAGE '|;|) (STRINGIMAGE |n|)))))))) - -\end{chunk} -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document}