diff --git a/changelog b/changelog index f05ae22..7d9fa0a 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +20090827 tpd src/axiom-website/patches.html 20090827.06.tpd.patch +20090827 tpd src/interp/Makefile move functor.boot to functor.lisp +20090827 tpd src/interp/functor.lisp added, rewritten from functor.boot +20090827 tpd src/interp/functor.boot removed, rewritten to functor.lisp 20090827 tpd src/axiom-website/patches.html 20090827.05.tpd.patch 20090827 tpd src/interp/Makefile move define.boot to define.lisp 20090827 tpd src/interp/define.lisp added, rewritten from define.boot diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 38ed8b4..2334b3d 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -1920,5 +1920,7 @@ category.lisp rewrite from boot to lisp
c-util.lisp rewrite from boot to lisp
20090827.05.tpd.patch define.lisp rewrite from boot to lisp
+20090827.06.tpd.patch +functor.lisp rewrite from boot to lisp
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index 9264cb9..13d3101 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -2551,52 +2551,26 @@ ${MID}/format.lisp: ${IN}/format.lisp.pamphlet @ -\subsection{functor.boot} -<>= -${AUTO}/functor.${O}: ${OUT}/functor.${O} - @ echo 252 making ${AUTO}/functor.${O} from ${OUT}/functor.${O} - @ cp ${OUT}/functor.${O} ${AUTO} - -@ +\subsection{functor.lisp} <>= -${OUT}/functor.${O}: ${MID}/functor.clisp - @ echo 253 making ${OUT}/functor.${O} from ${MID}/functor.clisp - @ (cd ${MID} ; \ +${OUT}/functor.${O}: ${MID}/functor.lisp + @ echo 136 making ${OUT}/functor.${O} from ${MID}/functor.lisp + @ ( cd ${MID} ; \ if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/functor.clisp"' \ + echo '(progn (compile-file "${MID}/functor.lisp"' \ ':output-file "${OUT}/functor.${O}") (${BYE}))' | ${DEPSYS} ; \ else \ - echo '(progn (compile-file "${MID}/functor.clisp"' \ + echo '(progn (compile-file "${MID}/functor.lisp"' \ ':output-file "${OUT}/functor.${O}") (${BYE}))' | ${DEPSYS} \ >${TMP}/trace ; \ fi ) @ -<>= -${MID}/functor.clisp: ${IN}/functor.boot.pamphlet - @ echo 254 making ${MID}/functor.clisp from ${IN}/functor.boot.pamphlet +<>= +${MID}/functor.lisp: ${IN}/functor.lisp.pamphlet + @ echo 137 making ${MID}/functor.lisp from ${IN}/functor.lisp.pamphlet @ (cd ${MID} ; \ - ${TANGLE} ${IN}/functor.boot.pamphlet >functor.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "functor.boot") (${BYE}))' \ - | ${DEPSYS} ; \ - else \ - echo '(progn (boottran::boottocl "functor.boot") (${BYE}))' \ - | ${DEPSYS} >${TMP}/trace ; \ - fi ; \ - rm functor.boot ) - -@ -<>= -${DOC}/functor.boot.dvi: ${IN}/functor.boot.pamphlet - @echo 255 making ${DOC}/functor.boot.dvi \ - from ${IN}/functor.boot.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/functor.boot.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} functor.boot ; \ - rm -f ${DOC}/functor.boot.pamphlet ; \ - rm -f ${DOC}/functor.boot.tex ; \ - rm -f ${DOC}/functor.boot ) + ${TANGLE} ${IN}/functor.lisp.pamphlet >functor.lisp ) @ @@ -5459,10 +5433,8 @@ clean: <> <> -<> <> -<> -<> +<> <> <> diff --git a/src/interp/functor.boot.pamphlet b/src/interp/functor.boot.pamphlet deleted file mode 100644 index 9e0366f..0000000 --- a/src/interp/functor.boot.pamphlet +++ /dev/null @@ -1,1006 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp functor.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. - -@ -<<*>>= -<> - ---% Domain printing -keyItem a == - isDomain a => CDAR a.4 - a - --The item that domain checks on - ---Global strategy here is to maintain a list of substitutions --- ( %in Sublis), of vectors and the names that they have, --- which may be either local names ('View1') or global names ('Where1') --- The global names are remembered on $Sublis from one --- invocation of DomainPrint1 to the next - -DomainPrint(D,brief) == - -- If brief is non-NIL, %then only a summary is printed - $WhereList: local := nil - $Sublis: local := nil - $WhereCounter: local := nil - $WhereCounter:= 1 - env:= - not BOUNDP '$e => $EmptyEnvironment - $e='$e => $EmptyEnvironment - $e --in case we are called from top level - isCategory D => CategoryPrint(D,env) - $Sublis:= [[keyItem D,:'original]] - SAY '"-----------------------------------------------------------------------" - DomainPrint1(D,NIL,env) - while ($WhereList) repeat - s:= $WhereList - $WhereList:= nil - for u in s repeat - TERPRI() - SAY ['"Where ",first u,'" is:"] - DomainPrint1(rest u,brief,env) - SAY '"-----------------------------------------------------------------------" - -DomainPrint1(D,brief,$e) == - REFVECP D and not isDomain D => PacPrint D - if REFVECP D then D:= D.4 - --if we were passed a vector, go to the domain - Sublis:= - [: - [[rest u,:INTERNL STRCONC('"View",STRINGIMAGE i)] - for u in D for i in 1..],:$Sublis] - for u in D for i in 1.. repeat - brief and i>1 => nil - uu:= COPY_-SEQ rest u - uu.4:= '"This domain" - if not brief then - SAY ['"View number ",i,'" corresponding to categories:"] - PRETTYPRINT first u - if i=1 and REFVECP uu.5 then - vv:= COPY_-SEQ uu.5 - uu.5:= vv - for j in 0..MAXINDEX vv repeat - if REFVECP vv.j then - l:= ASSQ(keyItem vv.j,Sublis) - if l - then name:= rest l - else - name:=DPname() - Sublis:= [[keyItem vv.j,:name],:Sublis] - $Sublis:= [first Sublis,:$Sublis] - $WhereList:= [[name,:vv.j],:$WhereList] - vv.j:= name - if i>1 then - uu.1:= uu.2:= uu.5:= '"As in first view" - for i in 6..MAXINDEX uu repeat - uu.i:= DomainPrintSubst(uu.i,Sublis) - if REFVECP uu.i then - name:=DPname() - Sublis:= [[keyItem uu.i,:name],:Sublis] - $Sublis:= [first Sublis,:$Sublis] - $WhereList:= [[name,:uu.i],:$WhereList] - uu.i:= name - if uu.i is [.,:v] and REFVECP v then - name:=DPname() - Sublis:= [[keyItem v,:name],:Sublis] - $Sublis:= [first Sublis,:$Sublis] - $WhereList:= [[name,:v],:$WhereList] - uu.i:= [first uu.i,:name] - if brief then PRETTYPRINT uu.0 else PRETTYPRINT uu - -DPname() == - name:= INTERNL STRCONC('"Where",STRINGIMAGE $WhereCounter) - $WhereCounter:= $WhereCounter+1 - name - -PacPrint v == - vv:= COPY_-SEQ v - for j in 0..MAXINDEX vv repeat - if REFVECP vv.j then - l:= ASSQ(keyItem vv.j,Sublis) - if l - then name:= rest l - else - name:=DPname() - Sublis:= [[keyItem vv.j,:name],:Sublis] - $Sublis:= [first Sublis,:$Sublis] - $WhereList:= [[name,:vv.j],:$WhereList] - vv.j:= name - if PAIRP vv.j and REFVECP(u:=CDR vv.j) then - l:= ASSQ(keyItem u,Sublis) - if l - then name:= rest l - else - name:=DPname() - Sublis:= [[keyItem u,:name],:Sublis] - $Sublis:= [first Sublis,:$Sublis] - $WhereList:= [[name,:u],:$WhereList] - RPLACD(vv.j,name) - PRETTYPRINT vv - -DomainPrintSubst(item,Sublis) == - item is [a,:b] => - c1:= DomainPrintSubst(a,Sublis) - c2:= DomainPrintSubst(b,Sublis) - EQ(c1,a) and EQ(c2,b) => item - [c1,:c2] - l:= ASSQ(item,Sublis) - l => rest l - l:= ASSQ(keyItem item,Sublis) - l => rest l - item - ---% Utilities - -mkDevaluate a == - null a => nil - a is ['QUOTE,a'] => (a' => a; nil) - a='$ => MKQ '$ - a is ['LIST] => nil - a is ['LIST,:.] => a - ['devaluate,a] - -getDomainView(domain,catform) == - u:= HasCategory(domain,catform) => u - c:= eval catform - u:= HasCategory(domain,c.0) => u - -- note: this is necessary because of domain == another domain, e.g. - -- Ps are defined to be SUPs with specific arguments so that if one - -- asks if a P is a Module over itself, here one has catform= (Module - -- (P I)) yet domain is a SUP. By oding this evaluation, c.0=SUP as - -- well and test works --- RDJ 10/31/83 - throwKeyedMsg("S2IF0009",[devaluate domain, catform]) - -getPrincipalView domain == - pview:= domain - for [.,:view] in domain.4 repeat if #view>#pview then pview:= view - pview - -CategoriesFromGDC x == - atom x => nil - x is ['LIST,a,:b] and a is ['QUOTE,a'] => - UNION(LIST LIST a',"UNION"/[CategoriesFromGDC u for u in b]) - x is ['QUOTE,a] and a is [b] => [a] - -compCategories u == - ATOM u => u - not ATOM first u => - error ['"compCategories: need an atom in operator position", first u] - first u = "Record" => - -- There is no modemap property for these guys so do it by hand. - [first u, :[[":", a.1, compCategories1(a.2,'(SetCategory))] for a in rest u]] - first u = "Union" or first u = "Mapping" => - -- There is no modemap property for these guys so do it by hand. - [first u, :[compCategories1(a,'(SetCategory)) for a in rest u]] - u is ['SubDomain,D,.] => compCategories D - v:=get(first u,'modemap,$e) - ATOM v => - error ['"compCategories: could not get proper modemap for operator",first u] - if rest v then - sayBrightly ['"compCategories: ", '%b, '"Warning", '%d, - '"ignoring unexpected stuff at end of modemap"] - pp rest v - -- the next line "fixes" a bad modemap which sometimes appears .... - -- - if rest v and NULL CAAAR v then v:=CDR v - v:= CDDAAR v - v:=resolvePatternVars(v, rest u) -- replaces #n forms - -- select the modemap part of the first entry, and skip result etc. - u:=[first u,:[compCategories1(a,b) for a in rest u for b in v]] - u - -compCategories1(u,v) == --- v is the mode of u - ATOM u => u - isCategoryForm(v,$e) => compCategories u - [c,:.] := comp(macroExpand(u,$e),v,$e) => c - error 'compCategories1 - -NewbFVectorCopy(u,domName) == - v:= GETREFV SIZE u - for i in 0..5 repeat v.i:= u.i - for i in 6..MAXINDEX v | PAIRP u.i repeat v.i:= [Undef,[domName,i],:first u.i] - v - -mkVector u == - u => ['VECTOR,:u] - nil - -optFunctorBody x == - atom x => x - x is ['QUOTE,:l] => x - x is ['DomainSubstitutionMacro,parms,body] => - optFunctorBody DomainSubstitutionFunction(parms,body) - x is ['LIST,:l] => - null l => nil - l:= [optFunctorBody u for u in l] - and/[optFunctorBodyQuotable u for u in l] => - ['QUOTE,[optFunctorBodyRequote u for u in l]] - l=rest x => x --CONS-saving hack - ['LIST,:l] - x is ['PROGN,:l] => ['PROGN,:optFunctorPROGN l] - x is ['COND,:l] => ---+ - l:= - [CondClause u for u in l | u and first u] where - CondClause [pred,:conseq] == - [optFunctorBody pred,:optFunctorPROGN conseq] - l:= EFFACE('((QUOTE T)),l) - --delete any trailing ("T) - null l => nil - CAAR l='(QUOTE T) => - (null CDAR l => nil; null CDDAR l => CADAR l; ["PROGN",:CDAR l]) - null rest l and null CDAR l => - --there is no meat to this COND - pred:= CAAR l - atom pred => nil - first pred="HasCategory" => nil - ['COND,:l] - ['COND,:l] - [optFunctorBody u for u in x] - -optFunctorBodyQuotable u == - null u => true - NUMBERP u => true - atom u => nil - u is ['QUOTE,:.] => true - nil - -optFunctorBodyRequote u == - atom u => u - u is ['QUOTE,v] => v - systemErrorHere '"optFunctorBodyRequote" - -optFunctorPROGN l == - l is [x,:l'] => - worthlessCode x => optFunctorPROGN l' - l':= optFunctorBody l' - l'=[nil] => [optFunctorBody x] - [optFunctorBody x,:l'] - l - -worthlessCode x == - x is ['COND,:l] and (and/[x is [.,y] and worthlessCode y for x in l]) => true - x is ['PROGN,:l] => (null (l':= optFunctorPROGN l) => true; false) - x is ['LIST] => true - null x => true - false - -cons5(p,l) == - l and (CAAR l = CAR p) => [p,: rest l] - LENGTH l < 5 => [p,:l] - RPLACD(QCDDDDR l,nil) - [p,:l] - --- TrimEnvironment e == --- [TrimLocalEnvironment u for u in e] where --- TrimLocalEnvironment e == --- [TrimContour u for u in e] where --- TrimContour e == --- [u for u in e | Interesting u] where Interesting u == nil --- --clearly a temporary definition - -setVector0(catNames,definition) == - --returns code to set element 0 of the vector - --to the definition of the category - definition:= mkDomainConstructor definition --- If we call addMutableArg this early, then recurise calls to this domain --- (e.g. while testing predicates) will generate new domains => trouble ---definition:= addMutableArg mkDomainConstructor definition - for u in catNames repeat - definition:= [($QuickCode => 'QSETREFV; 'SETELT),u,0,definition] - definition - ---presence of GENSYM in arg-list differentiates mutable-domains --- addMutableArg nameFormer == --- $mutableDomain => --- nameFormer is ['LIST,:.] => [:nameFormer, '(GENSYM)] --- ['APPEND,nameFormer,'(LIST (GENSYM))] --- nameFormer - ---getname D == --- isDomain D or isCategory D => D.0 --- D - -setVector12 args == - --The purpose of this function is to replace place holders - --e.g. argument names or gensyms, by real values - null args => nil - args1:=args2:=args - for u in $extraParms repeat - --A typical element of $extraParms, which is set in - --DomainSubstitutionFunction, would be (gensym) cons - --(category parameter), e.g. DirectProduct(length vl,NNI) - --as in DistributedMultivariatePolynomial - args1:=[CAR u,:args1] - args2:=[CDR u,:args2] - freeof($domainShell.1,args1) and - freeof($domainShell.2,args1) and - freeof($domainShell.4,args1) => nil where freeof(a,b) == - ATOM a => NULL MEMQ(a,b) - freeof(CAR a,b) => freeof(CDR a,b) - false - [['SetDomainSlots124,'$,['QUOTE,args1],['LIST,:args2]]] - -SetDomainSlots124(vec,names,vals) == - l:= PAIR(names,vals) - vec.1:= sublisProp(l,vec.1) - vec.2:= sublisProp(l,vec.2) - l:= [[a,:devaluate b] for a in names for b in vals] - vec.4:= SUBLIS(l,vec.4) - vec.1:= SUBLIS(l,vec.1) - -sublisProp(subst,props) == - null props => nil - [cp,:props']:= props - (a' := inspect(cp,subst)) where - inspect(cp is [a,cond,:l],subst) == - cond=true => cp - --keep original CONS - cond is ['or,:x] => - (or/[inspect(u,subst) for u in x] => [a,true,:l]; nil) - cond is ['has,nam,b] and (val:= ASSQ(nam,subst)) => - ev:= - b is ['ATTRIBUTE,c] => HasAttribute(rest val,c) - b is ['SIGNATURE,c] => HasSignature(rest val,c) - isDomainForm(b,$CategoryFrame) => b=rest val - HasCategory(rest val,b) - ev => [a,true,:l] - nil - cp - not a' => sublisProp(subst,props') - props' := sublisProp(subst,props') - EQ(a',cp) and EQ(props',rest props) => props - [a',:props'] - -setVector3(name,instantiator) == - --generates code to set element 3 of 'name' from 'instantiator' - --element 3 is data structure representing category - --returns a single LISP statement - instantiator is ['DomainSubstitutionMacro,.,body] => setVector3(name,body) - [($QuickCode => 'QSETREFV; 'SETELT),name,3,mkDomainConstructor instantiator] - -mkDomainFormer x == - if x is ['DomainSubstitutionMacro,parms,body] then - x:=DomainSubstitutionFunction(parms,body) - x:=SUBLIS($extraParms,x) - --The next line ensures that only one copy of this structure will - --appear in the BPI being generated, thus saving (some) space - x is ['Join,:.] => ['eval,['QUOTE,x]] - x - -mkDomainConstructor x == - atom x => mkDevaluate x - x is ['Join] => nil - x is ['LIST] => nil - x is ['CATEGORY,:.] => MKQ x - x is ['mkCategory,:.] => MKQ x - x is ['_:,selector,dom] => - ['LIST,MKQ '_:,MKQ selector,mkDomainConstructor dom] - x is ['Record,:argl] => - ['LIST,MKQ 'Record,:[mkDomainConstructor y for y in argl]] - x is ['Join,:argl] => - ['LIST,MKQ 'Join,:[mkDomainConstructor y for y in argl]] - x is ['call,:argl] => ['MKQ, optCall x] - --The previous line added JHD/BMT 20/3/84 - --Necessary for proper compilation of DPOLY SPAD - x is [op] => MKQ x - x is [op,:argl] => ['LIST,MKQ op,:[mkDomainConstructor a for a in argl]] - -setVector4(catNames,catsig,conditions) == - if $HackSlot4 then - for ['LET,name,cond,:.] in $getDomainCode repeat - $HackSlot4:=SUBST(name,cond,$HackSlot4) - code:= ---+ - ['SETELT,'$,4,'TrueDomain] - code:=['(LET TrueDomain (NREVERSE TrueDomain)),:$HackSlot4,code] - code:= - [: - [setVector4Onecat(u,v,w) - for u in catNames for v in catsig for w in conditions],:code] - ['(LET TrueDomain NIL),:code] - -setVector4Onecat(name,instantiator,info) == - --generates code to create one item in the - --Alist representing a domain - --returns a single LISP expression - instantiator is ['DomainSubstitutionMacro,.,body] => - setVector4Onecat(name,body,info) - data:= - --CAR name.4 contains all the names except itself - --hence we need to add this on, by the above CONS - ['CONS,['CONS,mkDomainConstructor instantiator,['CAR,['ELT,name,4]]], - name] - data:= ['SETQ,'TrueDomain,['CONS,data,'TrueDomain]] - TruthP info => data - ['COND,[TryGDC PrepareConditional info,data],: - Supplementaries(instantiator,name)] where - Supplementaries(instantiator,name) == - slist:= - [u for u in $supplementaries | AncestorP(first u,[instantiator])] - null slist => nil - $supplementaries:= S_-($supplementaries,slist) - PRETTYPRINT [instantiator,'" should solve"] - PRETTYPRINT slist - slist:= - [form(u,name) for u in slist] where - form([cat,:cond],name) == - u:= ['QUOTE,[cat,:first (eval cat).4]] - ['COND,[TryGDC cond,['SETQ,'TrueDomain,['CONS,['CONS,u,name], - 'TrueDomain]]]] - LENGTH slist=1 => [CADAR slist] - --return a list, since it is CONSed - slist:= ['PROGN,:slist] - [['(QUOTE T),slist]] - -setVector4part3(catNames,catvecList) == - --the names are those that will be applied to the various vectors - generated:= nil - for u in catvecList for uname in catNames repeat - for v in CADDR u.4 repeat - if w:= ASSOC(first v,generated) - then RPLACD(w,[[rest v,:uname],:rest w]) - else generated:= [[first v,[rest v,:uname]],:generated] - codeList := nil - for [w,:u] in generated repeat - code := compCategories w - for v in u repeat - code:= [($QuickCode => 'QSETREFV; 'SETELT),rest v,first v,code] - if CONTAINED('$,w) then $epilogue := [code,:$epilogue] - else codeList := [code,:codeList] - codeList - -PrepareConditional u == u - -setVector5(catNames,locals) == - generated:= nil - for u in locals for uname in catNames repeat - if w:= ASSOC(u,generated) - then RPLACD(w,[uname,:rest w]) - else generated:= [[u,uname],:generated] - [(w:= mkVectorWithDeferral(first u,first rest u); - for v in rest u repeat - w:= [($QuickCode => 'QSETREFV; 'SETELT),v,5,w]; - w) - for u in generated] - -mkVectorWithDeferral(objects,tag) == --- Basically a mkVector, but spots things that aren't safe to instantiate --- and places them at the end of $ConstantAssignments, so that they get --- called AFTER the constants of $ have been set up. JHD 26.July.89 - ['VECTOR,: - [if CONTAINED('$,u) then -- It's not safe to instantiate this now - $ConstantAssignments:=[:$ConstantAssignments, - [($QuickCode=>'QSETREFV;'SETELT), - [($QuickCode=>'QREFELT;'ELT), tag, 5], - count, - u]] - [] - else u - for u in objects for count in 0..]] - -DescendCodeAdd(base,flag) == - atom base => DescendCodeVarAdd(base,flag) - not (modemap:=get(opOf base,'modemap,$CategoryFrame)) => - if getmode(opOf base,$e) is ["Mapping",target,:formalArgModes] - then formalArgs:= take(#formalArgModes,$FormalMapVariableList) - --argument substitution if parameterized? - - else keyedSystemError("S2OR0001",[opOf base]) - DescendCodeAdd1(base,flag,target,formalArgs,formalArgModes) - for [[[.,:formalArgs],target,:formalArgModes],.] in modemap repeat - (ans:= DescendCodeAdd1(base,flag,target,formalArgs,formalArgModes))=> - return ans - ans - -DescendCodeAdd1(base,flag,target,formalArgs,formalArgModes) == - slist:= pairList(formalArgs,rest $addFormLhs) - --base = comp $addFormLhs-- bound in compAdd - e:= $e - newModes:= SUBLIS(slist,formalArgModes) - or/[not comp(u,m,e) for u in rest $addFormLhs for m in newModes] => - return nil - --I should check that the actual arguments are of the right type - for u in formalArgs for m in newModes repeat - [.,.,e]:= compMakeDeclaration(['_:,u,m],m,e) - --we can not substitute in the formal arguments before we comp - --for that may change the shape of the object, but we must before - --we match signatures - cat:= (compMakeCategoryObject(target,e)).expr - instantiatedBase:= GENVAR() - n:=MAXINDEX cat - code:= - [u - for i in 6..n | not atom cat.i and not atom (sig:= first cat.i) - and - (u:= - SetFunctionSlots(SUBLIS(slist,sig),['ELT,instantiatedBase,i],flag, - 'adding))^=nil] - --The code from here to the end is designed to replace repeated LOAD/STORE - --combinations (SETELT ...(ELT ..)) by MVCs where this is practicable - copyvec:=GETREFV (1+n) - for u in code repeat - if update(u,copyvec,[]) then code:=DELETE(u,code) - where update(code,copyvec,sofar) == - ATOM code =>nil - MEMQ(QCAR code,'(ELT QREFELT)) => - copyvec.(CADDR code):=UNION(copyvec.(CADDR code), sofar) - true - code is [x,name,number,u'] and MEMQ(x,'(SETELT QSETREFV)) => - update(u',copyvec,[[name,:number],:sofar]) - for i in 6..n repeat - for u in copyvec.i repeat - [name,:count]:=u - j:=i+1 - while j<= MIN(n,i+63) and LASSOC(name,copyvec.j) = count+j-i repeat j:=j+1 - --Maximum length of an MVC is 64 words - j:=j-1 - j > i+2 => - for k in i..j repeat copyvec.k:=DELETE([name,:count+k-i],copyvec.k) - code:=[['REPLACE, name, instantiatedBase, - INTERN('"START1",'"KEYWORD"), count, - INTERN('"START2",'"KEYWORD"), i, - INTERN('"END2",'"KEYWORD"), j+1],:code] - copyvec.i => - v:=[($QuickCode => 'QREFELT;'ELT),instantiatedBase,i] - for u in copyvec.i repeat - [name,:count]:=u - v:=[($QuickCode => 'QSETREFV;'SETELT),name,count,v] - code:=[v,:code] - [['LET,instantiatedBase,base],:code] - -DescendCode(code,flag,viewAssoc,EnvToPass) == - -- flag = true if we are walking down code always executed; - -- otherwise set to conditions in which - code=nil => nil - code='noBranch => nil - isMacro(code,$e) => nil --RDJ: added 3/16/83 - code is ['add,base,:codelist] => - codelist:= - [v for u in codelist | (v:= DescendCode(u,flag,viewAssoc,EnvToPass))^=nil] - -- must do this first, to get this overriding Add code - ['PROGN,:DescendCodeAdd(base,flag),:codelist] - code is ['PROGN,:codelist] => - ['PROGN,: - --Two REVERSEs leave original order, but ensure last guy wins - NREVERSE [v for u in REVERSE codelist | - (v:= DescendCode(u,flag,viewAssoc,EnvToPass))^=nil]] - code is ['COND,:condlist] => - c:= [[u2:= ProcessCond(first u,viewAssoc),:q] for u in condlist] where q == - null u2 => nil - f:= - TruthP u2 => flag; - TruthP flag => - flag := ['NOT,u2] - u2 - flag := ['AND,flag,['NOT,u2]]; - ['AND,flag,u2] - [DescendCode(v, f, - if first u is ['HasCategory,dom,cat] - then [[dom,:cat],:viewAssoc] - else viewAssoc,EnvToPass) for v in rest u] - TruthP CAAR c => ['PROGN,:CDAR c] - while (c and (LAST c is [c1] or LAST c is [c1,[]]) and - (c1 = '(QUOTE T) or c1 is ['HasAttribute,:.])) repeat - --strip out some worthless junk at the end - c:=NREVERSE CDR NREVERSE c - null c => '(LIST) - ['COND,:c] - code is ['LET,name,body,:.] => - --only keep the names that are useful - if body is [a,:.] and isFunctor a - then $packagesUsed:=[body,:$packagesUsed] - u:=MEMBER(name,$locals) => - CONTAINED('$,body) and isDomainForm(body,$e) => - --instantiate domains which depend on $ after constants are set - code:=[($QuickCode => 'QSETREFV; 'SETELT),[($QuickCode => 'QREFELT; 'ELT),'$,5],#$locals-#u,code] - $epilogue:= - TruthP flag => [code,:$epilogue] - [['COND,[ProcessCond(flag,viewAssoc),code]],:$epilogue] - nil - code - code -- doItIf deletes entries from $locals so can't optimize this - code is ['CodeDefine,sig,implem] => - --Generated by doIt in COMPILER BOOT - dom:= EnvToPass - dom:= - u:= LASSOC(dom,viewAssoc) => ['getDomainView,dom,u] - dom - body:= ['CONS,implem,dom] - u:= SetFunctionSlots(sig,body,flag,'original) - ConstantCreator u => - if not (flag=true) then u:= ['COND,[ProcessCond(flag,viewAssoc),u]] - $ConstantAssignments:= [u,:$ConstantAssignments] - nil - u - 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 ['devaluate,:.] => nil - code is ['MDEF,:.] => nil - code is ['call,:.] => code - code is ['SETELT,:.] => code -- can be generated by doItIf - code is ['QSETREFV,:.] => code -- can be generated by doItIf - stackWarning ['"unknown Functor code ",code] - code - -ConstantCreator u == - null u => nil - u is [q,.,.,u'] and (q='SETELT or q='QSETREFV) => ConstantCreator u' - u is ['CONS,:.] => nil - true - -ProcessCond(cond,viewassoc) == - ncond := SUBLIS($pairlis,cond) - INTEGERP POSN1(ncond,$NRTslot1PredicateList) => predicateBitRef ncond - cond ---+ -TryGDC cond == - --sees if a condition can be optimised by the use of - --information in $getDomainCode - atom cond => cond - cond is ['HasCategory,:l] => - solved:= nil - for u in $getDomainCode | not solved repeat - if u is ['LET,name, =cond] then solved:= name - solved => solved - cond - cond - -SetFunctionSlots(sig,body,flag,mode) == --mode is either "original" or "adding" ---+ - catNames := ['$] - for u in $catvecList for v in catNames repeat - null body => return NIL - for catImplem in LookUpSigSlots(sig,u.1) repeat - if catImplem is [q,.,index] and (q='ELT or q='CONST) - then - if q is 'CONST and body is ['CONS,a,b] then - body := ['CONS,'IDENTITY,['FUNCALL,a,b]] - body:= [($QuickCode => 'QSETREFV; 'SETELT),v,index,body] - if REFVECP $SetFunctions and TruthP flag then u.index:= true - --used by CheckVector to determine which ops are missing - if v='$ then -- i.e. we are looking at the principal view - not REFVECP $SetFunctions => nil - --packages don't set it - $MissingFunctionInfo.index:= flag - TruthP $SetFunctions.index => (body:= nil; return nil) - -- the function was already assigned - $SetFunctions.index:= - TruthP flag => true - not $SetFunctions.index=>flag --JHD didn't set $SF on this branch - ["or",$SetFunctions.index,flag] - else - if catImplem is ['Subsumed,:truename] - --a special marker generated by SigListUnion - then - if mode='original - then if truename is [fn,:.] and MEMQ(fn,'(Zero One)) - then nil --hack by RDJ 8/90 - else body:= SetFunctionSlots(truename,body,nil,mode) - else nil - else - if not (catImplem is ['PAC,:.]) then - keyedSystemError("S2OR0002",[catImplem]) - body is ['SETELT,:.] => body - body is ['QSETREFV,:.] => body - nil - -LookUpSigSlots(sig,siglist) == ---+ must kill any implementations below of the form (ELT $ NIL) - if $insideCategoryPackageIfTrue then - sig := substitute('$,CADR($functorForm),sig) - siglist := $lisplibOperationAlist - REMDUP [implem for u in siglist | SigSlotsMatch(sig,first u,implem:=CADDR u) - and KADDR implem] - -SigSlotsMatch(sig,pattern,implem) == - sig=pattern => true - not (LENGTH CADR sig=LENGTH CADR pattern) => nil - --CADR sig is the actual signature part - not (first sig=first pattern) => nil - pat' :=SUBSTQ($definition,'$,CADR pattern) - sig' :=SUBSTQ($definition,'$,CADR sig) - sig'=pat' => true - --If we don't have this next test, then we'll recurse in SetFunctionSlots - implem is ['Subsumed,:.] => nil - SourceLevelSubsume(sig',pat') => true - nil - -CheckVector(vec,name,catvecListMaker) == - code:= nil - condAlist := - [[a,:first b] for [.,a,:b] in $getDomainCode] - -- used as substitution alist below - for i in 6..MAXINDEX vec repeat - v:= vec.i - v=true => nil - null v => nil - --a domain, which setVector4part3 will fill in - atom v => systemErrorHere '"CheckVector" - atom first v => - --It's a secondary view of a domain, which we - --must generate code to fill in - for x in $catNames for y in catvecListMaker repeat - if y=v then code:= - [[($QuickCode => 'QSETREFV; 'SETELT),name,i,x],:code] - if name='$ then - ASSOC(first v,$CheckVectorList) => nil - $CheckVectorList:= - [[first v,:makeMissingFunctionEntry(condAlist,i)],:$CheckVectorList] --- MEMBER(first v,$CheckVectorList) => nil --- $CheckVectorList:= [first v,:$CheckVectorList] - code - -makeMissingFunctionEntry(alist,i) == - tran SUBLIS(alist,$MissingFunctionInfo.i) where - tran x == - x is ["HasCategory",a,["QUOTE",b]] => ['has,a,b] - x is [op,:l] and op in '(AND OR NOT) => [op,:[tran y for y in l]] - x - ---% Under what conditions may views exist? - -InvestigateConditions catvecListMaker == - -- given a principal view and a list of secondary views, - -- discover under what conditions the secondary view are - -- always present. - $Conditions: local := nil - $principal: local := nil - [$principal,:secondaries]:= catvecListMaker - --We are not interested in the principal view - --The next block allows for the possibility that $principal may - --have conditional secondary views ---+ - null secondaries => '(T) - --return for packages which generally have no secondary views - if $principal is [op,:.] then - [principal',:.]:=compMakeCategoryObject($principal,$e) - --Rather like eval, but quotes parameters first - for u in CADR principal'.4 repeat - if not TruthP(cond:=CADR u) then - new:=['CATEGORY,'domain,['IF,cond,['ATTRIBUTE,CAR u], 'noBranch]] - $principal is ['Join,:l] => - not MEMBER(new,l) => - $principal:=['Join,:l,new] - $principal:=['Join,$principal,new] - principal' := - pessimise $principal where - pessimise a == - atom a => a - a is ['SIGNATURE,:.] => a - a is ['IF,cond,:.] => - if not MEMBER(cond,$Conditions) then $Conditions:= [cond,:$Conditions] - nil - [pessimise first a,:pessimise rest a] - null $Conditions => [true,:[true for u in secondaries]] - PrincipalSecondaries:= getViewsConditions principal' - MinimalPrimary:= CAR first PrincipalSecondaries - MaximalPrimary:= CAAR $domainShell.4 - necessarySecondaries:= [first u for u in PrincipalSecondaries | rest u=true] - and/[MEMBER(u,necessarySecondaries) for u in secondaries] => - [true,:[true for u in secondaries]] - $HackSlot4:= - MinimalPrimary=MaximalPrimary => nil - MaximalPrimaries:=[MaximalPrimary,:CAR (CatEval MaximalPrimary).4] - MinimalPrimaries:=[MinimalPrimary,:CAR (CatEval MinimalPrimary).4] - MaximalPrimaries:=S_-(MaximalPrimaries,MinimalPrimaries) - [[x] for x in MaximalPrimaries] - ($Conditions:= Conds($principal,nil)) where - Conds(code,previous) == - --each call takes a list of conditions, and returns a list - --of refinements of that list - atom code => [previous] - code is ['DomainSubstitutionMacro,.,b] => Conds(b,previous) - code is ['IF,a,b,c] => UNION(Conds(b,[a,:previous]),Conds(c,previous)) - code is ['PROGN,:l] => "UNION"/[Conds(u,previous) for u in l] - code is ['CATEGORY,:l] => "UNION"/[Conds(u,previous) for u in l] - code is ['Join,:l] => "UNION"/[Conds(u,previous) for u in l] - [previous] - $Conditions:= EFFACE(nil,[EFFACE(nil,u) for u in $Conditions]) - partList:= - [getViewsConditions partPessimise($principal,cond) for cond in $Conditions] - masterSecondaries:= secondaries - for u in partList repeat - for [v,:.] in u repeat - if not MEMBER(v,secondaries) then secondaries:= [v,:secondaries] - --PRETTYPRINT $Conditions - --PRETTYPRINT masterSecondaries - --PRETTYPRINT secondaries - (list:= [mkNilT MEMBER(u,necessarySecondaries) for u in secondaries]) where - mkNilT u == - u => true - nil - for u in $Conditions for newS in partList repeat - --newS is a list of secondaries and conditions (over and above - --u) for which they apply - u:= - LENGTH u=1 => first u - ['AND,:u] - for [v,:.] in newS repeat - for v' in [v,:CAR (CatEval v).4] repeat - if (w:=ASSOC(v',$HackSlot4)) then - RPLAC(rest w,if rest w then mkOr(u,rest w) else u) - (list:= update(list,u,secondaries,newS)) where - update(list,cond,secondaries,newS) == - (list2:= - [flist(sec,newS,old,cond) for sec in secondaries for old in list]) where - flist(sec,newS,old,cond) == - old=true => old - for [newS2,:morecond] in newS repeat - old:= - not AncestorP(sec,[newS2]) => old - cond2:= mkAnd(cond,morecond) - null old => cond2 - mkOr(cond2,old) - old - list2 - list:= [[sec,:ICformat u] for u in list for sec in secondaries] - pv:= getPossibleViews $principal --- $HackSlot4 is used in SetVector4 to ensure that conditional --- extensions of the principal view are handles correctly --- here we build the code necessary to remove spurious extensions - ($HackSlot4:= [reshape u for u in $HackSlot4]) where - reshape u == - ['COND,[TryGDC ICformat rest u], - ['(QUOTE T),['RPLACA,'(CAR TrueDomain), - ['delete,['QUOTE,first u],'(CAAR TrueDomain)]]]] - $supplementaries:= - [u - for u in list | not MEMBER(first u,masterSecondaries) - and not (true=rest u) and not MEMBER(first u,pv)] - [true,:[LASSOC(ms,list) for ms in masterSecondaries]] - -ICformat u == - atom u => u - u is ['has,:.] => compHasFormat u - u is ['AND,:l] or u is ['and,:l] => - l:= REMDUP [ICformat v for [v,:l'] in tails l | not MEMBER(v,l')] - -- we could have duplicates after, even if not before - LENGTH l=1 => first l - l1:= first l - for u in rest l repeat - l1:=mkAnd(u,l1) - l1 - u is ['OR,:l] => - (l:= ORreduce l) where - ORreduce l == - for u in l | u is ['AND,:.] or u is ['and,:.] repeat - --check that B causes (and A B) to go - for v in l | not (v=u) repeat - if MEMBER(v,u) or (and/[MEMBER(w,u) for w in v]) then l:= - DELETE(u,l) - --v subsumes u - --Note that we are ignoring AND as a component. - --Convince yourself that this code still works - l - LENGTH l=1 => ICformat first l - l:= ORreduce REMDUP [ICformat u for u in l] - --causes multiple ANDs to be squashed, etc. - -- and duplicates that have been built up by tidying - (l:= Hasreduce l) where - Hasreduce l == - for u in l | u is ['HasCategory,name,cond] and cond is ['QUOTE, - cond] repeat - --check that v causes descendants to go - for v in l | not (v=u) and v is ['HasCategory, =name,['QUOTE, - cond2]] repeat if DescendantP(cond,cond2) then l:= DELETE(u,l) - --v subsumes u - for u in l | u is ['AND,:l'] or u is ['and,:l'] repeat - for u' in l' | u' is ['HasCategory,name,cond] and cond is ['QUOTE, - cond] repeat - --check that v causes descendants to go - for v in l | v is ['HasCategory, =name,['QUOTE, - cond2]] repeat if DescendantP(cond,cond2) then l:= DELETE(u,l) - --v subsumes u - l - LENGTH l=1 => first l - ['OR,:l] - systemErrorHere '"ICformat" - -partPessimise(a,trueconds) == - atom a => a - a is ['SIGNATURE,:.] => a - a is ['IF,cond,:.] => (MEMBER(cond,trueconds) => a; nil) - [partPessimise(first a,trueconds),:partPessimise(rest a,trueconds)] - -getPossibleViews u == - --returns a list of all the categories that can be views of this one - [vec,:.]:= compMakeCategoryObject(u,$e) or - systemErrorHere '"getPossibleViews" - views:= [first u for u in CADR vec.4] - null vec.0 => [CAAR vec.4,:views] --* - [vec.0,:views] --* - --the two lines marked ensure that the principal view comes first - --if you don't want it, CDR it off - -getViewsConditions u == - - --returns a list of all the categories that can be views of this one - --paired with the condition under which they are such views - [vec,:.]:= compMakeCategoryObject(u,$e) or - systemErrorHere '"getViewsConditions" - views:= [[first u,:CADR u] for u in CADR vec.4] - null vec.0 => ---+ - null CAR vec.4 => views - [[CAAR vec.4,:true],:views] --* - [[vec.0,:true],:views] --* - --the two lines marked ensure that the principal view comes first - --if you don't want it, CDR it off - -DescendCodeVarAdd(base,flag) == - princview := CAR $catvecList - [SetFunctionSlots(sig,SUBST('ELT,'CONST,implem),flag,'adding) repeat - for i in 6..MAXINDEX princview | - princview.i is [sig:=[op,types],:.] and - LASSOC([base,:SUBST(base,'$,types)],get(op,'modemap,$e)) is - [[pred,implem]]] - -resolvePatternVars(p,args) == - p := SUBLISLIS(args, $TriangleVariableList, p) - SUBLISLIS(args, $FormalMapVariableList, p) - ---resolvePatternVars(p,args) == --- atom p => --- isSharpVarWithNum p => args.(position(p,$FormalMapVariableList)) --- p --- [resolvePatternVars(CAR p,args),:resolvePatternVars(CDR p,args)] - --- Mysterious JENKS definition follows: ---DescendCodeVarAdd(base,flag) == --- baseops := [(u:=LASSOC([base,:SUBST(base,'$,types)], --- get(op,'modemap,$e))) and [sig,:u] --- for (sig := [op,types]) in $CheckVectorList] --- $CheckVectorList := [sig for sig in $CheckVectorList --- for op in baseops | null op] --- [SetFunctionSlots(sig,implem,flag,'adding) --- for u in baseops | u is [sig,[pred,implem]]] - -@ -\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 new file mode 100644 index 0000000..3fb5205 --- /dev/null +++ b/src/interp/functor.lisp.pamphlet @@ -0,0 +1,4547 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp functor.lisp} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +<<*>>= +(IN-PACKAGE "BOOT" ) + +;--% Domain printing +;keyItem a == +; isDomain a => CDAR a.4 +; a + +(DEFUN |keyItem| (|a|) + (COND ((|isDomain| |a|) (CDAR (ELT |a| 4))) ('T |a|))) + +; --The item that domain checks on +; +;--Global strategy here is to maintain a list of substitutions +;-- ( %in Sublis), of vectors and the names that they have, +;-- which may be either local names ('View1') or global names ('Where1') +;-- The global names are remembered on $Sublis from one +;-- invocation of DomainPrint1 to the next +; +;DomainPrint(D,brief) == +; -- If brief is non-NIL, %then only a summary is printed +; $WhereList: local := nil +; $Sublis: local := nil +; $WhereCounter: local := nil +; $WhereCounter:= 1 +; env:= +; not BOUNDP '$e => $EmptyEnvironment +; $e='$e => $EmptyEnvironment +; $e --in case we are called from top level +; isCategory D => CategoryPrint(D,env) +; $Sublis:= [[keyItem D,:'original]] +; SAY '"-----------------------------------------------------------------------" +; DomainPrint1(D,NIL,env) +; while ($WhereList) repeat +; s:= $WhereList +; $WhereList:= nil +; for u in s repeat +; TERPRI() +; SAY ['"Where ",first u,'" is:"] +; DomainPrint1(rest u,brief,env) +; SAY '"-----------------------------------------------------------------------" + +(DEFUN |DomainPrint| (D |brief|) + (PROG (|$WhereList| |$Sublis| |$WhereCounter| |env| |s|) + (DECLARE (SPECIAL |$WhereList| |$Sublis| |$WhereCounter|)) + (RETURN + (SEQ (PROGN + (SPADLET |$WhereList| NIL) + (SPADLET |$Sublis| NIL) + (SPADLET |$WhereCounter| NIL) + (SPADLET |$WhereCounter| 1) + (SPADLET |env| + (COND + ((NULL (BOUNDP '|$e|)) |$EmptyEnvironment|) + ((BOOT-EQUAL |$e| '|$e|) |$EmptyEnvironment|) + ('T |$e|))) + (COND + ((|isCategory| D) (|CategoryPrint| D |env|)) + ('T + (SPADLET |$Sublis| + (CONS (CONS (|keyItem| D) '|original|) NIL)) + (SAY (MAKESTRING + "-----------------------------------------------------------------------")) + (|DomainPrint1| D NIL |env|) + (DO () ((NULL |$WhereList|) NIL) + (SEQ (EXIT (PROGN + (SPADLET |s| |$WhereList|) + (SPADLET |$WhereList| NIL) + (DO ((G166083 |s| (CDR G166083)) + (|u| NIL)) + ((OR (ATOM G166083) + (PROGN + (SETQ |u| (CAR G166083)) + NIL)) + NIL) + (SEQ (EXIT + (PROGN + (TERPRI) + (SAY + (CONS (MAKESTRING "Where ") + (CONS (CAR |u|) + (CONS (MAKESTRING " is:") + NIL)))) + (|DomainPrint1| (CDR |u|) + |brief| |env|))))))))) + (SAY (MAKESTRING + "-----------------------------------------------------------------------" + ))))))))) + + +;DomainPrint1(D,brief,$e) == +; REFVECP D and not isDomain D => PacPrint D +; if REFVECP D then D:= D.4 +; --if we were passed a vector, go to the domain +; Sublis:= +; [: +; [[rest u,:INTERNL STRCONC('"View",STRINGIMAGE i)] +; for u in D for i in 1..],:$Sublis] +; for u in D for i in 1.. repeat +; brief and i>1 => nil +; uu:= COPY_-SEQ rest u +; uu.4:= '"This domain" +; if not brief then +; SAY ['"View number ",i,'" corresponding to categories:"] +; PRETTYPRINT first u +; if i=1 and REFVECP uu.5 then +; vv:= COPY_-SEQ uu.5 +; uu.5:= vv +; for j in 0..MAXINDEX vv repeat +; if REFVECP vv.j then +; l:= ASSQ(keyItem vv.j,Sublis) +; if l +; then name:= rest l +; else +; name:=DPname() +; Sublis:= [[keyItem vv.j,:name],:Sublis] +; $Sublis:= [first Sublis,:$Sublis] +; $WhereList:= [[name,:vv.j],:$WhereList] +; vv.j:= name +; if i>1 then +; uu.1:= uu.2:= uu.5:= '"As in first view" +; for i in 6..MAXINDEX uu repeat +; uu.i:= DomainPrintSubst(uu.i,Sublis) +; if REFVECP uu.i then +; name:=DPname() +; Sublis:= [[keyItem uu.i,:name],:Sublis] +; $Sublis:= [first Sublis,:$Sublis] +; $WhereList:= [[name,:uu.i],:$WhereList] +; uu.i:= name +; if uu.i is [.,:v] and REFVECP v then +; name:=DPname() +; Sublis:= [[keyItem v,:name],:Sublis] +; $Sublis:= [first Sublis,:$Sublis] +; $WhereList:= [[name,:v],:$WhereList] +; uu.i:= [first uu.i,:name] +; if brief then PRETTYPRINT uu.0 else PRETTYPRINT uu + +(DEFUN |DomainPrint1| (D |brief| |$e|) + (DECLARE (SPECIAL |$e|)) + (PROG (|uu| |vv| |l| |ISTMP#1| |v| |name| |Sublis|) + (RETURN + (SEQ (COND + ((AND (REFVECP D) (NULL (|isDomain| D))) (|PacPrint| D)) + ('T (COND ((REFVECP D) (SPADLET D (ELT D 4)))) + (SPADLET |Sublis| + (APPEND (PROG (G166124) + (SPADLET G166124 NIL) + (RETURN + (DO + ((G166130 D (CDR G166130)) + (|u| NIL) (|i| 1 (QSADD1 |i|))) + ((OR (ATOM G166130) + (PROGN + (SETQ |u| (CAR G166130)) + NIL)) + (NREVERSE0 G166124)) + (SEQ + (EXIT + (SETQ G166124 + (CONS + (CONS (CDR |u|) + (INTERNL + (STRCONC (MAKESTRING "View") + (STRINGIMAGE |i|)))) + G166124))))))) + |$Sublis|)) + (DO ((G166147 D (CDR G166147)) (|u| NIL) + (|i| 1 (QSADD1 |i|))) + ((OR (ATOM G166147) + (PROGN (SETQ |u| (CAR G166147)) NIL)) + NIL) + (SEQ (EXIT (COND + ((AND |brief| (> |i| 1)) NIL) + ('T (SPADLET |uu| (COPY-SEQ (CDR |u|))) + (SETELT |uu| 4 + (MAKESTRING "This domain")) + (COND + ((NULL |brief|) + (SAY (CONS (MAKESTRING "View number ") + (CONS |i| + (CONS + (MAKESTRING + " corresponding to categories:") + NIL)))) + (PRETTYPRINT (CAR |u|)))) + (COND + ((AND (EQL |i| 1) + (REFVECP (ELT |uu| 5))) + (SPADLET |vv| (COPY-SEQ (ELT |uu| 5))) + (SETELT |uu| 5 |vv|) + (DO ((G166156 (MAXINDEX |vv|)) + (|j| 0 (QSADD1 |j|))) + ((QSGREATERP |j| G166156) NIL) + (SEQ + (EXIT + (COND + ((REFVECP (ELT |vv| |j|)) + (SPADLET |l| + (ASSQ + (|keyItem| (ELT |vv| |j|)) + |Sublis|)) + (COND + (|l| + (SPADLET |name| (CDR |l|))) + ('T + (SPADLET |name| (|DPname|)) + (SPADLET |Sublis| + (CONS + (CONS + (|keyItem| + (ELT |vv| |j|)) + |name|) + |Sublis|)) + (SPADLET |$Sublis| + (CONS (CAR |Sublis|) + |$Sublis|)) + (SPADLET |$WhereList| + (CONS + (CONS |name| + (ELT |vv| |j|)) + |$WhereList|)))) + (SETELT |vv| |j| |name|)) + ('T NIL))))))) + (COND + ((> |i| 1) + (SETELT |uu| 1 + (SETELT |uu| 2 + (SETELT |uu| 5 + (MAKESTRING + "As in first view")))))) + (DO ((G166170 (MAXINDEX |uu|)) + (|i| 6 (+ |i| 1))) + ((> |i| G166170) NIL) + (SEQ (EXIT + (PROGN + (SETELT |uu| |i| + (|DomainPrintSubst| + (ELT |uu| |i|) |Sublis|)) + (COND + ((REFVECP (ELT |uu| |i|)) + (SPADLET |name| (|DPname|)) + (SPADLET |Sublis| + (CONS + (CONS + (|keyItem| + (ELT |uu| |i|)) + |name|) + |Sublis|)) + (SPADLET |$Sublis| + (CONS (CAR |Sublis|) + |$Sublis|)) + (SPADLET |$WhereList| + (CONS + (CONS |name| + (ELT |uu| |i|)) + |$WhereList|)) + (SETELT |uu| |i| |name|))) + (COND + ((AND + (PROGN + (SPADLET |ISTMP#1| + (ELT |uu| |i|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |v| + (QCDR |ISTMP#1|)) + 'T))) + (REFVECP |v|)) + (SPADLET |name| (|DPname|)) + (SPADLET |Sublis| + (CONS + (CONS (|keyItem| |v|) + |name|) + |Sublis|)) + (SPADLET |$Sublis| + (CONS (CAR |Sublis|) + |$Sublis|)) + (SPADLET |$WhereList| + (CONS (CONS |name| |v|) + |$WhereList|)) + (SETELT |uu| |i| + (CONS (CAR (ELT |uu| |i|)) + |name|))) + ('T NIL)))))) + (COND + (|brief| (PRETTYPRINT (ELT |uu| 0))) + ('T (PRETTYPRINT |uu|)))))))))))))) + +;DPname() == +; name:= INTERNL STRCONC('"Where",STRINGIMAGE $WhereCounter) +; $WhereCounter:= $WhereCounter+1 +; name + +(DEFUN |DPname| () + (PROG (|name|) + (RETURN + (PROGN + (SPADLET |name| + (INTERNL (STRCONC (MAKESTRING "Where") + (STRINGIMAGE |$WhereCounter|)))) + (SPADLET |$WhereCounter| (PLUS |$WhereCounter| 1)) + |name|)))) + +;PacPrint v == +; vv:= COPY_-SEQ v +; for j in 0..MAXINDEX vv repeat +; if REFVECP vv.j then +; l:= ASSQ(keyItem vv.j,Sublis) +; if l +; then name:= rest l +; else +; name:=DPname() +; Sublis:= [[keyItem vv.j,:name],:Sublis] +; $Sublis:= [first Sublis,:$Sublis] +; $WhereList:= [[name,:vv.j],:$WhereList] +; vv.j:= name +; if PAIRP vv.j and REFVECP(u:=CDR vv.j) then +; l:= ASSQ(keyItem u,Sublis) +; if l +; then name:= rest l +; else +; name:=DPname() +; Sublis:= [[keyItem u,:name],:Sublis] +; $Sublis:= [first Sublis,:$Sublis] +; $WhereList:= [[name,:u],:$WhereList] +; RPLACD(vv.j,name) +; PRETTYPRINT vv + +(DEFUN |PacPrint| (|v|) + (PROG (|vv| |u| |l| |name| |Sublis|) + (RETURN + (SEQ (PROGN + (SPADLET |vv| (COPY-SEQ |v|)) + (DO ((G166216 (MAXINDEX |vv|)) (|j| 0 (QSADD1 |j|))) + ((QSGREATERP |j| G166216) NIL) + (SEQ (EXIT (PROGN + (COND + ((REFVECP (ELT |vv| |j|)) + (SPADLET |l| + (ASSQ + (|keyItem| (ELT |vv| |j|)) + |Sublis|)) + (COND + (|l| (SPADLET |name| (CDR |l|))) + ('T (SPADLET |name| (|DPname|)) + (SPADLET |Sublis| + (CONS + (CONS + (|keyItem| (ELT |vv| |j|)) + |name|) + |Sublis|)) + (SPADLET |$Sublis| + (CONS (CAR |Sublis|) + |$Sublis|)) + (SPADLET |$WhereList| + (CONS + (CONS |name| + (ELT |vv| |j|)) + |$WhereList|)))) + (SETELT |vv| |j| |name|))) + (COND + ((AND (PAIRP (ELT |vv| |j|)) + (REFVECP + (SPADLET |u| (CDR (ELT |vv| |j|))))) + (SPADLET |l| + (ASSQ (|keyItem| |u|) |Sublis|)) + (COND + (|l| (SPADLET |name| (CDR |l|))) + ('T (SPADLET |name| (|DPname|)) + (SPADLET |Sublis| + (CONS + (CONS (|keyItem| |u|) + |name|) + |Sublis|)) + (SPADLET |$Sublis| + (CONS (CAR |Sublis|) + |$Sublis|)) + (SPADLET |$WhereList| + (CONS (CONS |name| |u|) + |$WhereList|)))) + (RPLACD (ELT |vv| |j|) |name|)) + ('T NIL)))))) + (PRETTYPRINT |vv|)))))) + +;DomainPrintSubst(item,Sublis) == +; item is [a,:b] => +; c1:= DomainPrintSubst(a,Sublis) +; c2:= DomainPrintSubst(b,Sublis) +; EQ(c1,a) and EQ(c2,b) => item +; [c1,:c2] +; l:= ASSQ(item,Sublis) +; l => rest l +; l:= ASSQ(keyItem item,Sublis) +; l => rest l +; item + +(DEFUN |DomainPrintSubst| (|item| |Sublis|) + (PROG (|a| |b| |c1| |c2| |l|) + (RETURN + (COND + ((AND (PAIRP |item|) + (PROGN + (SPADLET |a| (QCAR |item|)) + (SPADLET |b| (QCDR |item|)) + 'T)) + (SPADLET |c1| (|DomainPrintSubst| |a| |Sublis|)) + (SPADLET |c2| (|DomainPrintSubst| |b| |Sublis|)) + (COND + ((AND (EQ |c1| |a|) (EQ |c2| |b|)) |item|) + ('T (CONS |c1| |c2|)))) + ('T (SPADLET |l| (ASSQ |item| |Sublis|)) + (COND + (|l| (CDR |l|)) + ('T (SPADLET |l| (ASSQ (|keyItem| |item|) |Sublis|)) + (COND (|l| (CDR |l|)) ('T |item|))))))))) + +;--% Utilities +; +;mkDevaluate a == +; null a => nil +; a is ['QUOTE,a'] => (a' => a; nil) +; a='$ => MKQ '$ +; a is ['LIST] => nil +; a is ['LIST,:.] => a +; ['devaluate,a] + +(DEFUN |mkDevaluate| (|a|) + (PROG (|ISTMP#1| |a'|) + (RETURN + (COND + ((NULL |a|) NIL) + ((AND (PAIRP |a|) (EQ (QCAR |a|) 'QUOTE) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |a'| (QCAR |ISTMP#1|)) 'T)))) + (COND (|a'| |a|) ('T NIL))) + ((BOOT-EQUAL |a| '$) (MKQ '$)) + ((AND (PAIRP |a|) (EQ (QCDR |a|) NIL) (EQ (QCAR |a|) 'LIST)) + NIL) + ((AND (PAIRP |a|) (EQ (QCAR |a|) 'LIST)) |a|) + ('T (CONS '|devaluate| (CONS |a| NIL))))))) + +;getDomainView(domain,catform) == +; u:= HasCategory(domain,catform) => u +; c:= eval catform +; u:= HasCategory(domain,c.0) => u +; -- note: this is necessary because of domain == another domain, e.g. +; -- Ps are defined to be SUPs with specific arguments so that if one +; -- asks if a P is a Module over itself, here one has catform= (Module +; -- (P I)) yet domain is a SUP. By oding this evaluation, c.0=SUP as +; -- well and test works --- RDJ 10/31/83 +; throwKeyedMsg("S2IF0009",[devaluate domain, catform]) + +(DEFUN |getDomainView| (|domain| |catform|) + (PROG (|c| |u|) + (RETURN + (COND + ((SPADLET |u| (|HasCategory| |domain| |catform|)) |u|) + ('T (SPADLET |c| (|eval| |catform|)) + (COND + ((SPADLET |u| (|HasCategory| |domain| (ELT |c| 0))) |u|) + ('T + (|throwKeyedMsg| 'S2IF0009 + (CONS (|devaluate| |domain|) (CONS |catform| NIL)))))))))) + +;getPrincipalView domain == +; pview:= domain +; for [.,:view] in domain.4 repeat if #view>#pview then pview:= view +; pview + +(DEFUN |getPrincipalView| (|domain|) + (PROG (|view| |pview|) + (RETURN + (SEQ (PROGN + (SPADLET |pview| |domain|) + (DO ((G166277 (ELT |domain| 4) (CDR G166277)) + (G166269 NIL)) + ((OR (ATOM G166277) + (PROGN (SETQ G166269 (CAR G166277)) NIL) + (PROGN + (PROGN + (SPADLET |view| (CDR G166269)) + G166269) + NIL)) + NIL) + (SEQ (EXIT (COND + ((> (|#| |view|) (|#| |pview|)) + (SPADLET |pview| |view|)) + ('T NIL))))) + |pview|))))) + +;CategoriesFromGDC x == +; atom x => nil +; x is ['LIST,a,:b] and a is ['QUOTE,a'] => +; UNION(LIST LIST a',"UNION"/[CategoriesFromGDC u for u in b]) +; x is ['QUOTE,a] and a is [b] => [a] + +(DEFUN |CategoriesFromGDC| (|x|) + (PROG (|a'| |ISTMP#1| |a| |b|) + (RETURN + (SEQ (COND + ((ATOM |x|) NIL) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'LIST) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |b| (QCDR |ISTMP#1|)) + 'T))) + (PAIRP |a|) (EQ (QCAR |a|) 'QUOTE) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |a'| (QCAR |ISTMP#1|)) 'T)))) + (|union| (LIST (LIST |a'|)) + (PROG (G166307) + (SPADLET G166307 NIL) + (RETURN + (DO ((G166312 |b| (CDR G166312)) + (|u| NIL)) + ((OR (ATOM G166312) + (PROGN + (SETQ |u| (CAR G166312)) + NIL)) + G166307) + (SEQ (EXIT (SETQ G166307 + (|union| G166307 + (|CategoriesFromGDC| |u|)))))))))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'QUOTE) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |a| (QCAR |ISTMP#1|)) 'T))) + (PAIRP |a|) (EQ (QCDR |a|) NIL) + (PROGN (SPADLET |b| (QCAR |a|)) 'T)) + (CONS |a| NIL))))))) + +;compCategories u == +; ATOM u => u +; not ATOM first u => +; error ['"compCategories: need an atom in operator position", first u] +; first u = "Record" => +; -- There is no modemap property for these guys so do it by hand. +; [first u, :[[":", a.1, compCategories1(a.2,'(SetCategory))] for a in rest u]] +; first u = "Union" or first u = "Mapping" => +; -- There is no modemap property for these guys so do it by hand. +; [first u, :[compCategories1(a,'(SetCategory)) for a in rest u]] +; u is ['SubDomain,D,.] => compCategories D +; v:=get(first u,'modemap,$e) +; ATOM v => +; error ['"compCategories: could not get proper modemap for operator",first u] +; if rest v then +; sayBrightly ['"compCategories: ", '%b, '"Warning", '%d, +; '"ignoring unexpected stuff at end of modemap"] +; pp rest v +; -- the next line "fixes" a bad modemap which sometimes appears .... +; -- +; if rest v and NULL CAAAR v then v:=CDR v +; v:= CDDAAR v +; v:=resolvePatternVars(v, rest u) -- replaces #n forms +; -- select the modemap part of the first entry, and skip result etc. +; u:=[first u,:[compCategories1(a,b) for a in rest u for b in v]] +; u + +(DEFUN |compCategories| (|u|) + (PROG (|ISTMP#1| D |ISTMP#2| |v|) + (RETURN + (SEQ (COND + ((ATOM |u|) |u|) + ((NULL (ATOM (CAR |u|))) + (|error| (CONS (MAKESTRING + "compCategories: need an atom in operator position") + (CONS (CAR |u|) NIL)))) + ((BOOT-EQUAL (CAR |u|) '|Record|) + (CONS (CAR |u|) + (PROG (G166346) + (SPADLET G166346 NIL) + (RETURN + (DO ((G166351 (CDR |u|) (CDR G166351)) + (|a| NIL)) + ((OR (ATOM G166351) + (PROGN + (SETQ |a| (CAR G166351)) + NIL)) + (NREVERSE0 G166346)) + (SEQ (EXIT (SETQ G166346 + (CONS + (CONS '|:| + (CONS (ELT |a| 1) + (CONS + (|compCategories1| + (ELT |a| 2) + '(|SetCategory|)) + NIL))) + G166346))))))))) + ((OR (BOOT-EQUAL (CAR |u|) '|Union|) + (BOOT-EQUAL (CAR |u|) '|Mapping|)) + (CONS (CAR |u|) + (PROG (G166361) + (SPADLET G166361 NIL) + (RETURN + (DO ((G166366 (CDR |u|) (CDR G166366)) + (|a| NIL)) + ((OR (ATOM G166366) + (PROGN + (SETQ |a| (CAR G166366)) + NIL)) + (NREVERSE0 G166361)) + (SEQ (EXIT (SETQ G166361 + (CONS + (|compCategories1| |a| + '(|SetCategory|)) + G166361))))))))) + ((AND (PAIRP |u|) (EQ (QCAR |u|) '|SubDomain|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |u|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET D (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL)))))) + (|compCategories| D)) + ('T (SPADLET |v| (|get| (CAR |u|) '|modemap| |$e|)) + (COND + ((ATOM |v|) + (|error| (CONS (MAKESTRING + "compCategories: could not get proper modemap for operator") + (CONS (CAR |u|) NIL)))) + ('T + (COND + ((CDR |v|) + (|sayBrightly| + (CONS (MAKESTRING "compCategories: ") + (CONS '|%b| + (CONS (MAKESTRING "Warning") + (CONS '|%d| + (CONS + (MAKESTRING + "ignoring unexpected stuff at end of modemap") + NIL)))))) + (|pp| (CDR |v|)))) + (COND + ((AND (CDR |v|) (NULL (CAAAR |v|))) + (SPADLET |v| (CDR |v|)))) + (SPADLET |v| (CDDAAR |v|)) + (SPADLET |v| (|resolvePatternVars| |v| (CDR |u|))) + (SPADLET |u| + (CONS (CAR |u|) + (PROG (G166377) + (SPADLET G166377 NIL) + (RETURN + (DO + ((G166383 (CDR |u|) + (CDR G166383)) + (|a| NIL) + (G166384 |v| (CDR G166384)) + (|b| NIL)) + ((OR (ATOM G166383) + (PROGN + (SETQ |a| (CAR G166383)) + NIL) + (ATOM G166384) + (PROGN + (SETQ |b| (CAR G166384)) + NIL)) + (NREVERSE0 G166377)) + (SEQ + (EXIT + (SETQ G166377 + (CONS + (|compCategories1| |a| |b|) + G166377))))))))) + |u|)))))))) + +;compCategories1(u,v) == +;-- v is the mode of u +; ATOM u => u +; isCategoryForm(v,$e) => compCategories u +; [c,:.] := comp(macroExpand(u,$e),v,$e) => c +; error 'compCategories1 + +(DEFUN |compCategories1| (|u| |v|) + (PROG (|LETTMP#1| |c|) + (RETURN + (COND + ((ATOM |u|) |u|) + ((|isCategoryForm| |v| |$e|) (|compCategories| |u|)) + ((PROGN + (SPADLET |LETTMP#1| + (|comp| (|macroExpand| |u| |$e|) |v| |$e|)) + (SPADLET |c| (CAR |LETTMP#1|)) + |LETTMP#1|) + |c|) + ('T (|error| '|compCategories1|)))))) + +;NewbFVectorCopy(u,domName) == +; v:= GETREFV SIZE u +; for i in 0..5 repeat v.i:= u.i +; for i in 6..MAXINDEX v | PAIRP u.i repeat v.i:= [Undef,[domName,i],:first u.i] +; v + +(DEFUN |NewbFVectorCopy| (|u| |domName|) + (PROG (|v|) + (RETURN + (SEQ (PROGN + (SPADLET |v| (GETREFV (SIZE |u|))) + (DO ((|i| 0 (QSADD1 |i|))) ((QSGREATERP |i| 5) NIL) + (SEQ (EXIT (SETELT |v| |i| (ELT |u| |i|))))) + (DO ((G166429 (MAXINDEX |v|)) (|i| 6 (+ |i| 1))) + ((> |i| G166429) NIL) + (SEQ (EXIT (COND + ((PAIRP (ELT |u| |i|)) + (SETELT |v| |i| + (CONS |Undef| + (CONS + (CONS |domName| (CONS |i| NIL)) + (CAR (ELT |u| |i|)))))))))) + |v|))))) + +;mkVector u == +; u => ['VECTOR,:u] +; nil + +(DEFUN |mkVector| (|u|) (COND (|u| (CONS 'VECTOR |u|)) ('T NIL))) + +;optFunctorBody x == +; atom x => x +; x is ['QUOTE,:l] => x +; x is ['DomainSubstitutionMacro,parms,body] => +; optFunctorBody DomainSubstitutionFunction(parms,body) +; x is ['LIST,:l] => +; null l => nil +; l:= [optFunctorBody u for u in l] +; and/[optFunctorBodyQuotable u for u in l] => +; ['QUOTE,[optFunctorBodyRequote u for u in l]] +; l=rest x => x --CONS-saving hack +; ['LIST,:l] +; x is ['PROGN,:l] => ['PROGN,:optFunctorPROGN l] +; x is ['COND,:l] => +;--+ +; l:= +; [CondClause u for u in l | u and first u] where +; CondClause [pred,:conseq] == +; [optFunctorBody pred,:optFunctorPROGN conseq] +; l:= EFFACE('((QUOTE T)),l) +; --delete any trailing ("T) +; null l => nil +; CAAR l='(QUOTE T) => +; (null CDAR l => nil; null CDDAR l => CADAR l; ["PROGN",:CDAR l]) +; null rest l and null CDAR l => +; --there is no meat to this COND +; pred:= CAAR l +; atom pred => nil +; first pred="HasCategory" => nil +; ['COND,:l] +; ['COND,:l] +; [optFunctorBody u for u in x] + +(DEFUN |optFunctorBody,CondClause| (G166458) + (PROG (|pred| |conseq|) + (RETURN + (PROGN + (SPADLET |pred| (CAR G166458)) + (SPADLET |conseq| (CDR G166458)) + G166458 + (CONS (|optFunctorBody| |pred|) (|optFunctorPROGN| |conseq|)))))) + +(DEFUN |optFunctorBody| (|x|) + (PROG (|ISTMP#1| |parms| |ISTMP#2| |body| |l| |pred|) + (RETURN + (SEQ (COND + ((ATOM |x|) |x|) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'QUOTE) + (PROGN (SPADLET |l| (QCDR |x|)) 'T)) + |x|) + ((AND (PAIRP |x|) + (EQ (QCAR |x|) '|DomainSubstitutionMacro|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |parms| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |body| (QCAR |ISTMP#2|)) + 'T)))))) + (|optFunctorBody| + (|DomainSubstitutionFunction| |parms| |body|))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'LIST) + (PROGN (SPADLET |l| (QCDR |x|)) 'T)) + (COND + ((NULL |l|) NIL) + ('T + (SPADLET |l| + (PROG (G166481) + (SPADLET G166481 NIL) + (RETURN + (DO ((G166486 |l| (CDR G166486)) + (|u| NIL)) + ((OR (ATOM G166486) + (PROGN + (SETQ |u| (CAR G166486)) + NIL)) + (NREVERSE0 G166481)) + (SEQ (EXIT + (SETQ G166481 + (CONS (|optFunctorBody| |u|) + G166481)))))))) + (COND + ((PROG (G166492) + (SPADLET G166492 'T) + (RETURN + (DO ((G166498 NIL (NULL G166492)) + (G166499 |l| (CDR G166499)) (|u| NIL)) + ((OR G166498 (ATOM G166499) + (PROGN + (SETQ |u| (CAR G166499)) + NIL)) + G166492) + (SEQ (EXIT (SETQ G166492 + (AND G166492 + (|optFunctorBodyQuotable| |u|)))))))) + (CONS 'QUOTE + (CONS (PROG (G166510) + (SPADLET G166510 NIL) + (RETURN + (DO + ((G166515 |l| (CDR G166515)) + (|u| NIL)) + ((OR (ATOM G166515) + (PROGN + (SETQ |u| (CAR G166515)) + NIL)) + (NREVERSE0 G166510)) + (SEQ + (EXIT + (SETQ G166510 + (CONS + (|optFunctorBodyRequote| |u|) + G166510))))))) + NIL))) + ((BOOT-EQUAL |l| (CDR |x|)) |x|) + ('T (CONS 'LIST |l|)))))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'PROGN) + (PROGN (SPADLET |l| (QCDR |x|)) 'T)) + (CONS 'PROGN (|optFunctorPROGN| |l|))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'COND) + (PROGN (SPADLET |l| (QCDR |x|)) 'T)) + (SPADLET |l| + (PROG (G166526) + (SPADLET G166526 NIL) + (RETURN + (DO ((G166532 |l| (CDR G166532)) + (|u| NIL)) + ((OR (ATOM G166532) + (PROGN + (SETQ |u| (CAR G166532)) + NIL)) + (NREVERSE0 G166526)) + (SEQ (EXIT (COND + ((AND |u| (CAR |u|)) + (SETQ G166526 + (CONS + (|optFunctorBody,CondClause| + |u|) + G166526)))))))))) + (SPADLET |l| (EFFACE '('T) |l|)) + (COND + ((NULL |l|) NIL) + ((BOOT-EQUAL (CAAR |l|) ''T) + (COND + ((NULL (CDAR |l|)) NIL) + ((NULL (CDDAR |l|)) (CADAR |l|)) + ('T (CONS 'PROGN (CDAR |l|))))) + ((AND (NULL (CDR |l|)) (NULL (CDAR |l|))) + (SPADLET |pred| (CAAR |l|)) + (COND + ((ATOM |pred|) NIL) + ((BOOT-EQUAL (CAR |pred|) '|HasCategory|) NIL) + ('T (CONS 'COND |l|)))) + ('T (CONS 'COND |l|)))) + ('T + (PROG (G166542) + (SPADLET G166542 NIL) + (RETURN + (DO ((G166547 |x| (CDR G166547)) (|u| NIL)) + ((OR (ATOM G166547) + (PROGN (SETQ |u| (CAR G166547)) NIL)) + (NREVERSE0 G166542)) + (SEQ (EXIT (SETQ G166542 + (CONS (|optFunctorBody| |u|) + G166542))))))))))))) + +;optFunctorBodyQuotable u == +; null u => true +; NUMBERP u => true +; atom u => nil +; u is ['QUOTE,:.] => true +; nil + +(DEFUN |optFunctorBodyQuotable| (|u|) + (COND + ((NULL |u|) 'T) + ((NUMBERP |u|) 'T) + ((ATOM |u|) NIL) + ((AND (PAIRP |u|) (EQ (QCAR |u|) 'QUOTE)) 'T) + ('T NIL))) + +;optFunctorBodyRequote u == +; atom u => u +; u is ['QUOTE,v] => v +; systemErrorHere '"optFunctorBodyRequote" + +(DEFUN |optFunctorBodyRequote| (|u|) + (PROG (|ISTMP#1| |v|) + (RETURN + (COND + ((ATOM |u|) |u|) + ((AND (PAIRP |u|) (EQ (QCAR |u|) 'QUOTE) + (PROGN + (SPADLET |ISTMP#1| (QCDR |u|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |v| (QCAR |ISTMP#1|)) 'T)))) + |v|) + ('T (|systemErrorHere| (MAKESTRING "optFunctorBodyRequote"))))))) + +;optFunctorPROGN l == +; l is [x,:l'] => +; worthlessCode x => optFunctorPROGN l' +; l':= optFunctorBody l' +; l'=[nil] => [optFunctorBody x] +; [optFunctorBody x,:l'] +; l + +(DEFUN |optFunctorPROGN| (|l|) + (PROG (|x| |l'|) + (RETURN + (COND + ((AND (PAIRP |l|) + (PROGN + (SPADLET |x| (QCAR |l|)) + (SPADLET |l'| (QCDR |l|)) + 'T)) + (COND + ((|worthlessCode| |x|) (|optFunctorPROGN| |l'|)) + ('T (SPADLET |l'| (|optFunctorBody| |l'|)) + (COND + ((BOOT-EQUAL |l'| (CONS NIL NIL)) + (CONS (|optFunctorBody| |x|) NIL)) + ('T (CONS (|optFunctorBody| |x|) |l'|)))))) + ('T |l|))))) + +;worthlessCode x == +; x is ['COND,:l] and (and/[x is [.,y] and worthlessCode y for x in l]) => true +; x is ['PROGN,:l] => (null (l':= optFunctorPROGN l) => true; false) +; x is ['LIST] => true +; null x => true +; false + +(DEFUN |worthlessCode| (|x|) + (PROG (|ISTMP#1| |y| |l| |l'|) + (RETURN + (SEQ (COND + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'COND) + (PROGN (SPADLET |l| (QCDR |x|)) 'T) + (PROG (G166604) + (SPADLET G166604 'T) + (RETURN + (DO ((G166614 NIL (NULL G166604)) + (G166615 |l| (CDR G166615)) (|x| NIL)) + ((OR G166614 (ATOM G166615) + (PROGN (SETQ |x| (CAR G166615)) NIL)) + G166604) + (SEQ (EXIT (SETQ G166604 + (AND G166604 + (AND (PAIRP |x|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |y| + (QCAR |ISTMP#1|)) + 'T))) + (|worthlessCode| |y|)))))))))) + 'T) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'PROGN) + (PROGN (SPADLET |l| (QCDR |x|)) 'T)) + (COND + ((NULL (SPADLET |l'| (|optFunctorPROGN| |l|))) 'T) + ('T NIL))) + ((AND (PAIRP |x|) (EQ (QCDR |x|) NIL) + (EQ (QCAR |x|) 'LIST)) + 'T) + ((NULL |x|) 'T) + ('T NIL)))))) + +;cons5(p,l) == +; l and (CAAR l = CAR p) => [p,: rest l] +; LENGTH l < 5 => [p,:l] +; RPLACD(QCDDDDR l,nil) +; [p,:l] + +(DEFUN |cons5| (|p| |l|) + (COND + ((AND |l| (BOOT-EQUAL (CAAR |l|) (CAR |p|))) (CONS |p| (CDR |l|))) + ((QSLESSP (LENGTH |l|) 5) (CONS |p| |l|)) + ('T (RPLACD (QCDDDDR |l|) NIL) (CONS |p| |l|)))) + +;-- TrimEnvironment e == +;-- [TrimLocalEnvironment u for u in e] where +;-- TrimLocalEnvironment e == +;-- [TrimContour u for u in e] where +;-- TrimContour e == +;-- [u for u in e | Interesting u] where Interesting u == nil +;-- --clearly a temporary definition +; +;setVector0(catNames,definition) == +; --returns code to set element 0 of the vector +; --to the definition of the category +; definition:= mkDomainConstructor definition +;-- If we call addMutableArg this early, then recurise calls to this domain +;-- (e.g. while testing predicates) will generate new domains => trouble +;--definition:= addMutableArg mkDomainConstructor definition +; for u in catNames repeat +; definition:= [($QuickCode => 'QSETREFV; 'SETELT),u,0,definition] +; definition + +(DEFUN |setVector0| (|catNames| |definition|) + (SEQ (PROGN + (SPADLET |definition| (|mkDomainConstructor| |definition|)) + (DO ((G166640 |catNames| (CDR G166640)) (|u| NIL)) + ((OR (ATOM G166640) + (PROGN (SETQ |u| (CAR G166640)) NIL)) + NIL) + (SEQ (EXIT (SPADLET |definition| + (CONS (COND + (|$QuickCode| 'QSETREFV) + ('T 'SETELT)) + (CONS |u| + (CONS 0 (CONS |definition| NIL)))))))) + |definition|))) + +;--presence of GENSYM in arg-list differentiates mutable-domains +;-- addMutableArg nameFormer == +;-- $mutableDomain => +;-- nameFormer is ['LIST,:.] => [:nameFormer, '(GENSYM)] +;-- ['APPEND,nameFormer,'(LIST (GENSYM))] +;-- nameFormer +; +;--getname D == +;-- isDomain D or isCategory D => D.0 +;-- D +; +;setVector12 args == +; --The purpose of this function is to replace place holders +; --e.g. argument names or gensyms, by real values +; null args => nil +; args1:=args2:=args +; for u in $extraParms repeat +; --A typical element of $extraParms, which is set in +; --DomainSubstitutionFunction, would be (gensym) cons +; --(category parameter), e.g. DirectProduct(length vl,NNI) +; --as in DistributedMultivariatePolynomial +; args1:=[CAR u,:args1] +; args2:=[CDR u,:args2] +; freeof($domainShell.1,args1) and +; freeof($domainShell.2,args1) and +; freeof($domainShell.4,args1) => nil where freeof(a,b) == +; ATOM a => NULL MEMQ(a,b) +; freeof(CAR a,b) => freeof(CDR a,b) +; false +; [['SetDomainSlots124,'$,['QUOTE,args1],['LIST,:args2]]] + +(DEFUN |setVector12,freeof| (|a| |b|) + (SEQ (IF (ATOM |a|) (EXIT (NULL (MEMQ |a| |b|)))) + (IF (|setVector12,freeof| (CAR |a|) |b|) + (EXIT (|setVector12,freeof| (CDR |a|) |b|))) + (EXIT NIL))) + + +(DEFUN |setVector12| (|args|) + (PROG (|args1| |args2|) + (RETURN + (SEQ (COND + ((NULL |args|) NIL) + ('T (SPADLET |args1| (SPADLET |args2| |args|)) + (DO ((G166663 |$extraParms| (CDR G166663)) (|u| NIL)) + ((OR (ATOM G166663) + (PROGN (SETQ |u| (CAR G166663)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |args1| (CONS (CAR |u|) |args1|)) + (SPADLET |args2| (CONS (CDR |u|) |args2|)))))) + (COND + ((AND (|setVector12,freeof| (ELT |$domainShell| 1) + |args1|) + (|setVector12,freeof| (ELT |$domainShell| 2) + |args1|) + (|setVector12,freeof| (ELT |$domainShell| 4) + |args1|)) + NIL) + ('T + (CONS (CONS '|SetDomainSlots124| + (CONS '$ + (CONS + (CONS 'QUOTE (CONS |args1| NIL)) + (CONS (CONS 'LIST |args2|) NIL)))) + NIL))))))))) + +;SetDomainSlots124(vec,names,vals) == +; l:= PAIR(names,vals) +; vec.1:= sublisProp(l,vec.1) +; vec.2:= sublisProp(l,vec.2) +; l:= [[a,:devaluate b] for a in names for b in vals] +; vec.4:= SUBLIS(l,vec.4) +; vec.1:= SUBLIS(l,vec.1) + +(DEFUN |SetDomainSlots124| (|vec| |names| |vals|) + (PROG (|l|) + (RETURN + (SEQ (PROGN + (SPADLET |l| (PAIR |names| |vals|)) + (SETELT |vec| 1 (|sublisProp| |l| (ELT |vec| 1))) + (SETELT |vec| 2 (|sublisProp| |l| (ELT |vec| 2))) + (SPADLET |l| + (PROG (G166682) + (SPADLET G166682 NIL) + (RETURN + (DO ((G166688 |names| (CDR G166688)) + (|a| NIL) + (G166689 |vals| (CDR G166689)) + (|b| NIL)) + ((OR (ATOM G166688) + (PROGN + (SETQ |a| (CAR G166688)) + NIL) + (ATOM G166689) + (PROGN + (SETQ |b| (CAR G166689)) + NIL)) + (NREVERSE0 G166682)) + (SEQ (EXIT (SETQ G166682 + (CONS + (CONS |a| (|devaluate| |b|)) + G166682)))))))) + (SETELT |vec| 4 (SUBLIS |l| (ELT |vec| 4))) + (SETELT |vec| 1 (SUBLIS |l| (ELT |vec| 1)))))))) + +;sublisProp(subst,props) == +; null props => nil +; [cp,:props']:= props +; (a' := inspect(cp,subst)) where +; inspect(cp is [a,cond,:l],subst) == +; cond=true => cp +; --keep original CONS +; cond is ['or,:x] => +; (or/[inspect(u,subst) for u in x] => [a,true,:l]; nil) +; cond is ['has,nam,b] and (val:= ASSQ(nam,subst)) => +; ev:= +; b is ['ATTRIBUTE,c] => HasAttribute(rest val,c) +; b is ['SIGNATURE,c] => HasSignature(rest val,c) +; isDomainForm(b,$CategoryFrame) => b=rest val +; HasCategory(rest val,b) +; ev => [a,true,:l] +; nil +; cp +; not a' => sublisProp(subst,props') +; props' := sublisProp(subst,props') +; EQ(a',cp) and EQ(props',rest props) => props +; [a',:props'] + +(DEFUN |sublisProp,inspect| (|cp| |subst|) + (PROG (|a| |cond| |l| |x| |nam| |ISTMP#2| |b| |val| |ISTMP#1| |c| + |ev|) + (RETURN + (SEQ (PROGN + (SPADLET |a| (CAR |cp|)) + (SPADLET |cond| (CADR |cp|)) + (SPADLET |l| (CDDR |cp|)) + |cp| + (SEQ (IF (BOOT-EQUAL |cond| 'T) (EXIT |cp|)) + (IF (AND (PAIRP |cond|) (EQ (QCAR |cond|) '|or|) + (PROGN (SPADLET |x| (QCDR |cond|)) 'T)) + (EXIT (SEQ (IF (PROG (G166762) + (SPADLET G166762 NIL) + (RETURN + (DO + ((G166768 NIL G166762) + (G166769 |x| + (CDR G166769)) + (|u| NIL)) + ((OR G166768 + (ATOM G166769) + (PROGN + (SETQ |u| + (CAR G166769)) + NIL)) + G166762) + (SEQ + (EXIT + (SETQ G166762 + (OR G166762 + (|sublisProp,inspect| + |u| |subst|)))))))) + (EXIT (CONS |a| (CONS 'T |l|)))) + (EXIT NIL)))) + (IF (AND (AND (PAIRP |cond|) + (EQ (QCAR |cond|) '|has|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |cond|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |nam| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |b| + (QCAR |ISTMP#2|)) + 'T)))))) + (SPADLET |val| (ASSQ |nam| |subst|))) + (EXIT (SEQ (SPADLET |ev| + (SEQ + (IF + (AND (PAIRP |b|) + (EQ (QCAR |b|) 'ATTRIBUTE) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |b|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) + NIL) + (PROGN + (SPADLET |c| + (QCAR |ISTMP#1|)) + 'T)))) + (EXIT + (|HasAttribute| + (CDR |val|) |c|))) + (IF + (AND (PAIRP |b|) + (EQ (QCAR |b|) 'SIGNATURE) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |b|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) + NIL) + (PROGN + (SPADLET |c| + (QCAR |ISTMP#1|)) + 'T)))) + (EXIT + (|HasSignature| + (CDR |val|) |c|))) + (IF + (|isDomainForm| |b| + |$CategoryFrame|) + (EXIT + (BOOT-EQUAL |b| + (CDR |val|)))) + (EXIT + (|HasCategory| (CDR |val|) + |b|)))) + (IF |ev| + (EXIT (CONS |a| (CONS 'T |l|)))) + (EXIT NIL)))) + (EXIT |cp|))))))) + +(DEFUN |sublisProp| (|subst| |props|) + (PROG (|cp| |a'| |props'|) + (RETURN + (COND + ((NULL |props|) NIL) + ('T (SPADLET |cp| (CAR |props|)) + (SPADLET |props'| (CDR |props|)) + (SPADLET |a'| (|sublisProp,inspect| |cp| |subst|)) + (COND + ((NULL |a'|) (|sublisProp| |subst| |props'|)) + ('T (SPADLET |props'| (|sublisProp| |subst| |props'|)) + (COND + ((AND (EQ |a'| |cp|) (EQ |props'| (CDR |props|))) + |props|) + ('T (CONS |a'| |props'|)))))))))) + +;setVector3(name,instantiator) == +; --generates code to set element 3 of 'name' from 'instantiator' +; --element 3 is data structure representing category +; --returns a single LISP statement +; instantiator is ['DomainSubstitutionMacro,.,body] => setVector3(name,body) +; [($QuickCode => 'QSETREFV; 'SETELT),name,3,mkDomainConstructor instantiator] + +(DEFUN |setVector3| (|name| |instantiator|) + (PROG (|ISTMP#1| |ISTMP#2| |body|) + (RETURN + (COND + ((AND (PAIRP |instantiator|) + (EQ (QCAR |instantiator|) '|DomainSubstitutionMacro|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |instantiator|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |body| (QCAR |ISTMP#2|)) + 'T)))))) + (|setVector3| |name| |body|)) + ('T + (CONS (COND (|$QuickCode| 'QSETREFV) ('T 'SETELT)) + (CONS |name| + (CONS 3 + (CONS (|mkDomainConstructor| |instantiator|) + NIL))))))))) + +;mkDomainFormer x == +; if x is ['DomainSubstitutionMacro,parms,body] then +; x:=DomainSubstitutionFunction(parms,body) +; x:=SUBLIS($extraParms,x) +; --The next line ensures that only one copy of this structure will +; --appear in the BPI being generated, thus saving (some) space +; x is ['Join,:.] => ['eval,['QUOTE,x]] +; x + +(DEFUN |mkDomainFormer| (|x|) + (PROG (|ISTMP#1| |parms| |ISTMP#2| |body|) + (RETURN + (PROGN + (COND + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|DomainSubstitutionMacro|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |parms| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |body| (QCAR |ISTMP#2|)) + 'T)))))) + (SPADLET |x| (|DomainSubstitutionFunction| |parms| |body|)) + (SPADLET |x| (SUBLIS |$extraParms| |x|)))) + (COND + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|Join|)) + (CONS '|eval| (CONS (CONS 'QUOTE (CONS |x| NIL)) NIL))) + ('T |x|)))))) + +;mkDomainConstructor x == +; atom x => mkDevaluate x +; x is ['Join] => nil +; x is ['LIST] => nil +; x is ['CATEGORY,:.] => MKQ x +; x is ['mkCategory,:.] => MKQ x +; x is ['_:,selector,dom] => +; ['LIST,MKQ '_:,MKQ selector,mkDomainConstructor dom] +; x is ['Record,:argl] => +; ['LIST,MKQ 'Record,:[mkDomainConstructor y for y in argl]] +; x is ['Join,:argl] => +; ['LIST,MKQ 'Join,:[mkDomainConstructor y for y in argl]] +; x is ['call,:argl] => ['MKQ, optCall x] +; --The previous line added JHD/BMT 20/3/84 +; --Necessary for proper compilation of DPOLY SPAD +; x is [op] => MKQ x +; x is [op,:argl] => ['LIST,MKQ op,:[mkDomainConstructor a for a in argl]] + +(DEFUN |mkDomainConstructor| (|x|) + (PROG (|ISTMP#1| |selector| |ISTMP#2| |dom| |op| |argl|) + (RETURN + (SEQ (COND + ((ATOM |x|) (|mkDevaluate| |x|)) + ((AND (PAIRP |x|) (EQ (QCDR |x|) NIL) + (EQ (QCAR |x|) '|Join|)) + NIL) + ((AND (PAIRP |x|) (EQ (QCDR |x|) NIL) + (EQ (QCAR |x|) 'LIST)) + NIL) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'CATEGORY)) (MKQ |x|)) + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|mkCategory|)) + (MKQ |x|)) + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|:|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |selector| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |dom| (QCAR |ISTMP#2|)) + 'T)))))) + (CONS 'LIST + (CONS (MKQ '|:|) + (CONS (MKQ |selector|) + (CONS (|mkDomainConstructor| |dom|) + NIL))))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|Record|) + (PROGN (SPADLET |argl| (QCDR |x|)) 'T)) + (CONS 'LIST + (CONS (MKQ '|Record|) + (PROG (G166872) + (SPADLET G166872 NIL) + (RETURN + (DO ((G166877 |argl| (CDR G166877)) + (|y| NIL)) + ((OR (ATOM G166877) + (PROGN + (SETQ |y| (CAR G166877)) + NIL)) + (NREVERSE0 G166872)) + (SEQ (EXIT + (SETQ G166872 + (CONS + (|mkDomainConstructor| |y|) + G166872)))))))))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|Join|) + (PROGN (SPADLET |argl| (QCDR |x|)) 'T)) + (CONS 'LIST + (CONS (MKQ '|Join|) + (PROG (G166887) + (SPADLET G166887 NIL) + (RETURN + (DO ((G166892 |argl| (CDR G166892)) + (|y| NIL)) + ((OR (ATOM G166892) + (PROGN + (SETQ |y| (CAR G166892)) + NIL)) + (NREVERSE0 G166887)) + (SEQ (EXIT + (SETQ G166887 + (CONS + (|mkDomainConstructor| |y|) + G166887)))))))))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|call|) + (PROGN (SPADLET |argl| (QCDR |x|)) 'T)) + (CONS 'MKQ (CONS (|optCall| |x|) NIL))) + ((AND (PAIRP |x|) (EQ (QCDR |x|) NIL) + (PROGN (SPADLET |op| (QCAR |x|)) 'T)) + (MKQ |x|)) + ((AND (PAIRP |x|) + (PROGN + (SPADLET |op| (QCAR |x|)) + (SPADLET |argl| (QCDR |x|)) + 'T)) + (CONS 'LIST + (CONS (MKQ |op|) + (PROG (G166902) + (SPADLET G166902 NIL) + (RETURN + (DO ((G166907 |argl| (CDR G166907)) + (|a| NIL)) + ((OR (ATOM G166907) + (PROGN + (SETQ |a| (CAR G166907)) + NIL)) + (NREVERSE0 G166902)) + (SEQ (EXIT + (SETQ G166902 + (CONS + (|mkDomainConstructor| |a|) + G166902))))))))))))))) + +;setVector4(catNames,catsig,conditions) == +; if $HackSlot4 then +; for ['LET,name,cond,:.] in $getDomainCode repeat +; $HackSlot4:=SUBST(name,cond,$HackSlot4) +; code:= +;--+ +; ['SETELT,'$,4,'TrueDomain] +; code:=['(LET TrueDomain (NREVERSE TrueDomain)),:$HackSlot4,code] +; code:= +; [: +; [setVector4Onecat(u,v,w) +; for u in catNames for v in catsig for w in conditions],:code] +; ['(LET TrueDomain NIL),:code] + +(DEFUN |setVector4| (|catNames| |catsig| |conditions|) + (PROG (|name| |cond| |code|) + (RETURN + (SEQ (PROGN + (COND + (|$HackSlot4| + (DO ((G166938 |$getDomainCode| (CDR G166938)) + (G166929 NIL)) + ((OR (ATOM G166938) + (PROGN + (SETQ G166929 (CAR G166938)) + NIL) + (PROGN + (PROGN + (SPADLET |name| (CADR G166929)) + (SPADLET |cond| (CADDR G166929)) + G166929) + NIL)) + NIL) + (SEQ (EXIT (SPADLET |$HackSlot4| + (MSUBST |name| |cond| + |$HackSlot4|))))))) + (SPADLET |code| + (CONS 'SETELT + (CONS '$ (CONS 4 (CONS '|TrueDomain| NIL))))) + (SPADLET |code| + (CONS '(LET |TrueDomain| + (NREVERSE |TrueDomain|)) + (APPEND |$HackSlot4| (CONS |code| NIL)))) + (SPADLET |code| + (APPEND (PROG (G166951) + (SPADLET G166951 NIL) + (RETURN + (DO ((G166958 |catNames| + (CDR G166958)) + (|u| NIL) + (G166959 |catsig| + (CDR G166959)) + (|v| NIL) + (G166960 |conditions| + (CDR G166960)) + (|w| NIL)) + ((OR (ATOM G166958) + (PROGN + (SETQ |u| (CAR G166958)) + NIL) + (ATOM G166959) + (PROGN + (SETQ |v| (CAR G166959)) + NIL) + (ATOM G166960) + (PROGN + (SETQ |w| (CAR G166960)) + NIL)) + (NREVERSE0 G166951)) + (SEQ + (EXIT + (SETQ G166951 + (CONS + (|setVector4Onecat| |u| |v| + |w|) + G166951))))))) + |code|)) + (CONS '(LET |TrueDomain| NIL) |code|)))))) + +;setVector4Onecat(name,instantiator,info) == +; --generates code to create one item in the +; --Alist representing a domain +; --returns a single LISP expression +; instantiator is ['DomainSubstitutionMacro,.,body] => +; setVector4Onecat(name,body,info) +; data:= +; --CAR name.4 contains all the names except itself +; --hence we need to add this on, by the above CONS +; ['CONS,['CONS,mkDomainConstructor instantiator,['CAR,['ELT,name,4]]], +; name] +; data:= ['SETQ,'TrueDomain,['CONS,data,'TrueDomain]] +; TruthP info => data +; ['COND,[TryGDC PrepareConditional info,data],: +; Supplementaries(instantiator,name)] where +; Supplementaries(instantiator,name) == +; slist:= +; [u for u in $supplementaries | AncestorP(first u,[instantiator])] +; null slist => nil +; $supplementaries:= S_-($supplementaries,slist) +; PRETTYPRINT [instantiator,'" should solve"] +; PRETTYPRINT slist +; slist:= +; [form(u,name) for u in slist] where +; form([cat,:cond],name) == +; u:= ['QUOTE,[cat,:first (eval cat).4]] +; ['COND,[TryGDC cond,['SETQ,'TrueDomain,['CONS,['CONS,u,name], +; 'TrueDomain]]]] +; LENGTH slist=1 => [CADAR slist] +; --return a list, since it is CONSed +; slist:= ['PROGN,:slist] +; [['(QUOTE T),slist]] + +(DEFUN |setVector4Onecat,form| (G166993 |name|) + (PROG (|cat| |cond| |u|) + (RETURN + (SEQ (PROGN + (SPADLET |cat| (CAR G166993)) + (SPADLET |cond| (CDR G166993)) + G166993 + (SEQ (SPADLET |u| + (CONS 'QUOTE + (CONS (CONS |cat| + (CAR (ELT (|eval| |cat|) 4))) + NIL))) + (EXIT (CONS 'COND + (CONS (CONS (|TryGDC| |cond|) + (CONS + (CONS 'SETQ + (CONS '|TrueDomain| + (CONS + (CONS 'CONS + (CONS + (CONS 'CONS + (CONS |u| + (CONS |name| NIL))) + (CONS '|TrueDomain| NIL))) + NIL))) + NIL)) + NIL))))))))) + +(DEFUN |setVector4Onecat,Supplementaries| (|instantiator| |name|) + (PROG (|slist|) + (RETURN + (SEQ (SPADLET |slist| + (PROG (G167015) + (SPADLET G167015 NIL) + (RETURN + (DO ((G167021 |$supplementaries| + (CDR G167021)) + (|u| NIL)) + ((OR (ATOM G167021) + (PROGN + (SETQ |u| (CAR G167021)) + NIL)) + (NREVERSE0 G167015)) + (SEQ (EXIT (COND + ((|AncestorP| (CAR |u|) + (CONS |instantiator| NIL)) + (SETQ G167015 + (CONS |u| G167015)))))))))) + (IF (NULL |slist|) (EXIT NIL)) + (SPADLET |$supplementaries| (S- |$supplementaries| |slist|)) + (PRETTYPRINT + (CONS |instantiator| + (CONS (MAKESTRING " should solve") NIL))) + (PRETTYPRINT |slist|) + (SPADLET |slist| + (PROG (G167031) + (SPADLET G167031 NIL) + (RETURN + (DO ((G167036 |slist| (CDR G167036)) + (|u| NIL)) + ((OR (ATOM G167036) + (PROGN + (SETQ |u| (CAR G167036)) + NIL)) + (NREVERSE0 G167031)) + (SEQ (EXIT (SETQ G167031 + (CONS + (|setVector4Onecat,form| |u| + |name|) + G167031)))))))) + (IF (EQL (LENGTH |slist|) 1) + (EXIT (CONS (CADAR |slist|) NIL))) + (SPADLET |slist| (CONS 'PROGN |slist|)) + (EXIT (CONS (CONS ''T (CONS |slist| NIL)) NIL)))))) + +(DEFUN |setVector4Onecat| (|name| |instantiator| |info|) + (PROG (|ISTMP#1| |ISTMP#2| |body| |data|) + (RETURN + (COND + ((AND (PAIRP |instantiator|) + (EQ (QCAR |instantiator|) '|DomainSubstitutionMacro|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |instantiator|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |body| (QCAR |ISTMP#2|)) + 'T)))))) + (|setVector4Onecat| |name| |body| |info|)) + ('T + (SPADLET |data| + (CONS 'CONS + (CONS (CONS 'CONS + (CONS + (|mkDomainConstructor| + |instantiator|) + (CONS + (CONS 'CAR + (CONS + (CONS 'ELT + (CONS |name| (CONS 4 NIL))) + NIL)) + NIL))) + (CONS |name| NIL)))) + (SPADLET |data| + (CONS 'SETQ + (CONS '|TrueDomain| + (CONS (CONS 'CONS + (CONS |data| + (CONS '|TrueDomain| NIL))) + NIL)))) + (COND + ((|TruthP| |info|) |data|) + ('T + (CONS 'COND + (CONS (CONS (|TryGDC| (|PrepareConditional| |info|)) + (CONS |data| NIL)) + (|setVector4Onecat,Supplementaries| + |instantiator| |name|)))))))))) + +;setVector4part3(catNames,catvecList) == +; --the names are those that will be applied to the various vectors +; generated:= nil +; for u in catvecList for uname in catNames repeat +; for v in CADDR u.4 repeat +; if w:= ASSOC(first v,generated) +; then RPLACD(w,[[rest v,:uname],:rest w]) +; else generated:= [[first v,[rest v,:uname]],:generated] +; codeList := nil +; for [w,:u] in generated repeat +; code := compCategories w +; for v in u repeat +; code:= [($QuickCode => 'QSETREFV; 'SETELT),rest v,first v,code] +; if CONTAINED('$,w) then $epilogue := [code,:$epilogue] +; else codeList := [code,:codeList] +; codeList + +(DEFUN |setVector4part3| (|catNames| |catvecList|) + (PROG (|generated| |w| |u| |code| |codeList|) + (RETURN + (SEQ (PROGN + (SPADLET |generated| NIL) + (DO ((G167072 |catvecList| (CDR G167072)) (|u| NIL) + (G167073 |catNames| (CDR G167073)) (|uname| NIL)) + ((OR (ATOM G167072) + (PROGN (SETQ |u| (CAR G167072)) NIL) + (ATOM G167073) + (PROGN (SETQ |uname| (CAR G167073)) NIL)) + NIL) + (SEQ (EXIT (DO ((G167085 (CADDR (ELT |u| 4)) + (CDR G167085)) + (|v| NIL)) + ((OR (ATOM G167085) + (PROGN + (SETQ |v| (CAR G167085)) + NIL)) + NIL) + (SEQ (EXIT (COND + ((SPADLET |w| + (|assoc| (CAR |v|) + |generated|)) + (RPLACD |w| + (CONS + (CONS (CDR |v|) |uname|) + (CDR |w|)))) + ('T + (SPADLET |generated| + (CONS + (CONS (CAR |v|) + (CONS + (CONS (CDR |v|) |uname|) + NIL)) + |generated|)))))))))) + (SPADLET |codeList| NIL) + (DO ((G167098 |generated| (CDR G167098)) + (G167063 NIL)) + ((OR (ATOM G167098) + (PROGN (SETQ G167063 (CAR G167098)) NIL) + (PROGN + (PROGN + (SPADLET |w| (CAR G167063)) + (SPADLET |u| (CDR G167063)) + G167063) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |code| (|compCategories| |w|)) + (DO ((G167108 |u| (CDR G167108)) + (|v| NIL)) + ((OR (ATOM G167108) + (PROGN + (SETQ |v| (CAR G167108)) + NIL)) + NIL) + (SEQ (EXIT + (SPADLET |code| + (CONS + (COND + (|$QuickCode| 'QSETREFV) + ('T 'SETELT)) + (CONS (CDR |v|) + (CONS (CAR |v|) + (CONS |code| NIL)))))))) + (COND + ((CONTAINED '$ |w|) + (SPADLET |$epilogue| + (CONS |code| |$epilogue|))) + ('T + (SPADLET |codeList| + (CONS |code| |codeList|)))))))) + |codeList|))))) + +;PrepareConditional u == u + +(DEFUN |PrepareConditional| (|u|) |u|) + +;setVector5(catNames,locals) == +; generated:= nil +; for u in locals for uname in catNames repeat +; if w:= ASSOC(u,generated) +; then RPLACD(w,[uname,:rest w]) +; else generated:= [[u,uname],:generated] +; [(w:= mkVectorWithDeferral(first u,first rest u); +; for v in rest u repeat +; w:= [($QuickCode => 'QSETREFV; 'SETELT),v,5,w]; +; w) +; for u in generated] + +(DEFUN |setVector5| (|catNames| |locals|) + (PROG (|generated| |w|) + (RETURN + (SEQ (PROGN + (SPADLET |generated| NIL) + (DO ((G167137 |locals| (CDR G167137)) (|u| NIL) + (G167138 |catNames| (CDR G167138)) (|uname| NIL)) + ((OR (ATOM G167137) + (PROGN (SETQ |u| (CAR G167137)) NIL) + (ATOM G167138) + (PROGN (SETQ |uname| (CAR G167138)) NIL)) + NIL) + (SEQ (EXIT (COND + ((SPADLET |w| (|assoc| |u| |generated|)) + (RPLACD |w| (CONS |uname| (CDR |w|)))) + ('T + (SPADLET |generated| + (CONS + (CONS |u| (CONS |uname| NIL)) + |generated|))))))) + (PROG (G167154) + (SPADLET G167154 NIL) + (RETURN + (DO ((G167162 |generated| (CDR G167162)) + (|u| NIL)) + ((OR (ATOM G167162) + (PROGN (SETQ |u| (CAR G167162)) NIL)) + (NREVERSE0 G167154)) + (SEQ (EXIT (SETQ G167154 + (CONS + (PROGN + (SPADLET |w| + (|mkVectorWithDeferral| + (CAR |u|) (CAR (CDR |u|)))) + (DO + ((G167171 (CDR |u|) + (CDR G167171)) + (|v| NIL)) + ((OR (ATOM G167171) + (PROGN + (SETQ |v| (CAR G167171)) + NIL)) + NIL) + (SEQ + (EXIT + (SPADLET |w| + (CONS + (COND + (|$QuickCode| 'QSETREFV) + ('T 'SETELT)) + (CONS |v| + (CONS 5 (CONS |w| NIL)))))))) + |w|) + G167154)))))))))))) + +;mkVectorWithDeferral(objects,tag) == +;-- Basically a mkVector, but spots things that aren't safe to instantiate +;-- and places them at the end of $ConstantAssignments, so that they get +;-- called AFTER the constants of $ have been set up. JHD 26.July.89 +; ['VECTOR,: +; [if CONTAINED('$,u) then -- It's not safe to instantiate this now +; $ConstantAssignments:=[:$ConstantAssignments, +; [($QuickCode=>'QSETREFV;'SETELT), +; [($QuickCode=>'QREFELT;'ELT), tag, 5], +; count, +; u]] +; [] +; else u +; for u in objects for count in 0..]] + +(DEFUN |mkVectorWithDeferral| (|objects| |tag|) + (PROG () + (RETURN + (SEQ (CONS 'VECTOR + (PROG (G167194) + (SPADLET G167194 NIL) + (RETURN + (DO ((G167200 |objects| (CDR G167200)) + (|u| NIL) (|count| 0 (QSADD1 |count|))) + ((OR (ATOM G167200) + (PROGN (SETQ |u| (CAR G167200)) NIL)) + (NREVERSE0 G167194)) + (SEQ (EXIT (SETQ G167194 + (CONS + (COND + ((CONTAINED '$ |u|) + (SPADLET + |$ConstantAssignments| + (APPEND + |$ConstantAssignments| + (CONS + (CONS + (COND + (|$QuickCode| + 'QSETREFV) + ('T 'SETELT)) + (CONS + (CONS + (COND + (|$QuickCode| + 'QREFELT) + ('T 'ELT)) + (CONS |tag| + (CONS 5 NIL))) + (CONS |count| + (CONS |u| NIL)))) + NIL))) + NIL) + ('T |u|)) + G167194)))))))))))) + +;DescendCodeAdd(base,flag) == +; atom base => DescendCodeVarAdd(base,flag) +; not (modemap:=get(opOf base,'modemap,$CategoryFrame)) => +; if getmode(opOf base,$e) is ["Mapping",target,:formalArgModes] +; then formalArgs:= take(#formalArgModes,$FormalMapVariableList) +; --argument substitution if parameterized? +; +; else keyedSystemError("S2OR0001",[opOf base]) +; DescendCodeAdd1(base,flag,target,formalArgs,formalArgModes) +; for [[[.,:formalArgs],target,:formalArgModes],.] in modemap repeat +; (ans:= DescendCodeAdd1(base,flag,target,formalArgs,formalArgModes))=> +; return ans +; ans + +(DEFUN |DescendCodeAdd| (|base| |flag|) + (PROG (|modemap| |ISTMP#1| |ISTMP#2| |formalArgs| |target| + |formalArgModes| |ans|) + (RETURN + (SEQ (COND + ((ATOM |base|) (|DescendCodeVarAdd| |base| |flag|)) + ((NULL (SPADLET |modemap| + (|get| (|opOf| |base|) '|modemap| + |$CategoryFrame|))) + (COND + ((PROGN + (SPADLET |ISTMP#1| (|getmode| (|opOf| |base|) |$e|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|Mapping|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |target| (QCAR |ISTMP#2|)) + (SPADLET |formalArgModes| + (QCDR |ISTMP#2|)) + 'T))))) + (SPADLET |formalArgs| + (TAKE (|#| |formalArgModes|) + |$FormalMapVariableList|))) + ('T + (|keyedSystemError| 'S2OR0001 + (CONS (|opOf| |base|) NIL)))) + (|DescendCodeAdd1| |base| |flag| |target| |formalArgs| + |formalArgModes|)) + ('T + (SEQ (DO ((G167237 |modemap| (CDR G167237)) + (G167227 NIL)) + ((OR (ATOM G167237) + (PROGN + (SETQ G167227 (CAR G167237)) + NIL) + (PROGN + (PROGN + (SPADLET |formalArgs| + (CDAAR G167227)) + (SPADLET |target| (CADAR G167227)) + (SPADLET |formalArgModes| + (CDDAR G167227)) + G167227) + NIL)) + NIL) + (SEQ (EXIT (COND + ((SPADLET |ans| + (|DescendCodeAdd1| |base| |flag| + |target| |formalArgs| + |formalArgModes|)) + (EXIT (RETURN |ans|))))))) + (EXIT |ans|)))))))) + +;DescendCodeAdd1(base,flag,target,formalArgs,formalArgModes) == +; slist:= pairList(formalArgs,rest $addFormLhs) +; --base = comp $addFormLhs-- bound in compAdd +; e:= $e +; newModes:= SUBLIS(slist,formalArgModes) +; or/[not comp(u,m,e) for u in rest $addFormLhs for m in newModes] => +; return nil +; --I should check that the actual arguments are of the right type +; for u in formalArgs for m in newModes repeat +; [.,.,e]:= compMakeDeclaration(['_:,u,m],m,e) +; --we can not substitute in the formal arguments before we comp +; --for that may change the shape of the object, but we must before +; --we match signatures +; cat:= (compMakeCategoryObject(target,e)).expr +; instantiatedBase:= GENVAR() +; n:=MAXINDEX cat +; code:= +; [u +; for i in 6..n | not atom cat.i and not atom (sig:= first cat.i) +; and +; (u:= +; SetFunctionSlots(SUBLIS(slist,sig),['ELT,instantiatedBase,i],flag, +; 'adding))^=nil] +; --The code from here to the end is designed to replace repeated LOAD/STORE +; --combinations (SETELT ...(ELT ..)) by MVCs where this is practicable +; copyvec:=GETREFV (1+n) +; for u in code repeat +; if update(u,copyvec,[]) then code:=DELETE(u,code) +; where update(code,copyvec,sofar) == +; ATOM code =>nil +; MEMQ(QCAR code,'(ELT QREFELT)) => +; copyvec.(CADDR code):=UNION(copyvec.(CADDR code), sofar) +; true +; code is [x,name,number,u'] and MEMQ(x,'(SETELT QSETREFV)) => +; update(u',copyvec,[[name,:number],:sofar]) +; for i in 6..n repeat +; for u in copyvec.i repeat +; [name,:count]:=u +; j:=i+1 +; while j<= MIN(n,i+63) and LASSOC(name,copyvec.j) = count+j-i repeat j:=j+1 +; --Maximum length of an MVC is 64 words +; j:=j-1 +; j > i+2 => +; for k in i..j repeat copyvec.k:=DELETE([name,:count+k-i],copyvec.k) +; code:=[['REPLACE, name, instantiatedBase, +; INTERN('"START1",'"KEYWORD"), count, +; INTERN('"START2",'"KEYWORD"), i, +; INTERN('"END2",'"KEYWORD"), j+1],:code] +; copyvec.i => +; v:=[($QuickCode => 'QREFELT;'ELT),instantiatedBase,i] +; for u in copyvec.i repeat +; [name,:count]:=u +; v:=[($QuickCode => 'QSETREFV;'SETELT),name,count,v] +; code:=[v,:code] +; [['LET,instantiatedBase,base],:code] + +(DEFUN |DescendCodeAdd1,update| (|code| |copyvec| |sofar|) + (PROG (|x| |ISTMP#1| |name| |ISTMP#2| |number| |ISTMP#3| |u'|) + (RETURN + (SEQ (IF (ATOM |code|) (EXIT NIL)) + (IF (MEMQ (QCAR |code|) '(ELT QREFELT)) + (EXIT (SEQ (SETELT |copyvec| (CADDR |code|) + (|union| (ELT |copyvec| + (CADDR |code|)) + |sofar|)) + (EXIT 'T)))) + (EXIT (IF (AND (AND (PAIRP |code|) + (PROGN + (SPADLET |x| (QCAR |code|)) + (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 |number| + (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |u'| + (QCAR |ISTMP#3|)) + 'T)))))))) + (MEMQ |x| '(SETELT QSETREFV))) + (EXIT (|DescendCodeAdd1,update| |u'| |copyvec| + (CONS (CONS |name| |number|) |sofar|))))))))) + + +(DEFUN |DescendCodeAdd1| + (|base| |flag| |target| |formalArgs| |formalArgModes|) + (PROG (|slist| |newModes| |LETTMP#1| |e| |cat| |instantiatedBase| |n| + |sig| |u| |copyvec| |j| |name| |count| |v| |code|) + (RETURN + (SEQ (PROGN + (SPADLET |slist| + (|pairList| |formalArgs| (CDR |$addFormLhs|))) + (SPADLET |e| |$e|) + (SPADLET |newModes| (SUBLIS |slist| |formalArgModes|)) + (COND + ((PROG (G167334) + (SPADLET G167334 NIL) + (RETURN + (DO ((G167341 NIL G167334) + (G167342 (CDR |$addFormLhs|) + (CDR G167342)) + (|u| NIL) + (G167343 |newModes| (CDR G167343)) + (|m| NIL)) + ((OR G167341 (ATOM G167342) + (PROGN (SETQ |u| (CAR G167342)) NIL) + (ATOM G167343) + (PROGN (SETQ |m| (CAR G167343)) NIL)) + G167334) + (SEQ (EXIT (SETQ G167334 + (OR G167334 + (NULL (|comp| |u| |m| |e|))))))))) + (RETURN NIL)) + ('T + (DO ((G167360 |formalArgs| (CDR G167360)) (|u| NIL) + (G167361 |newModes| (CDR G167361)) (|m| NIL)) + ((OR (ATOM G167360) + (PROGN (SETQ |u| (CAR G167360)) NIL) + (ATOM G167361) + (PROGN (SETQ |m| (CAR G167361)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |LETTMP#1| + (|compMakeDeclaration| + (CONS '|:| + (CONS |u| (CONS |m| NIL))) + |m| |e|)) + (SPADLET |e| (CADDR |LETTMP#1|)) + |LETTMP#1|)))) + (SPADLET |cat| + (CAR (|compMakeCategoryObject| |target| |e|))) + (SPADLET |instantiatedBase| (GENVAR)) + (SPADLET |n| (MAXINDEX |cat|)) + (SPADLET |code| + (PROG (G167375) + (SPADLET G167375 NIL) + (RETURN + (DO ((|i| 6 (+ |i| 1))) + ((> |i| |n|) (NREVERSE0 G167375)) + (SEQ (EXIT + (COND + ((AND + (NULL (ATOM (ELT |cat| |i|))) + (NULL + (ATOM + (SPADLET |sig| + (CAR (ELT |cat| |i|))))) + (NEQUAL + (SPADLET |u| + (|SetFunctionSlots| + (SUBLIS |slist| |sig|) + (CONS 'ELT + (CONS |instantiatedBase| + (CONS |i| NIL))) + |flag| '|adding|)) + NIL)) + (SETQ G167375 + (CONS |u| G167375)))))))))) + (SPADLET |copyvec| (GETREFV (PLUS 1 |n|))) + (DO ((G167387 |code| (CDR G167387)) (|u| NIL)) + ((OR (ATOM G167387) + (PROGN (SETQ |u| (CAR G167387)) NIL)) + NIL) + (SEQ (EXIT (COND + ((|DescendCodeAdd1,update| |u| |copyvec| + NIL) + (SPADLET |code| (|delete| |u| |code|))) + ('T NIL))))) + (DO ((|i| 6 (+ |i| 1))) ((> |i| |n|) NIL) + (SEQ (EXIT (PROGN + (DO ((G167426 (ELT |copyvec| |i|) + (CDR G167426)) + (|u| NIL)) + ((OR (ATOM G167426) + (PROGN + (SETQ |u| (CAR G167426)) + NIL)) + NIL) + (SEQ (EXIT + (PROGN + (SPADLET |name| (CAR |u|)) + (SPADLET |count| (CDR |u|)) + (SPADLET |j| (PLUS |i| 1)) + (DO () + ((NULL + (AND + (<= |j| + (MIN |n| (PLUS |i| 63))) + (BOOT-EQUAL + (LASSOC |name| + (ELT |copyvec| |j|)) + (SPADDIFFERENCE + (PLUS |count| |j|) |i|)))) + NIL) + (SEQ + (EXIT + (SPADLET |j| (PLUS |j| 1))))) + (SPADLET |j| + (SPADDIFFERENCE |j| 1)) + (COND + ((> |j| (PLUS |i| 2)) + (PROGN + (DO ((|k| |i| (+ |k| 1))) + ((> |k| |j|) NIL) + (SEQ + (EXIT + (SETELT |copyvec| |k| + (|delete| + (CONS |name| + (SPADDIFFERENCE + (PLUS |count| + |k|) + |i|)) + (ELT |copyvec| |k|)))))) + (SPADLET |code| + (CONS + (CONS 'REPLACE + (CONS |name| + (CONS + |instantiatedBase| + (CONS + (INTERN + (MAKESTRING + "START1") + (MAKESTRING + "KEYWORD")) + (CONS |count| + (CONS + (INTERN + (MAKESTRING + "START2") + (MAKESTRING + "KEYWORD")) + (CONS |i| + (CONS + (INTERN + (MAKESTRING + "END2") + (MAKESTRING + "KEYWORD")) + (CONS + (PLUS |j| 1) + NIL))))))))) + |code|))))))))) + (COND + ((ELT |copyvec| |i|) + (PROGN + (SPADLET |v| + (CONS + (COND + (|$QuickCode| 'QREFELT) + ('T 'ELT)) + (CONS |instantiatedBase| + (CONS |i| NIL)))) + (DO + ((G167450 (ELT |copyvec| |i|) + (CDR G167450)) + (|u| NIL)) + ((OR (ATOM G167450) + (PROGN + (SETQ |u| (CAR G167450)) + NIL)) + NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |name| (CAR |u|)) + (SPADLET |count| (CDR |u|)) + (SPADLET |v| + (CONS + (COND + (|$QuickCode| 'QSETREFV) + ('T 'SETELT)) + (CONS |name| + (CONS |count| + (CONS |v| NIL))))))))) + (SPADLET |code| (CONS |v| |code|))))))))) + (CONS (CONS 'LET + (CONS |instantiatedBase| (CONS |base| NIL))) + |code|)))))))) + +;DescendCode(code,flag,viewAssoc,EnvToPass) == +; -- flag = true if we are walking down code always executed; +; -- otherwise set to conditions in which +; code=nil => nil +; code='noBranch => nil +; isMacro(code,$e) => nil --RDJ: added 3/16/83 +; code is ['add,base,:codelist] => +; codelist:= +; [v for u in codelist | (v:= DescendCode(u,flag,viewAssoc,EnvToPass))^=nil] +; -- must do this first, to get this overriding Add code +; ['PROGN,:DescendCodeAdd(base,flag),:codelist] +; code is ['PROGN,:codelist] => +; ['PROGN,: +; --Two REVERSEs leave original order, but ensure last guy wins +; NREVERSE [v for u in REVERSE codelist | +; (v:= DescendCode(u,flag,viewAssoc,EnvToPass))^=nil]] +; code is ['COND,:condlist] => +; c:= [[u2:= ProcessCond(first u,viewAssoc),:q] for u in condlist] where q == +; null u2 => nil +; f:= +; TruthP u2 => flag; +; TruthP flag => +; flag := ['NOT,u2] +; u2 +; flag := ['AND,flag,['NOT,u2]]; +; ['AND,flag,u2] +; [DescendCode(v, f, +; if first u is ['HasCategory,dom,cat] +; then [[dom,:cat],:viewAssoc] +; else viewAssoc,EnvToPass) for v in rest u] +; TruthP CAAR c => ['PROGN,:CDAR c] +; while (c and (LAST c is [c1] or LAST c is [c1,[]]) and +; (c1 = '(QUOTE T) or c1 is ['HasAttribute,:.])) repeat +; --strip out some worthless junk at the end +; c:=NREVERSE CDR NREVERSE c +; null c => '(LIST) +; ['COND,:c] +; code is ['LET,name,body,:.] => +; --only keep the names that are useful +; if body is [a,:.] and isFunctor a +; then $packagesUsed:=[body,:$packagesUsed] +; u:=MEMBER(name,$locals) => +; CONTAINED('$,body) and isDomainForm(body,$e) => +; --instantiate domains which depend on $ after constants are set +; code:=[($QuickCode => 'QSETREFV; 'SETELT),[($QuickCode => 'QREFELT; 'ELT),'$,5],#$locals-#u,code] +; $epilogue:= +; TruthP flag => [code,:$epilogue] +; [['COND,[ProcessCond(flag,viewAssoc),code]],:$epilogue] +; nil +; code +; code -- doItIf deletes entries from $locals so can't optimize this +; code is ['CodeDefine,sig,implem] => +; --Generated by doIt in COMPILER BOOT +; dom:= EnvToPass +; dom:= +; u:= LASSOC(dom,viewAssoc) => ['getDomainView,dom,u] +; dom +; body:= ['CONS,implem,dom] +; u:= SetFunctionSlots(sig,body,flag,'original) +; ConstantCreator u => +; if not (flag=true) then u:= ['COND,[ProcessCond(flag,viewAssoc),u]] +; $ConstantAssignments:= [u,:$ConstantAssignments] +; nil +; u +; 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 ['devaluate,:.] => nil +; code is ['MDEF,:.] => nil +; code is ['call,:.] => code +; code is ['SETELT,:.] => code -- can be generated by doItIf +; code is ['QSETREFV,:.] => code -- can be generated by doItIf +; stackWarning ['"unknown Functor code ",code] +; code + +(DEFUN |DescendCode| (|code| |flag| |viewAssoc| |EnvToPass|) + (PROG (|base| |codelist| |v| |condlist| |u2| |f| |ISTMP#3| |cat| |c1| + |c| |name| |a| |ISTMP#1| |sig| |ISTMP#2| |implem| |dom| + |body| |u|) + (RETURN + (SEQ (COND + ((NULL |code|) NIL) + ((BOOT-EQUAL |code| '|noBranch|) NIL) + ((|isMacro| |code| |$e|) 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)))) + (SPADLET |codelist| + (PROG (G167595) + (SPADLET G167595 NIL) + (RETURN + (DO ((G167601 |codelist| (CDR G167601)) + (|u| NIL)) + ((OR (ATOM G167601) + (PROGN + (SETQ |u| (CAR G167601)) + NIL)) + (NREVERSE0 G167595)) + (SEQ (EXIT (COND + ((NEQUAL + (SPADLET |v| + (|DescendCode| |u| |flag| + |viewAssoc| |EnvToPass|)) + NIL) + (SETQ G167595 + (CONS |v| G167595)))))))))) + (CONS 'PROGN + (APPEND (|DescendCodeAdd| |base| |flag|) + |codelist|))) + ((AND (PAIRP |code|) (EQ (QCAR |code|) 'PROGN) + (PROGN (SPADLET |codelist| (QCDR |code|)) 'T)) + (CONS 'PROGN + (NREVERSE + (PROG (G167612) + (SPADLET G167612 NIL) + (RETURN + (DO ((G167618 (REVERSE |codelist|) + (CDR G167618)) + (|u| NIL)) + ((OR (ATOM G167618) + (PROGN + (SETQ |u| (CAR G167618)) + NIL)) + (NREVERSE0 G167612)) + (SEQ (EXIT + (COND + ((NEQUAL + (SPADLET |v| + (|DescendCode| |u| |flag| + |viewAssoc| |EnvToPass|)) + NIL) + (SETQ G167612 + (CONS |v| G167612)))))))))))) + ((AND (PAIRP |code|) (EQ (QCAR |code|) 'COND) + (PROGN (SPADLET |condlist| (QCDR |code|)) 'T)) + (SPADLET |c| + (PROG (G167637) + (SPADLET G167637 NIL) + (RETURN + (DO ((G167651 |condlist| (CDR G167651)) + (|u| NIL)) + ((OR (ATOM G167651) + (PROGN + (SETQ |u| (CAR G167651)) + NIL)) + (NREVERSE0 G167637)) + (SEQ (EXIT (SETQ G167637 + (CONS + (CONS + (SPADLET |u2| + (|ProcessCond| (CAR |u|) + |viewAssoc|)) + (COND + ((NULL |u2|) NIL) + ('T + (SPADLET |f| + (COND + ((|TruthP| |u2|) + |flag|) + ((|TruthP| |flag|) + (SPADLET |flag| + (CONS 'NOT + (CONS |u2| NIL))) + |u2|) + ('T + (SPADLET |flag| + (CONS 'AND + (CONS |flag| + (CONS + (CONS 'NOT + (CONS |u2| NIL)) + NIL)))) + (CONS 'AND + (CONS |flag| + (CONS |u2| NIL)))))) + (PROG (G167670) + (SPADLET G167670 NIL) + (RETURN + (DO + ((G167684 + (CDR |u|) + (CDR G167684)) + (|v| NIL)) + ((OR + (ATOM G167684) + (PROGN + (SETQ |v| + (CAR G167684)) + NIL)) + (NREVERSE0 + G167670)) + (SEQ + (EXIT + (SETQ G167670 + (CONS + (|DescendCode| + |v| |f| + (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|)) + |EnvToPass|) + G167670)))))))))) + G167637)))))))) + (COND + ((|TruthP| (CAAR |c|)) (CONS 'PROGN (CDAR |c|))) + ('T + (DO () + ((NULL (AND |c| + (OR (PROGN + (SPADLET |ISTMP#1| (|last| |c|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |c1| + (QCAR |ISTMP#1|)) + 'T))) + (PROGN + (SPADLET |ISTMP#1| (|last| |c|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |c1| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (NULL (QCAR |ISTMP#2|))))))) + (OR (BOOT-EQUAL |c1| ''T) + (AND (PAIRP |c1|) + (EQ (QCAR |c1|) '|HasAttribute|))))) + NIL) + (SEQ (EXIT (SPADLET |c| + (NREVERSE (CDR (NREVERSE |c|))))))) + (COND ((NULL |c|) '(LIST)) ('T (CONS 'COND |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 + ((AND (PAIRP |body|) + (PROGN (SPADLET |a| (QCAR |body|)) 'T) + (|isFunctor| |a|)) + (SPADLET |$packagesUsed| + (CONS |body| |$packagesUsed|)))) + (COND + ((SPADLET |u| (|member| |name| |$locals|)) + (COND + ((AND (CONTAINED '$ |body|) + (|isDomainForm| |body| |$e|)) + (SPADLET |code| + (CONS (COND + (|$QuickCode| 'QSETREFV) + ('T 'SETELT)) + (CONS + (CONS + (COND + (|$QuickCode| 'QREFELT) + ('T 'ELT)) + (CONS '$ (CONS 5 NIL))) + (CONS + (SPADDIFFERENCE (|#| |$locals|) + (|#| |u|)) + (CONS |code| NIL))))) + (SPADLET |$epilogue| + (COND + ((|TruthP| |flag|) + (CONS |code| |$epilogue|)) + ('T + (CONS (CONS 'COND + (CONS + (CONS + (|ProcessCond| |flag| + |viewAssoc|) + (CONS |code| NIL)) + NIL)) + |$epilogue|)))) + NIL) + ('T |code|))) + ('T |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| |EnvToPass|) + (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)))) + (SPADLET |u| + (|SetFunctionSlots| |sig| |body| |flag| + '|original|)) + (COND + ((|ConstantCreator| |u|) + (COND + ((NULL (BOOT-EQUAL |flag| 'T)) + (SPADLET |u| + (CONS 'COND + (CONS + (CONS + (|ProcessCond| |flag| |viewAssoc|) + (CONS |u| NIL)) + NIL))))) + (SPADLET |$ConstantAssignments| + (CONS |u| |$ConstantAssignments|)) + NIL) + ('T |u|))) + ((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|) '|devaluate|)) NIL) + ((AND (PAIRP |code|) (EQ (QCAR |code|) 'MDEF)) 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 (MAKESTRING "unknown Functor code ") + (CONS |code| NIL))) + |code|)))))) + +;ConstantCreator u == +; null u => nil +; u is [q,.,.,u'] and (q='SETELT or q='QSETREFV) => ConstantCreator u' +; u is ['CONS,:.] => nil +; true + +(DEFUN |ConstantCreator| (|u|) + (PROG (|q| |ISTMP#1| |ISTMP#2| |ISTMP#3| |u'|) + (RETURN + (COND + ((NULL |u|) NIL) + ((AND (PAIRP |u|) + (PROGN + (SPADLET |q| (QCAR |u|)) + (SPADLET |ISTMP#1| (QCDR |u|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |u'| (QCAR |ISTMP#3|)) + 'T))))))) + (OR (BOOT-EQUAL |q| 'SETELT) (BOOT-EQUAL |q| 'QSETREFV))) + (|ConstantCreator| |u'|)) + ((AND (PAIRP |u|) (EQ (QCAR |u|) 'CONS)) NIL) + ('T 'T))))) + +;ProcessCond(cond,viewassoc) == +; ncond := SUBLIS($pairlis,cond) +; INTEGERP POSN1(ncond,$NRTslot1PredicateList) => predicateBitRef ncond +; cond + +(DEFUN |ProcessCond| (|cond| |viewassoc|) + (PROG (|ncond|) + (RETURN + (PROGN + (SPADLET |ncond| (SUBLIS |$pairlis| |cond|)) + (COND + ((INTEGERP (POSN1 |ncond| |$NRTslot1PredicateList|)) + (|predicateBitRef| |ncond|)) + ('T |cond|)))))) + +;--+ +;TryGDC cond == +; --sees if a condition can be optimised by the use of +; --information in $getDomainCode +; atom cond => cond +; cond is ['HasCategory,:l] => +; solved:= nil +; for u in $getDomainCode | not solved repeat +; if u is ['LET,name, =cond] then solved:= name +; solved => solved +; cond +; cond + +(DEFUN |TryGDC| (|cond|) + (PROG (|l| |ISTMP#1| |name| |ISTMP#2| |solved|) + (RETURN + (SEQ (COND + ((ATOM |cond|) |cond|) + ((AND (PAIRP |cond|) (EQ (QCAR |cond|) '|HasCategory|) + (PROGN (SPADLET |l| (QCDR |cond|)) 'T)) + (SPADLET |solved| NIL) + (DO ((G167813 |$getDomainCode| (CDR G167813)) + (|u| NIL)) + ((OR (ATOM G167813) + (PROGN (SETQ |u| (CAR G167813)) NIL)) + NIL) + (SEQ (EXIT (COND + ((NULL |solved|) + (COND + ((AND (PAIRP |u|) (EQ (QCAR |u|) 'LET) + (PROGN + (SPADLET |ISTMP#1| (QCDR |u|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |name| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (EQUAL (QCAR |ISTMP#2|) + |cond|)))))) + (SPADLET |solved| |name|)) + ('T NIL))))))) + (COND (|solved| |solved|) ('T |cond|))) + ('T |cond|)))))) + +;SetFunctionSlots(sig,body,flag,mode) == --mode is either "original" or "adding" +;--+ +; catNames := ['$] +; for u in $catvecList for v in catNames repeat +; null body => return NIL +; for catImplem in LookUpSigSlots(sig,u.1) repeat +; if catImplem is [q,.,index] and (q='ELT or q='CONST) +; then +; if q is 'CONST and body is ['CONS,a,b] then +; body := ['CONS,'IDENTITY,['FUNCALL,a,b]] +; body:= [($QuickCode => 'QSETREFV; 'SETELT),v,index,body] +; if REFVECP $SetFunctions and TruthP flag then u.index:= true +; --used by CheckVector to determine which ops are missing +; if v='$ then -- i.e. we are looking at the principal view +; not REFVECP $SetFunctions => nil +; --packages don't set it +; $MissingFunctionInfo.index:= flag +; TruthP $SetFunctions.index => (body:= nil; return nil) +; -- the function was already assigned +; $SetFunctions.index:= +; TruthP flag => true +; not $SetFunctions.index=>flag --JHD didn't set $SF on this branch +; ["or",$SetFunctions.index,flag] +; else +; if catImplem is ['Subsumed,:truename] +; --a special marker generated by SigListUnion +; then +; if mode='original +; then if truename is [fn,:.] and MEMQ(fn,'(Zero One)) +; then nil --hack by RDJ 8/90 +; else body:= SetFunctionSlots(truename,body,nil,mode) +; else nil +; else +; if not (catImplem is ['PAC,:.]) then +; keyedSystemError("S2OR0002",[catImplem]) +; body is ['SETELT,:.] => body +; body is ['QSETREFV,:.] => body +; nil + +(DEFUN |SetFunctionSlots| (|sig| |body| |flag| |mode|) + (PROG (|catNames| |q| |index| |ISTMP#1| |a| |ISTMP#2| |b| |truename| + |fn|) + (RETURN + (SEQ (PROGN + (SPADLET |catNames| (CONS '$ NIL)) + (DO ((G167890 |$catvecList| (CDR G167890)) (|u| NIL) + (G167891 |catNames| (CDR G167891)) (|v| NIL)) + ((OR (ATOM G167890) + (PROGN (SETQ |u| (CAR G167890)) NIL) + (ATOM G167891) + (PROGN (SETQ |v| (CAR G167891)) NIL)) + NIL) + (SEQ (EXIT (COND + ((NULL |body|) (RETURN NIL)) + ('T + (DO ((G167921 + (|LookUpSigSlots| |sig| + (ELT |u| 1)) + (CDR G167921)) + (|catImplem| NIL)) + ((OR (ATOM G167921) + (PROGN + (SETQ |catImplem| + (CAR G167921)) + NIL)) + NIL) + (SEQ (EXIT + (COND + ((AND (PAIRP |catImplem|) + (PROGN + (SPADLET |q| + (QCAR |catImplem|)) + (SPADLET |ISTMP#1| + (QCDR |catImplem|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) + NIL) + (PROGN + (SPADLET |index| + (QCAR |ISTMP#2|)) + 'T))))) + (OR (BOOT-EQUAL |q| 'ELT) + (BOOT-EQUAL |q| 'CONST))) + (COND + ((AND (EQ |q| 'CONST) + (PAIRP |body|) + (EQ (QCAR |body|) 'CONS) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |body|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) + NIL) + (PROGN + (SPADLET |b| + (QCAR |ISTMP#2|)) + 'T)))))) + (SPADLET |body| + (CONS 'CONS + (CONS 'IDENTITY + (CONS + (CONS 'FUNCALL + (CONS |a| + (CONS |b| NIL))) + NIL)))))) + (SPADLET |body| + (CONS + (COND + (|$QuickCode| 'QSETREFV) + ('T 'SETELT)) + (CONS |v| + (CONS |index| + (CONS |body| NIL))))) + (COND + ((AND + (REFVECP |$SetFunctions|) + (|TruthP| |flag|)) + (SETELT |u| |index| 'T))) + (COND + ((BOOT-EQUAL |v| '$) + (COND + ((NULL + (REFVECP + |$SetFunctions|)) + NIL) + ('T + (SETELT + |$MissingFunctionInfo| + |index| |flag|) + (COND + ((|TruthP| + (ELT |$SetFunctions| + |index|)) + (SPADLET |body| NIL) + (RETURN NIL)) + ('T + (SETELT + |$SetFunctions| + |index| + (COND + ((|TruthP| |flag|) + 'T) + ((NULL + (ELT + |$SetFunctions| + |index|)) + |flag|) + ('T + (CONS '|or| + (CONS + (ELT + |$SetFunctions| + |index|) + (CONS |flag| + NIL))))))))))) + ('T NIL))) + ((AND (PAIRP |catImplem|) + (EQ (QCAR |catImplem|) + '|Subsumed|) + (PROGN + (SPADLET |truename| + (QCDR |catImplem|)) + 'T)) + (COND + ((BOOT-EQUAL |mode| + '|original|) + (COND + ((AND (PAIRP |truename|) + (PROGN + (SPADLET |fn| + (QCAR |truename|)) + 'T) + (MEMQ |fn| + '(|Zero| |One|))) + NIL) + ('T + (SPADLET |body| + (|SetFunctionSlots| + |truename| |body| NIL + |mode|))))) + ('T NIL))) + ((NULL + (AND (PAIRP |catImplem|) + (EQ (QCAR |catImplem|) 'PAC))) + (|keyedSystemError| 'S2OR0002 + (CONS |catImplem| NIL))) + ('T NIL)))))))))) + (COND + ((AND (PAIRP |body|) (EQ (QCAR |body|) 'SETELT)) |body|) + ((AND (PAIRP |body|) (EQ (QCAR |body|) 'QSETREFV)) + |body|) + ('T NIL))))))) + +;LookUpSigSlots(sig,siglist) == +;--+ must kill any implementations below of the form (ELT $ NIL) +; if $insideCategoryPackageIfTrue then +; sig := substitute('$,CADR($functorForm),sig) +; siglist := $lisplibOperationAlist +; REMDUP [implem for u in siglist | SigSlotsMatch(sig,first u,implem:=CADDR u) +; and KADDR implem] + +(DEFUN |LookUpSigSlots| (|sig| |siglist|) + (PROG (|implem|) + (RETURN + (SEQ (PROGN + (COND + (|$insideCategoryPackageIfTrue| + (SPADLET |sig| + (MSUBST '$ (CADR |$functorForm|) |sig|)))) + (SPADLET |siglist| |$lisplibOperationAlist|) + (REMDUP (PROG (G167951) + (SPADLET G167951 NIL) + (RETURN + (DO ((G167957 |siglist| (CDR G167957)) + (|u| NIL)) + ((OR (ATOM G167957) + (PROGN + (SETQ |u| (CAR G167957)) + NIL)) + (NREVERSE0 G167951)) + (SEQ (EXIT (COND + ((AND + (|SigSlotsMatch| |sig| + (CAR |u|) + (SPADLET |implem| + (CADDR |u|))) + (KADDR |implem|)) + (SETQ G167951 + (CONS |implem| G167951))))))))))))))) + +;SigSlotsMatch(sig,pattern,implem) == +; sig=pattern => true +; not (LENGTH CADR sig=LENGTH CADR pattern) => nil +; --CADR sig is the actual signature part +; not (first sig=first pattern) => nil +; pat' :=SUBSTQ($definition,'$,CADR pattern) +; sig' :=SUBSTQ($definition,'$,CADR sig) +; sig'=pat' => true +; --If we don't have this next test, then we'll recurse in SetFunctionSlots +; implem is ['Subsumed,:.] => nil +; SourceLevelSubsume(sig',pat') => true +; nil + +(DEFUN |SigSlotsMatch| (|sig| |pattern| |implem|) + (PROG (|pat'| |sig'|) + (RETURN + (COND + ((BOOT-EQUAL |sig| |pattern|) 'T) + ((NULL (BOOT-EQUAL (LENGTH (CADR |sig|)) + (LENGTH (CADR |pattern|)))) + NIL) + ((NULL (BOOT-EQUAL (CAR |sig|) (CAR |pattern|))) NIL) + ('T (SPADLET |pat'| (SUBSTQ |$definition| '$ (CADR |pattern|))) + (SPADLET |sig'| (SUBSTQ |$definition| '$ (CADR |sig|))) + (COND + ((BOOT-EQUAL |sig'| |pat'|) 'T) + ((AND (PAIRP |implem|) (EQ (QCAR |implem|) '|Subsumed|)) + NIL) + ((|SourceLevelSubsume| |sig'| |pat'|) 'T) + ('T NIL))))))) + +;CheckVector(vec,name,catvecListMaker) == +; code:= nil +; condAlist := +; [[a,:first b] for [.,a,:b] in $getDomainCode] +; -- used as substitution alist below +; for i in 6..MAXINDEX vec repeat +; v:= vec.i +; v=true => nil +; null v => nil +; --a domain, which setVector4part3 will fill in +; atom v => systemErrorHere '"CheckVector" +; atom first v => +; --It's a secondary view of a domain, which we +; --must generate code to fill in +; for x in $catNames for y in catvecListMaker repeat +; if y=v then code:= +; [[($QuickCode => 'QSETREFV; 'SETELT),name,i,x],:code] +; if name='$ then +; ASSOC(first v,$CheckVectorList) => nil +; $CheckVectorList:= +; [[first v,:makeMissingFunctionEntry(condAlist,i)],:$CheckVectorList] +;-- MEMBER(first v,$CheckVectorList) => nil +;-- $CheckVectorList:= [first v,:$CheckVectorList] +; code + +(DEFUN |CheckVector| (|vec| |name| |catvecListMaker|) + (PROG (|a| |b| |condAlist| |v| |code|) + (RETURN + (SEQ (PROGN + (SPADLET |code| NIL) + (SPADLET |condAlist| + (PROG (G167989) + (SPADLET G167989 NIL) + (RETURN + (DO ((G167995 |$getDomainCode| + (CDR G167995)) + (G167976 NIL)) + ((OR (ATOM G167995) + (PROGN + (SETQ G167976 (CAR G167995)) + NIL) + (PROGN + (PROGN + (SPADLET |a| (CADR G167976)) + (SPADLET |b| (CDDR G167976)) + G167976) + NIL)) + (NREVERSE0 G167989)) + (SEQ (EXIT (SETQ G167989 + (CONS (CONS |a| (CAR |b|)) + G167989)))))))) + (DO ((G168007 (MAXINDEX |vec|)) (|i| 6 (+ |i| 1))) + ((> |i| G168007) NIL) + (SEQ (EXIT (PROGN + (SPADLET |v| (ELT |vec| |i|)) + (COND + ((BOOT-EQUAL |v| 'T) NIL) + ((NULL |v|) NIL) + ((ATOM |v|) + (|systemErrorHere| + (MAKESTRING "CheckVector"))) + ((ATOM (CAR |v|)) + (DO ((G168015 |$catNames| + (CDR G168015)) + (|x| NIL) + (G168016 |catvecListMaker| + (CDR G168016)) + (|y| NIL)) + ((OR (ATOM G168015) + (PROGN + (SETQ |x| (CAR G168015)) + NIL) + (ATOM G168016) + (PROGN + (SETQ |y| (CAR G168016)) + NIL)) + NIL) + (SEQ (EXIT + (COND + ((BOOT-EQUAL |y| |v|) + (SPADLET |code| + (CONS + (CONS + (COND + (|$QuickCode| 'QSETREFV) + ('T 'SETELT)) + (CONS |name| + (CONS |i| (CONS |x| NIL)))) + |code|))) + ('T NIL)))))) + ((BOOT-EQUAL |name| '$) + (COND + ((|assoc| (CAR |v|) + |$CheckVectorList|) + NIL) + ('T + (SPADLET |$CheckVectorList| + (CONS + (CONS (CAR |v|) + (|makeMissingFunctionEntry| + |condAlist| |i|)) + |$CheckVectorList|))))) + ('T NIL)))))) + |code|))))) + +;makeMissingFunctionEntry(alist,i) == +; tran SUBLIS(alist,$MissingFunctionInfo.i) where +; tran x == +; x is ["HasCategory",a,["QUOTE",b]] => ['has,a,b] +; x is [op,:l] and op in '(AND OR NOT) => [op,:[tran y for y in l]] +; x + +(DEFUN |makeMissingFunctionEntry,tran| (|x|) + (PROG (|ISTMP#1| |a| |ISTMP#2| |ISTMP#3| |ISTMP#4| |b| |op| |l|) + (RETURN + (SEQ (IF (AND (PAIRP |x|) (EQ (QCAR |x|) '|HasCategory|) + (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|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |ISTMP#3| + (QCAR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCAR |ISTMP#3|) 'QUOTE) + (PROGN + (SPADLET |ISTMP#4| + (QCDR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) + (EQ (QCDR |ISTMP#4|) NIL) + (PROGN + (SPADLET |b| + (QCAR |ISTMP#4|)) + 'T)))))))))) + (EXIT (CONS '|has| (CONS |a| (CONS |b| NIL))))) + (IF (AND (AND (PAIRP |x|) + (PROGN + (SPADLET |op| (QCAR |x|)) + (SPADLET |l| (QCDR |x|)) + 'T)) + (|member| |op| '(AND OR NOT))) + (EXIT (CONS |op| + (PROG (G168082) + (SPADLET G168082 NIL) + (RETURN + (DO ((G168087 |l| (CDR G168087)) + (|y| NIL)) + ((OR (ATOM G168087) + (PROGN + (SETQ |y| (CAR G168087)) + NIL)) + (NREVERSE0 G168082)) + (SEQ (EXIT + (SETQ G168082 + (CONS + (|makeMissingFunctionEntry,tran| + |y|) + G168082)))))))))) + (EXIT |x|))))) + +(DEFUN |makeMissingFunctionEntry| (|alist| |i|) + (|makeMissingFunctionEntry,tran| + (SUBLIS |alist| (ELT |$MissingFunctionInfo| |i|)))) + +;--% Under what conditions may views exist? +; +;InvestigateConditions catvecListMaker == +; -- given a principal view and a list of secondary views, +; -- discover under what conditions the secondary view are +; -- always present. +; $Conditions: local := nil +; $principal: local := nil +; [$principal,:secondaries]:= catvecListMaker +; --We are not interested in the principal view +; --The next block allows for the possibility that $principal may +; --have conditional secondary views +;--+ +; null secondaries => '(T) +; --return for packages which generally have no secondary views +; if $principal is [op,:.] then +; [principal',:.]:=compMakeCategoryObject($principal,$e) +; --Rather like eval, but quotes parameters first +; for u in CADR principal'.4 repeat +; if not TruthP(cond:=CADR u) then +; new:=['CATEGORY,'domain,['IF,cond,['ATTRIBUTE,CAR u], 'noBranch]] +; $principal is ['Join,:l] => +; not MEMBER(new,l) => +; $principal:=['Join,:l,new] +; $principal:=['Join,$principal,new] +; principal' := +; pessimise $principal where +; pessimise a == +; atom a => a +; a is ['SIGNATURE,:.] => a +; a is ['IF,cond,:.] => +; if not MEMBER(cond,$Conditions) then $Conditions:= [cond,:$Conditions] +; nil +; [pessimise first a,:pessimise rest a] +; null $Conditions => [true,:[true for u in secondaries]] +; PrincipalSecondaries:= getViewsConditions principal' +; MinimalPrimary:= CAR first PrincipalSecondaries +; MaximalPrimary:= CAAR $domainShell.4 +; necessarySecondaries:= [first u for u in PrincipalSecondaries | rest u=true] +; and/[MEMBER(u,necessarySecondaries) for u in secondaries] => +; [true,:[true for u in secondaries]] +; $HackSlot4:= +; MinimalPrimary=MaximalPrimary => nil +; MaximalPrimaries:=[MaximalPrimary,:CAR (CatEval MaximalPrimary).4] +; MinimalPrimaries:=[MinimalPrimary,:CAR (CatEval MinimalPrimary).4] +; MaximalPrimaries:=S_-(MaximalPrimaries,MinimalPrimaries) +; [[x] for x in MaximalPrimaries] +; ($Conditions:= Conds($principal,nil)) where +; Conds(code,previous) == +; --each call takes a list of conditions, and returns a list +; --of refinements of that list +; atom code => [previous] +; code is ['DomainSubstitutionMacro,.,b] => Conds(b,previous) +; code is ['IF,a,b,c] => UNION(Conds(b,[a,:previous]),Conds(c,previous)) +; code is ['PROGN,:l] => "UNION"/[Conds(u,previous) for u in l] +; code is ['CATEGORY,:l] => "UNION"/[Conds(u,previous) for u in l] +; code is ['Join,:l] => "UNION"/[Conds(u,previous) for u in l] +; [previous] +; $Conditions:= EFFACE(nil,[EFFACE(nil,u) for u in $Conditions]) +; partList:= +; [getViewsConditions partPessimise($principal,cond) for cond in $Conditions] +; masterSecondaries:= secondaries +; for u in partList repeat +; for [v,:.] in u repeat +; if not MEMBER(v,secondaries) then secondaries:= [v,:secondaries] +; --PRETTYPRINT $Conditions +; --PRETTYPRINT masterSecondaries +; --PRETTYPRINT secondaries +; (list:= [mkNilT MEMBER(u,necessarySecondaries) for u in secondaries]) where +; mkNilT u == +; u => true +; nil +; for u in $Conditions for newS in partList repeat +; --newS is a list of secondaries and conditions (over and above +; --u) for which they apply +; u:= +; LENGTH u=1 => first u +; ['AND,:u] +; for [v,:.] in newS repeat +; for v' in [v,:CAR (CatEval v).4] repeat +; if (w:=ASSOC(v',$HackSlot4)) then +; RPLAC(rest w,if rest w then mkOr(u,rest w) else u) +; (list:= update(list,u,secondaries,newS)) where +; update(list,cond,secondaries,newS) == +; (list2:= +; [flist(sec,newS,old,cond) for sec in secondaries for old in list]) where +; flist(sec,newS,old,cond) == +; old=true => old +; for [newS2,:morecond] in newS repeat +; old:= +; not AncestorP(sec,[newS2]) => old +; cond2:= mkAnd(cond,morecond) +; null old => cond2 +; mkOr(cond2,old) +; old +; list2 +; list:= [[sec,:ICformat u] for u in list for sec in secondaries] +; pv:= getPossibleViews $principal +;-- $HackSlot4 is used in SetVector4 to ensure that conditional +;-- extensions of the principal view are handles correctly +;-- here we build the code necessary to remove spurious extensions +; ($HackSlot4:= [reshape u for u in $HackSlot4]) where +; reshape u == +; ['COND,[TryGDC ICformat rest u], +; ['(QUOTE T),['RPLACA,'(CAR TrueDomain), +; ['delete,['QUOTE,first u],'(CAAR TrueDomain)]]]] +; $supplementaries:= +; [u +; for u in list | not MEMBER(first u,masterSecondaries) +; and not (true=rest u) and not MEMBER(first u,pv)] +; [true,:[LASSOC(ms,list) for ms in masterSecondaries]] + +(DEFUN |InvestigateConditions,pessimise| (|a|) + (PROG (|ISTMP#1| |cond|) + (RETURN + (SEQ (IF (ATOM |a|) (EXIT |a|)) + (IF (AND (PAIRP |a|) (EQ (QCAR |a|) 'SIGNATURE)) (EXIT |a|)) + (IF (AND (PAIRP |a|) (EQ (QCAR |a|) 'IF) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |cond| (QCAR |ISTMP#1|)) + 'T)))) + (EXIT (SEQ (IF (NULL (|member| |cond| |$Conditions|)) + (SPADLET |$Conditions| + (CONS |cond| |$Conditions|)) + NIL) + (EXIT NIL)))) + (EXIT (CONS (|InvestigateConditions,pessimise| (CAR |a|)) + (|InvestigateConditions,pessimise| (CDR |a|)))))))) + +(DEFUN |InvestigateConditions,Conds| (|code| |previous|) + (PROG (|ISTMP#1| |a| |ISTMP#2| |b| |ISTMP#3| |c| |l|) + (RETURN + (SEQ (IF (ATOM |code|) (EXIT (CONS |previous| NIL))) + (IF (AND (PAIRP |code|) + (EQ (QCAR |code|) '|DomainSubstitutionMacro|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |code|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |b| (QCAR |ISTMP#2|)) + 'T)))))) + (EXIT (|InvestigateConditions,Conds| |b| |previous|))) + (IF (AND (PAIRP |code|) (EQ (QCAR |code|) 'IF) + (PROGN + (SPADLET |ISTMP#1| (QCDR |code|)) + (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)))))))) + (EXIT (|union| (|InvestigateConditions,Conds| |b| + (CONS |a| |previous|)) + (|InvestigateConditions,Conds| |c| + |previous|)))) + (IF (AND (PAIRP |code|) (EQ (QCAR |code|) 'PROGN) + (PROGN (SPADLET |l| (QCDR |code|)) 'T)) + (EXIT (PROG (G168178) + (SPADLET G168178 NIL) + (RETURN + (DO ((G168183 |l| (CDR G168183)) + (|u| NIL)) + ((OR (ATOM G168183) + (PROGN + (SETQ |u| (CAR G168183)) + NIL)) + G168178) + (SEQ (EXIT (SETQ G168178 + (|union| G168178 + (|InvestigateConditions,Conds| + |u| |previous|)))))))))) + (IF (AND (PAIRP |code|) (EQ (QCAR |code|) 'CATEGORY) + (PROGN (SPADLET |l| (QCDR |code|)) 'T)) + (EXIT (PROG (G168189) + (SPADLET G168189 NIL) + (RETURN + (DO ((G168194 |l| (CDR G168194)) + (|u| NIL)) + ((OR (ATOM G168194) + (PROGN + (SETQ |u| (CAR G168194)) + NIL)) + G168189) + (SEQ (EXIT (SETQ G168189 + (|union| G168189 + (|InvestigateConditions,Conds| + |u| |previous|)))))))))) + (IF (AND (PAIRP |code|) (EQ (QCAR |code|) '|Join|) + (PROGN (SPADLET |l| (QCDR |code|)) 'T)) + (EXIT (PROG (G168200) + (SPADLET G168200 NIL) + (RETURN + (DO ((G168205 |l| (CDR G168205)) + (|u| NIL)) + ((OR (ATOM G168205) + (PROGN + (SETQ |u| (CAR G168205)) + NIL)) + G168200) + (SEQ (EXIT (SETQ G168200 + (|union| G168200 + (|InvestigateConditions,Conds| + |u| |previous|)))))))))) + (EXIT (CONS |previous| NIL)))))) + +(DEFUN |InvestigateConditions,mkNilT| (|u|) + (SEQ (IF |u| (EXIT 'T)) (EXIT NIL))) + +(DEFUN |InvestigateConditions,flist| (|sec| |newS| |old| |cond|) + (PROG (|newS2| |morecond| |cond2|) + (RETURN + (SEQ (IF (BOOT-EQUAL |old| 'T) (EXIT |old|)) + (DO ((G168252 |newS| (CDR G168252)) (G168243 NIL)) + ((OR (ATOM G168252) + (PROGN (SETQ G168243 (CAR G168252)) NIL) + (PROGN + (PROGN + (SPADLET |newS2| (CAR G168243)) + (SPADLET |morecond| (CDR G168243)) + G168243) + NIL)) + NIL) + (SEQ (EXIT (SPADLET |old| + (SEQ (IF + (NULL + (|AncestorP| |sec| + (CONS |newS2| NIL))) + (EXIT |old|)) + (SPADLET |cond2| + (|mkAnd| |cond| |morecond|)) + (IF (NULL |old|) (EXIT |cond2|)) + (EXIT (|mkOr| |cond2| |old|))))))) + (EXIT |old|))))) + +(DEFUN |InvestigateConditions,update| + (LIST |cond| |secondaries| |newS|) + (PROG (|list2|) + (RETURN + (SEQ (SPADLET |list2| + (PROG (G168273) + (SPADLET G168273 NIL) + (RETURN + (DO ((G168279 |secondaries| (CDR G168279)) + (|sec| NIL) + (G168280 LIST (CDR G168280)) + (|old| NIL)) + ((OR (ATOM G168279) + (PROGN + (SETQ |sec| (CAR G168279)) + NIL) + (ATOM G168280) + (PROGN + (SETQ |old| (CAR G168280)) + NIL)) + (NREVERSE0 G168273)) + (SEQ (EXIT (SETQ G168273 + (CONS + (|InvestigateConditions,flist| + |sec| |newS| |old| |cond|) + G168273)))))))) + (EXIT |list2|))))) + +(DEFUN |InvestigateConditions,reshape| (|u|) + (CONS 'COND + (CONS (CONS (|TryGDC| (|ICformat| (CDR |u|))) NIL) + (CONS (CONS ''T + (CONS (CONS 'RPLACA + (CONS '(CAR |TrueDomain|) + (CONS + (CONS '|delete| + (CONS + (CONS 'QUOTE + (CONS (CAR |u|) NIL)) + (CONS '(CAAR |TrueDomain|) + NIL))) + NIL))) + NIL)) + NIL)))) + +(DEFUN |InvestigateConditions| (|catvecListMaker|) + (PROG (|$Conditions| |$principal| |op| |LETTMP#1| |cond| |new| |l| + |principal'| |PrincipalSecondaries| |MinimalPrimary| + |MaximalPrimary| |necessarySecondaries| |MinimalPrimaries| + |MaximalPrimaries| |partList| |masterSecondaries| + |secondaries| |u| |v| |w| LIST |pv|) + (DECLARE (SPECIAL |$Conditions| |$principal|)) + (RETURN + (SEQ (PROGN + (SPADLET |$Conditions| NIL) + (SPADLET |$principal| NIL) + (SPADLET |$principal| (CAR |catvecListMaker|)) + (SPADLET |secondaries| (CDR |catvecListMaker|)) + (COND + ((NULL |secondaries|) '(T)) + ('T + (COND + ((AND (PAIRP |$principal|) + (PROGN (SPADLET |op| (QCAR |$principal|)) 'T)) + (SPADLET |LETTMP#1| + (|compMakeCategoryObject| |$principal| + |$e|)) + (SPADLET |principal'| (CAR |LETTMP#1|)) + (DO ((G168306 (CADR (ELT |principal'| 4)) + (CDR G168306)) + (|u| NIL)) + ((OR (ATOM G168306) + (PROGN (SETQ |u| (CAR G168306)) NIL)) + NIL) + (SEQ (EXIT (COND + ((NULL + (|TruthP| + (SPADLET |cond| (CADR |u|)))) + (SPADLET |new| + (CONS 'CATEGORY + (CONS '|domain| + (CONS + (CONS 'IF + (CONS |cond| + (CONS + (CONS 'ATTRIBUTE + (CONS (CAR |u|) NIL)) + (CONS '|noBranch| NIL)))) + NIL)))) + (SEQ + (COND + ((AND (PAIRP |$principal|) + (EQ (QCAR |$principal|) + '|Join|) + (PROGN + (SPADLET |l| + (QCDR |$principal|)) + 'T)) + (COND + ((NULL (|member| |new| |l|)) + (EXIT + (SPADLET |$principal| + (CONS '|Join| + (APPEND |l| + (CONS |new| NIL)))))))) + ('T + (SPADLET |$principal| + (CONS '|Join| + (CONS |$principal| + (CONS |new| NIL)))))))) + ('T NIL))))))) + (SPADLET |principal'| + (|InvestigateConditions,pessimise| + |$principal|)) + (COND + ((NULL |$Conditions|) + (CONS 'T + (PROG (G168316) + (SPADLET G168316 NIL) + (RETURN + (DO ((G168321 |secondaries| + (CDR G168321)) + (|u| NIL)) + ((OR (ATOM G168321) + (PROGN + (SETQ |u| (CAR G168321)) + NIL)) + (NREVERSE0 G168316)) + (SEQ (EXIT + (SETQ G168316 + (CONS 'T G168316))))))))) + ('T + (SPADLET |PrincipalSecondaries| + (|getViewsConditions| |principal'|)) + (SPADLET |MinimalPrimary| + (CAR (CAR |PrincipalSecondaries|))) + (SPADLET |MaximalPrimary| + (CAAR (ELT |$domainShell| 4))) + (SPADLET |necessarySecondaries| + (PROG (G168332) + (SPADLET G168332 NIL) + (RETURN + (DO ((G168338 |PrincipalSecondaries| + (CDR G168338)) + (|u| NIL)) + ((OR (ATOM G168338) + (PROGN + (SETQ |u| (CAR G168338)) + NIL)) + (NREVERSE0 G168332)) + (SEQ (EXIT + (COND + ((BOOT-EQUAL (CDR |u|) 'T) + (SETQ G168332 + (CONS (CAR |u|) G168332)))))))))) + (COND + ((PROG (G168344) + (SPADLET G168344 'T) + (RETURN + (DO ((G168350 NIL (NULL G168344)) + (G168351 |secondaries| + (CDR G168351)) + (|u| NIL)) + ((OR G168350 (ATOM G168351) + (PROGN + (SETQ |u| (CAR G168351)) + NIL)) + G168344) + (SEQ (EXIT (SETQ G168344 + (AND G168344 + (|member| |u| + |necessarySecondaries|)))))))) + (CONS 'T + (PROG (G168362) + (SPADLET G168362 NIL) + (RETURN + (DO ((G168367 |secondaries| + (CDR G168367)) + (|u| NIL)) + ((OR (ATOM G168367) + (PROGN + (SETQ |u| (CAR G168367)) + NIL)) + (NREVERSE0 G168362)) + (SEQ (EXIT + (SETQ G168362 + (CONS 'T G168362))))))))) + ('T + (SPADLET |$HackSlot4| + (COND + ((BOOT-EQUAL |MinimalPrimary| + |MaximalPrimary|) + NIL) + ('T + (SPADLET |MaximalPrimaries| + (CONS |MaximalPrimary| + (CAR + (ELT + (|CatEval| + |MaximalPrimary|) + 4)))) + (SPADLET |MinimalPrimaries| + (CONS |MinimalPrimary| + (CAR + (ELT + (|CatEval| + |MinimalPrimary|) + 4)))) + (SPADLET |MaximalPrimaries| + (S- |MaximalPrimaries| + |MinimalPrimaries|)) + (PROG (G168377) + (SPADLET G168377 NIL) + (RETURN + (DO + ((G168382 |MaximalPrimaries| + (CDR G168382)) + (|x| NIL)) + ((OR (ATOM G168382) + (PROGN + (SETQ |x| (CAR G168382)) + NIL)) + (NREVERSE0 G168377)) + (SEQ + (EXIT + (SETQ G168377 + (CONS (CONS |x| NIL) + G168377)))))))))) + (SPADLET |$Conditions| + (|InvestigateConditions,Conds| + |$principal| NIL)) + (SPADLET |$Conditions| + (EFFACE NIL + (PROG (G168392) + (SPADLET G168392 NIL) + (RETURN + (DO + ((G168397 |$Conditions| + (CDR G168397)) + (|u| NIL)) + ((OR (ATOM G168397) + (PROGN + (SETQ |u| + (CAR G168397)) + NIL)) + (NREVERSE0 G168392)) + (SEQ + (EXIT + (SETQ G168392 + (CONS (EFFACE NIL |u|) + G168392))))))))) + (SPADLET |partList| + (PROG (G168407) + (SPADLET G168407 NIL) + (RETURN + (DO + ((G168412 |$Conditions| + (CDR G168412)) + (|cond| NIL)) + ((OR (ATOM G168412) + (PROGN + (SETQ |cond| (CAR G168412)) + NIL)) + (NREVERSE0 G168407)) + (SEQ + (EXIT + (SETQ G168407 + (CONS + (|getViewsConditions| + (|partPessimise| |$principal| + |cond|)) + G168407)))))))) + (SPADLET |masterSecondaries| |secondaries|) + (DO ((G168423 |partList| (CDR G168423)) + (|u| NIL)) + ((OR (ATOM G168423) + (PROGN (SETQ |u| (CAR G168423)) NIL)) + NIL) + (SEQ (EXIT (DO + ((G168433 |u| (CDR G168433)) + (G168230 NIL)) + ((OR (ATOM G168433) + (PROGN + (SETQ G168230 + (CAR G168433)) + NIL) + (PROGN + (PROGN + (SPADLET |v| (CAR G168230)) + G168230) + NIL)) + NIL) + (SEQ + (EXIT + (COND + ((NULL + (|member| |v| |secondaries|)) + (SPADLET |secondaries| + (CONS |v| |secondaries|))) + ('T NIL)))))))) + (SPADLET LIST + (PROG (G168444) + (SPADLET G168444 NIL) + (RETURN + (DO + ((G168449 |secondaries| + (CDR G168449)) + (|u| NIL)) + ((OR (ATOM G168449) + (PROGN + (SETQ |u| (CAR G168449)) + NIL)) + (NREVERSE0 G168444)) + (SEQ + (EXIT + (SETQ G168444 + (CONS + (|InvestigateConditions,mkNilT| + (|member| |u| + |necessarySecondaries|)) + G168444)))))))) + (DO ((G168464 |$Conditions| (CDR G168464)) + (|u| NIL) + (G168465 |partList| (CDR G168465)) + (|newS| NIL)) + ((OR (ATOM G168464) + (PROGN (SETQ |u| (CAR G168464)) NIL) + (ATOM G168465) + (PROGN + (SETQ |newS| (CAR G168465)) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |u| + (COND + ((EQL (LENGTH |u|) 1) + (CAR |u|)) + ('T (CONS 'AND |u|)))) + (DO + ((G168478 |newS| + (CDR G168478)) + (G168239 NIL)) + ((OR (ATOM G168478) + (PROGN + (SETQ G168239 + (CAR G168478)) + NIL) + (PROGN + (PROGN + (SPADLET |v| + (CAR G168239)) + G168239) + NIL)) + NIL) + (SEQ + (EXIT + (DO + ((G168488 + (CONS |v| + (CAR + (ELT (|CatEval| |v|) 4))) + (CDR G168488)) + (|v'| NIL)) + ((OR (ATOM G168488) + (PROGN + (SETQ |v'| + (CAR G168488)) + NIL)) + NIL) + (SEQ + (EXIT + (COND + ((SPADLET |w| + (|assoc| |v'| + |$HackSlot4|)) + (RPLAC (CDR |w|) + (COND + ((CDR |w|) + (|mkOr| |u| + (CDR |w|))) + ('T |u|)))) + ('T NIL)))))))) + (SPADLET LIST + (|InvestigateConditions,update| + LIST |u| |secondaries| |newS|)))))) + (SPADLET LIST + (PROG (G168499) + (SPADLET G168499 NIL) + (RETURN + (DO + ((G168505 LIST (CDR G168505)) + (|u| NIL) + (G168506 |secondaries| + (CDR G168506)) + (|sec| NIL)) + ((OR (ATOM G168505) + (PROGN + (SETQ |u| (CAR G168505)) + NIL) + (ATOM G168506) + (PROGN + (SETQ |sec| (CAR G168506)) + NIL)) + (NREVERSE0 G168499)) + (SEQ + (EXIT + (SETQ G168499 + (CONS + (CONS |sec| (|ICformat| |u|)) + G168499)))))))) + (SPADLET |pv| (|getPossibleViews| |$principal|)) + (SPADLET |$HackSlot4| + (PROG (G168519) + (SPADLET G168519 NIL) + (RETURN + (DO + ((G168524 |$HackSlot4| + (CDR G168524)) + (|u| NIL)) + ((OR (ATOM G168524) + (PROGN + (SETQ |u| (CAR G168524)) + NIL)) + (NREVERSE0 G168519)) + (SEQ + (EXIT + (SETQ G168519 + (CONS + (|InvestigateConditions,reshape| + |u|) + G168519)))))))) + (SPADLET |$supplementaries| + (PROG (G168535) + (SPADLET G168535 NIL) + (RETURN + (DO + ((G168541 LIST (CDR G168541)) + (|u| NIL)) + ((OR (ATOM G168541) + (PROGN + (SETQ |u| (CAR G168541)) + NIL)) + (NREVERSE0 G168535)) + (SEQ + (EXIT + (COND + ((AND + (NULL + (|member| (CAR |u|) + |masterSecondaries|)) + (NULL + (BOOT-EQUAL 'T (CDR |u|))) + (NULL + (|member| (CAR |u|) |pv|))) + (SETQ G168535 + (CONS |u| G168535)))))))))) + (CONS 'T + (PROG (G168551) + (SPADLET G168551 NIL) + (RETURN + (DO ((G168556 |masterSecondaries| + (CDR G168556)) + (|ms| NIL)) + ((OR (ATOM G168556) + (PROGN + (SETQ |ms| (CAR G168556)) + NIL)) + (NREVERSE0 G168551)) + (SEQ (EXIT + (SETQ G168551 + (CONS (LASSOC |ms| LIST) + G168551))))))))))))))))))) + +;ICformat u == +; atom u => u +; u is ['has,:.] => compHasFormat u +; u is ['AND,:l] or u is ['and,:l] => +; l:= REMDUP [ICformat v for [v,:l'] in tails l | not MEMBER(v,l')] +; -- we could have duplicates after, even if not before +; LENGTH l=1 => first l +; l1:= first l +; for u in rest l repeat +; l1:=mkAnd(u,l1) +; l1 +; u is ['OR,:l] => +; (l:= ORreduce l) where +; ORreduce l == +; for u in l | u is ['AND,:.] or u is ['and,:.] repeat +; --check that B causes (and A B) to go +; for v in l | not (v=u) repeat +; if MEMBER(v,u) or (and/[MEMBER(w,u) for w in v]) then l:= +; DELETE(u,l) +; --v subsumes u +; --Note that we are ignoring AND as a component. +; --Convince yourself that this code still works +; l +; LENGTH l=1 => ICformat first l +; l:= ORreduce REMDUP [ICformat u for u in l] +; --causes multiple ANDs to be squashed, etc. +; -- and duplicates that have been built up by tidying +; (l:= Hasreduce l) where +; Hasreduce l == +; for u in l | u is ['HasCategory,name,cond] and cond is ['QUOTE, +; cond] repeat +; --check that v causes descendants to go +; for v in l | not (v=u) and v is ['HasCategory, =name,['QUOTE, +; cond2]] repeat if DescendantP(cond,cond2) then l:= DELETE(u,l) +; --v subsumes u +; for u in l | u is ['AND,:l'] or u is ['and,:l'] repeat +; for u' in l' | u' is ['HasCategory,name,cond] and cond is ['QUOTE, +; cond] repeat +; --check that v causes descendants to go +; for v in l | v is ['HasCategory, =name,['QUOTE, +; cond2]] repeat if DescendantP(cond,cond2) then l:= DELETE(u,l) +; --v subsumes u +; l +; LENGTH l=1 => first l +; ['OR,:l] +; systemErrorHere '"ICformat" + +(DEFUN |ICformat,ORreduce| (|l|) + (PROG () + (RETURN + (SEQ (DO ((G168627 |l| (CDR G168627)) (|u| NIL)) + ((OR (ATOM G168627) + (PROGN (SETQ |u| (CAR G168627)) NIL)) + NIL) + (SEQ (EXIT (COND + ((OR (AND (PAIRP |u|) (EQ (QCAR |u|) 'AND)) + (AND (PAIRP |u|) (EQ (QCAR |u|) '|and|))) + (DO ((G168637 |l| (CDR G168637)) + (|v| NIL)) + ((OR (ATOM G168637) + (PROGN + (SETQ |v| (CAR G168637)) + NIL)) + NIL) + (SEQ (EXIT (COND + ((NULL (BOOT-EQUAL |v| |u|)) + (IF + (OR (|member| |v| |u|) + (PROG (G168643) + (SPADLET G168643 'T) + (RETURN + (DO + ((G168649 NIL + (NULL G168643)) + (G168650 |v| + (CDR G168650)) + (|w| NIL)) + ((OR G168649 + (ATOM G168650) + (PROGN + (SETQ |w| + (CAR G168650)) + NIL)) + G168643) + (SEQ + (EXIT + (SETQ G168643 + (AND G168643 + (|member| |w| + |u|))))))))) + (SPADLET |l| + (|delete| |u| |l|)) + NIL))))))))))) + (EXIT |l|))))) + +(DEFUN |ICformat,Hasreduce| (|l|) + (PROG (|l'| |name| |cond| |ISTMP#1| |ISTMP#2| |ISTMP#3| |ISTMP#4| + |cond2|) + (RETURN + (SEQ (DO ((G168774 |l| (CDR G168774)) (|u| NIL)) + ((OR (ATOM G168774) + (PROGN (SETQ |u| (CAR G168774)) NIL)) + NIL) + (SEQ (EXIT (COND + ((AND (AND (PAIRP |u|) + (EQ (QCAR |u|) '|HasCategory|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |u|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |name| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |cond| + (QCAR |ISTMP#2|)) + 'T)))))) + (AND (PAIRP |cond|) + (EQ (QCAR |cond|) 'QUOTE) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |cond|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |cond| + (QCAR |ISTMP#1|)) + 'T))))) + (DO ((G168784 |l| (CDR G168784)) + (|v| NIL)) + ((OR (ATOM G168784) + (PROGN + (SETQ |v| (CAR G168784)) + NIL)) + NIL) + (SEQ (EXIT (COND + ((AND + (NULL (BOOT-EQUAL |v| |u|)) + (AND (PAIRP |v|) + (EQ (QCAR |v|) + '|HasCategory|) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |v|)) + (AND (PAIRP |ISTMP#1|) + (EQUAL (QCAR |ISTMP#1|) + |name|) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) + NIL) + (PROGN + (SPADLET |ISTMP#3| + (QCAR |ISTMP#2|)) + (AND + (PAIRP |ISTMP#3|) + (EQ + (QCAR |ISTMP#3|) + 'QUOTE) + (PROGN + (SPADLET + |ISTMP#4| + (QCDR + |ISTMP#3|)) + (AND + (PAIRP + |ISTMP#4|) + (EQ + (QCDR + |ISTMP#4|) + NIL) + (PROGN + (SPADLET + |cond2| + (QCAR + |ISTMP#4|)) + 'T))))))))))) + (IF + (|DescendantP| |cond| + |cond2|) + (SPADLET |l| + (|delete| |u| |l|)) + NIL))))))))))) + (DO ((G168815 |l| (CDR G168815)) (|u| NIL)) + ((OR (ATOM G168815) + (PROGN (SETQ |u| (CAR G168815)) NIL)) + NIL) + (SEQ (EXIT (COND + ((OR (AND (PAIRP |u|) (EQ (QCAR |u|) 'AND) + (PROGN + (SPADLET |l'| (QCDR |u|)) + 'T)) + (AND (PAIRP |u|) (EQ (QCAR |u|) '|and|) + (PROGN + (SPADLET |l'| (QCDR |u|)) + 'T))) + (DO ((G168835 |l'| (CDR G168835)) + (|u'| NIL)) + ((OR (ATOM G168835) + (PROGN + (SETQ |u'| (CAR G168835)) + NIL)) + NIL) + (SEQ (EXIT (COND + ((AND + (AND (PAIRP |u'|) + (EQ (QCAR |u'|) + '|HasCategory|) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |u'|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |name| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) + NIL) + (PROGN + (SPADLET |cond| + (QCAR |ISTMP#2|)) + 'T)))))) + (AND (PAIRP |cond|) + (EQ (QCAR |cond|) 'QUOTE) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |cond|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) + NIL) + (PROGN + (SPADLET |cond| + (QCAR |ISTMP#1|)) + 'T))))) + (DO + ((G168845 |l| + (CDR G168845)) + (|v| NIL)) + ((OR (ATOM G168845) + (PROGN + (SETQ |v| + (CAR G168845)) + NIL)) + NIL) + (SEQ + (EXIT + (COND + ((AND (PAIRP |v|) + (EQ (QCAR |v|) + '|HasCategory|) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |v|)) + (AND + (PAIRP |ISTMP#1|) + (EQUAL + (QCAR |ISTMP#1|) + |name|) + (PROGN + (SPADLET + |ISTMP#2| + (QCDR + |ISTMP#1|)) + (AND + (PAIRP + |ISTMP#2|) + (EQ + (QCDR + |ISTMP#2|) + NIL) + (PROGN + (SPADLET + |ISTMP#3| + (QCAR + |ISTMP#2|)) + (AND + (PAIRP + |ISTMP#3|) + (EQ + (QCAR + |ISTMP#3|) + 'QUOTE) + (PROGN + (SPADLET + |ISTMP#4| + (QCDR + |ISTMP#3|)) + (AND + (PAIRP + |ISTMP#4|) + (EQ + (QCDR + |ISTMP#4|) + NIL) + (PROGN + (SPADLET + |cond2| + (QCAR + |ISTMP#4|)) + 'T)))))))))) + (IF + (|DescendantP| + |cond| |cond2|) + (SPADLET |l| + (|delete| |u| |l|)) + NIL)))))))))))))))) + (EXIT |l|))))) + +(DEFUN |ICformat| (|u|) + (PROG (|v| |l'| |l1| |l|) + (RETURN + (SEQ (COND + ((ATOM |u|) |u|) + ((AND (PAIRP |u|) (EQ (QCAR |u|) '|has|)) + (|compHasFormat| |u|)) + ((OR (AND (PAIRP |u|) (EQ (QCAR |u|) 'AND) + (PROGN (SPADLET |l| (QCDR |u|)) 'T)) + (AND (PAIRP |u|) (EQ (QCAR |u|) '|and|) + (PROGN (SPADLET |l| (QCDR |u|)) 'T))) + (SPADLET |l| + (REMDUP (PROG (G168889) + (SPADLET G168889 NIL) + (RETURN + (DO + ((G168617 |l| (CDR G168617))) + ((OR (ATOM G168617) + (PROGN + (PROGN + (SPADLET |v| (CAR G168617)) + (SPADLET |l'| + (CDR G168617)) + G168617) + NIL)) + (NREVERSE0 G168889)) + (SEQ + (EXIT + (COND + ((NULL (|member| |v| |l'|)) + (SETQ G168889 + (CONS (|ICformat| |v|) + G168889))))))))))) + (COND + ((EQL (LENGTH |l|) 1) (CAR |l|)) + ('T (SPADLET |l1| (CAR |l|)) + (DO ((G168903 (CDR |l|) (CDR G168903)) (|u| NIL)) + ((OR (ATOM G168903) + (PROGN (SETQ |u| (CAR G168903)) NIL)) + NIL) + (SEQ (EXIT (SPADLET |l1| (|mkAnd| |u| |l1|))))) + |l1|))) + ((AND (PAIRP |u|) (EQ (QCAR |u|) 'OR) + (PROGN (SPADLET |l| (QCDR |u|)) 'T)) + (SPADLET |l| (|ICformat,ORreduce| |l|)) + (COND + ((EQL (LENGTH |l|) 1) (|ICformat| (CAR |l|))) + ('T + (SPADLET |l| + (|ICformat,ORreduce| + (REMDUP (PROG (G168913) + (SPADLET G168913 NIL) + (RETURN + (DO + ((G168918 |l| + (CDR G168918)) + (|u| NIL)) + ((OR (ATOM G168918) + (PROGN + (SETQ |u| + (CAR G168918)) + NIL)) + (NREVERSE0 G168913)) + (SEQ + (EXIT + (SETQ G168913 + (CONS (|ICformat| |u|) + G168913)))))))))) + (SPADLET |l| (|ICformat,Hasreduce| |l|)) + (COND + ((EQL (LENGTH |l|) 1) (CAR |l|)) + ('T (CONS 'OR |l|)))))) + ('T (|systemErrorHere| (MAKESTRING "ICformat")))))))) + +;partPessimise(a,trueconds) == +; atom a => a +; a is ['SIGNATURE,:.] => a +; a is ['IF,cond,:.] => (MEMBER(cond,trueconds) => a; nil) +; [partPessimise(first a,trueconds),:partPessimise(rest a,trueconds)] + +(DEFUN |partPessimise| (|a| |trueconds|) + (PROG (|ISTMP#1| |cond|) + (RETURN + (COND + ((ATOM |a|) |a|) + ((AND (PAIRP |a|) (EQ (QCAR |a|) 'SIGNATURE)) |a|) + ((AND (PAIRP |a|) (EQ (QCAR |a|) 'IF) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a|)) + (AND (PAIRP |ISTMP#1|) + (PROGN (SPADLET |cond| (QCAR |ISTMP#1|)) 'T)))) + (COND ((|member| |cond| |trueconds|) |a|) ('T NIL))) + ('T + (CONS (|partPessimise| (CAR |a|) |trueconds|) + (|partPessimise| (CDR |a|) |trueconds|))))))) + +;getPossibleViews u == +; --returns a list of all the categories that can be views of this one +; [vec,:.]:= compMakeCategoryObject(u,$e) or +; systemErrorHere '"getPossibleViews" +; views:= [first u for u in CADR vec.4] +; null vec.0 => [CAAR vec.4,:views] --* +; [vec.0,:views] --* + +(DEFUN |getPossibleViews| (|u|) + (PROG (|LETTMP#1| |vec| |views|) + (RETURN + (SEQ (PROGN + (SPADLET |LETTMP#1| + (OR (|compMakeCategoryObject| |u| |$e|) + (|systemErrorHere| + (MAKESTRING "getPossibleViews")))) + (SPADLET |vec| (CAR |LETTMP#1|)) + (SPADLET |views| + (PROG (G168961) + (SPADLET G168961 NIL) + (RETURN + (DO ((G168966 (CADR (ELT |vec| 4)) + (CDR G168966)) + (|u| NIL)) + ((OR (ATOM G168966) + (PROGN + (SETQ |u| (CAR G168966)) + NIL)) + (NREVERSE0 G168961)) + (SEQ (EXIT (SETQ G168961 + (CONS (CAR |u|) G168961)))))))) + (COND + ((NULL (ELT |vec| 0)) + (CONS (CAAR (ELT |vec| 4)) |views|)) + ('T (CONS (ELT |vec| 0) |views|)))))))) + +; --the two lines marked ensure that the principal view comes first +; --if you don't want it, CDR it off +; +;getViewsConditions u == +; +; --returns a list of all the categories that can be views of this one +; --paired with the condition under which they are such views +; [vec,:.]:= compMakeCategoryObject(u,$e) or +; systemErrorHere '"getViewsConditions" +; views:= [[first u,:CADR u] for u in CADR vec.4] +; null vec.0 => +;--+ +; null CAR vec.4 => views +; [[CAAR vec.4,:true],:views] --* +; [[vec.0,:true],:views] --* + +(DEFUN |getViewsConditions| (|u|) + (PROG (|LETTMP#1| |vec| |views|) + (RETURN + (SEQ (PROGN + (SPADLET |LETTMP#1| + (OR (|compMakeCategoryObject| |u| |$e|) + (|systemErrorHere| + (MAKESTRING "getViewsConditions")))) + (SPADLET |vec| (CAR |LETTMP#1|)) + (SPADLET |views| + (PROG (G168990) + (SPADLET G168990 NIL) + (RETURN + (DO ((G168995 (CADR (ELT |vec| 4)) + (CDR G168995)) + (|u| NIL)) + ((OR (ATOM G168995) + (PROGN + (SETQ |u| (CAR G168995)) + NIL)) + (NREVERSE0 G168990)) + (SEQ (EXIT (SETQ G168990 + (CONS + (CONS (CAR |u|) (CADR |u|)) + G168990)))))))) + (COND + ((NULL (ELT |vec| 0)) + (COND + ((NULL (CAR (ELT |vec| 4))) |views|) + ('T (CONS (CONS (CAAR (ELT |vec| 4)) 'T) |views|)))) + ('T (CONS (CONS (ELT |vec| 0) 'T) |views|)))))))) + +; --the two lines marked ensure that the principal view comes first +; --if you don't want it, CDR it off +; +;DescendCodeVarAdd(base,flag) == +; princview := CAR $catvecList +; [SetFunctionSlots(sig,SUBST('ELT,'CONST,implem),flag,'adding) repeat +; for i in 6..MAXINDEX princview | +; princview.i is [sig:=[op,types],:.] and +; LASSOC([base,:SUBST(base,'$,types)],get(op,'modemap,$e)) is +; [[pred,implem]]] + +(DEFUN |DescendCodeVarAdd| (|base| |flag|) + (PROG (|princview| |op| |types| |sig| |ISTMP#1| |ISTMP#2| |pred| + |ISTMP#3| |implem|) + (RETURN + (SEQ (PROGN + (SPADLET |princview| (CAR |$catvecList|)) + (PROG (G169068) + (SPADLET G169068 NIL) + (RETURN + (DO ((G169074 (MAXINDEX |princview|)) + (|i| 6 (+ |i| 1))) + ((> |i| G169074) (NREVERSE0 G169068)) + (SEQ (EXIT (COND + ((AND (PROGN + (SPADLET |ISTMP#1| + (ELT |princview| |i|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| + (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |op| + (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) + NIL) + (PROGN + (SPADLET |types| + (QCAR |ISTMP#3|)) + 'T))))) + (PROGN + (SPADLET |sig| + (QCAR |ISTMP#1|)) + 'T))) + (PROGN + (SPADLET |ISTMP#1| + (LASSOC + (CONS |base| + (MSUBST |base| '$ |types|)) + (|get| |op| '|modemap| |$e|))) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |ISTMP#2| + (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |pred| + (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) + NIL) + (PROGN + (SPADLET |implem| + (QCAR |ISTMP#3|)) + 'T)))))))) + (SETQ G169068 + (CONS + (|SetFunctionSlots| |sig| + (MSUBST 'ELT 'CONST |implem|) + |flag| '|adding|) + G169068)))))))))))))) + +;resolvePatternVars(p,args) == +; p := SUBLISLIS(args, $TriangleVariableList, p) +; SUBLISLIS(args, $FormalMapVariableList, p) +;--resolvePatternVars(p,args) == +;-- atom p => +;-- isSharpVarWithNum p => args.(position(p,$FormalMapVariableList)) +;-- p +;-- [resolvePatternVars(CAR p,args),:resolvePatternVars(CDR p,args)] +; +;-- Mysterious JENKS definition follows: +;--DescendCodeVarAdd(base,flag) == +;-- baseops := [(u:=LASSOC([base,:SUBST(base,'$,types)], +;-- get(op,'modemap,$e))) and [sig,:u] +;-- for (sig := [op,types]) in $CheckVectorList] +;-- $CheckVectorList := [sig for sig in $CheckVectorList +;-- for op in baseops | null op] +;-- [SetFunctionSlots(sig,implem,flag,'adding) +;-- for u in baseops | u is [sig,[pred,implem]]] +; + +(DEFUN |resolvePatternVars| (|p| |args|) + (PROGN + (SPADLET |p| (SUBLISLIS |args| |$TriangleVariableList| |p|)) + (SUBLISLIS |args| |$FormalMapVariableList| |p|))) + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document}