diff --git a/changelog b/changelog index 11e21d3..89399dd 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +20090828 tpd src/axiom-website/patches.html 20090828.01.tpd.patch +20090828 tpd src/interp/Makefile move package.boot to package.lisp +20090828 tpd src/interp/package.lisp added, rewritten from package.boot +20090828 tpd src/interp/package.boot removed, rewritten to package.lisp 20090827 tpd src/axiom-website/patches.html 20090827.09.tpd.patch 20090827 tpd src/interp/Makefile move modemap.boot to modemap.lisp 20090827 tpd src/interp/modemap.lisp added, rewritten from modemap.boot diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 8a7cea2..34f97ee 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -1928,5 +1928,7 @@ info.lisp rewrite from boot to lisp
iterator.lisp rewrite from boot to lisp
20090827.09.tpd.patch modemap.lisp rewrite from boot to lisp
+20090828.01.tpd.patch +package.lisp rewrite from boot to lisp
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index d3a6fe0..c284472 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -3505,52 +3505,26 @@ ${DOC}/obey.lisp.dvi: ${IN}/obey.lisp.pamphlet @ -\subsection{package.boot} -<>= -${AUTO}/package.${O}: ${OUT}/package.${O} - @ echo 370 making ${AUTO}/package.${O} from ${OUT}/package.${O} - @ cp ${OUT}/package.${O} ${AUTO} - -@ +\subsection{package.lisp} <>= -${OUT}/package.${O}: ${MID}/package.clisp - @ echo 371 making ${OUT}/package.${O} from ${MID}/package.clisp - @ (cd ${MID} ; \ +${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.clisp"' \ - ':output-file "${OUT}/package.${O}") (${BYE}))' | ${DEPSYS} ; \ + echo '(progn (compile-file "${MID}/package.lisp"' \ + ':output-file "${OUT}/package.${O}") (${BYE}))' | ${DEPSYS} ; \ else \ - echo '(progn (compile-file "${MID}/package.clisp"' \ - ':output-file "${OUT}/package.${O}") (${BYE}))' | ${DEPSYS} \ + echo '(progn (compile-file "${MID}/package.lisp"' \ + ':output-file "${OUT}/package.${O}") (${BYE}))' | ${DEPSYS} \ >${TMP}/trace ; \ fi ) @ -<>= -${MID}/package.clisp: ${IN}/package.boot.pamphlet - @ echo 372 making ${MID}/package.clisp from ${IN}/package.boot.pamphlet +<>= +${MID}/package.lisp: ${IN}/package.lisp.pamphlet + @ echo 137 making ${MID}/package.lisp from ${IN}/package.lisp.pamphlet @ (cd ${MID} ; \ - ${TANGLE} ${IN}/package.boot.pamphlet >package.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "package.boot") (${BYE}))' \ - | ${DEPSYS} ; \ - else \ - echo '(progn (boottran::boottocl "package.boot") (${BYE}))' \ - | ${DEPSYS} >${TMP}/trace ; \ - fi ; \ - rm package.boot ) - -@ -<>= -${DOC}/package.boot.dvi: ${IN}/package.boot.pamphlet - @echo 373 making ${DOC}/package.boot.dvi \ - from ${IN}/package.boot.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/package.boot.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} package.boot ; \ - rm -f ${DOC}/package.boot.pamphlet ; \ - rm -f ${DOC}/package.boot.tex ; \ - rm -f ${DOC}/package.boot ) + ${TANGLE} ${IN}/package.lisp.pamphlet >package.lisp ) @ @@ -5618,10 +5592,8 @@ clean: <> <> -<> <> -<> -<> +<> <> <> diff --git a/src/interp/package.boot.pamphlet b/src/interp/package.boot.pamphlet deleted file mode 100644 index 54b3c55..0000000 --- a/src/interp/package.boot.pamphlet +++ /dev/null @@ -1,294 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp package.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{License} -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - -isPackageFunction() == - -- called by compile/putInLocalDomainReferences ---+ - nil - -processFunctorOrPackage(form,signature,data,localParList,m,e) == ---+ - processFunctor(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 - -subTree(u,v) == - v=u => true - ATOM v => nil - or/[subTree(u,v') for v' in v] - -mkList u == - u => ["LIST",:u] - nil - -setPackageLocals(pac,locs) == - for var in locs for i in 0.. | var^=nil repeat 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 - -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] - -optPackageCall(x,["PAC",packageVariableOrForm,functionName],arglist) == - RPLACA(x,functionName) - RPLACD(x,[:arglist,packageVariableOrForm]) - 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 - -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] - -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)] - -encodeItem x == - x is [op,:argl] => getCaps op - IDENTP x => PNAME x - 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]] - ---% 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 - -mkAbbrev(X,x) == addSuffix(alistSize rest 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) - -addSuffix(n,u) == - ALPHA_-CHAR_-P (s:= STRINGIMAGE u).(MAXINDEX s) => INTERN STRCONC(s,STRINGIMAGE n) - INTERNL STRCONC(s,STRINGIMAGE ";",STRINGIMAGE n) - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/package.lisp.pamphlet b/src/interp/package.lisp.pamphlet new file mode 100644 index 0000000..c9cc4b6 --- /dev/null +++ b/src/interp/package.lisp.pamphlet @@ -0,0 +1,1022 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp package.lisp} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +<<*>>= + +(IN-PACKAGE "BOOT" ) + +;isPackageFunction() == +; -- called by compile/putInLocalDomainReferences +;--+ +; nil + +(DEFUN |isPackageFunction| () NIL) + +;processFunctorOrPackage(form,signature,data,localParList,m,e) == +;--+ +; processFunctor(form,signature,data,localParList,e) + +(DEFUN |processFunctorOrPackage| + (|form| |signature| |data| |localParList| |m| |e|) + (|processFunctor| |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'|) + (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|) + (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|)) + (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 + ((MEMQ |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|) + (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| + (MAKESTRING "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 (MEMQ |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|) + (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| (MAKESTRING ";")) + (COND + ((NULL (STRINGP |encodedName|)) + (SPADLET |encodedName| (STRINGIMAGE |encodedName|)))) + (COND + ((NULL (SPADLET |p1| + (STRPOS |sep0| |encodedName| 0 + (MAKESTRING "*")))) + NIL) + ((NULL (SPADLET |p2| + (STRPOS |sep0| |encodedName| (PLUS |p1| 1) + (MAKESTRING "*")))) + '|inner|) + ((NULL (SPADLET |p3| + (STRPOS |sep| |encodedName| (PLUS |p2| 1) + (MAKESTRING "*")))) + 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|) (MAKESTRING "_")) + ('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|) + (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|)))))))) + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document}