diff --git a/changelog b/changelog index 1bea0f4..f05ae22 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +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 +20090827 tpd src/interp/define.boot removed, rewritten to define.lisp 20090827 tpd src/axiom-website/patches.html 20090827.04.tpd.patch 20090827 tpd src/interp/Makefile move c-util.boot to c-util.lisp 20090827 tpd src/interp/c-util.lisp added, rewritten from c-util.boot diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index cbea030..38ed8b4 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -1918,5 +1918,7 @@ c-doc.lisp rewrite from boot to lisp
category.lisp rewrite from boot to lisp
20090827.04.tpd.patch c-util.lisp rewrite from boot to lisp
+20090827.05.tpd.patch +define.lisp rewrite from boot to lisp
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index b35b0dc..9264cb9 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -2505,51 +2505,26 @@ ${MID}/database.lisp: ${IN}/database.lisp.pamphlet @ -\subsection{define.boot} -<>= -${AUTO}/define.${O}: ${OUT}/define.${O} - @ echo 245 making ${AUTO}/define.${O} from ${OUT}/define.${O} - @ cp ${OUT}/define.${O} ${AUTO} - -@ +\subsection{define.lisp} <>= -${OUT}/define.${O}: ${MID}/define.clisp - @ echo 246 making ${OUT}/define.${O} from ${MID}/define.clisp - @ (cd ${MID} ; \ +${OUT}/define.${O}: ${MID}/define.lisp + @ echo 136 making ${OUT}/define.${O} from ${MID}/define.lisp + @ ( cd ${MID} ; \ if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/define.clisp"' \ + echo '(progn (compile-file "${MID}/define.lisp"' \ ':output-file "${OUT}/define.${O}") (${BYE}))' | ${DEPSYS} ; \ else \ - echo '(progn (compile-file "${MID}/define.clisp"' \ + echo '(progn (compile-file "${MID}/define.lisp"' \ ':output-file "${OUT}/define.${O}") (${BYE}))' | ${DEPSYS} \ >${TMP}/trace ; \ fi ) @ -<>= -${MID}/define.clisp: ${IN}/define.boot.pamphlet - @ echo 247 making ${MID}/define.clisp from ${IN}/define.boot.pamphlet +<>= +${MID}/define.lisp: ${IN}/define.lisp.pamphlet + @ echo 137 making ${MID}/define.lisp from ${IN}/define.lisp.pamphlet @ (cd ${MID} ; \ - ${TANGLE} ${IN}/define.boot.pamphlet >define.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "define.boot") (${BYE}))' \ - | ${DEPSYS} ; \ - else \ - echo '(progn (boottran::boottocl "define.boot") (${BYE}))' \ - | ${DEPSYS} >${TMP}/trace ; \ - fi ; \ - rm define.boot ) - -@ -<>= -${DOC}/define.boot.dvi: ${IN}/define.boot.pamphlet - @echo 248 making ${DOC}/define.boot.dvi from ${IN}/define.boot.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/define.boot.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} define.boot ; \ - rm -f ${DOC}/define.boot.pamphlet ; \ - rm -f ${DOC}/define.boot.tex ; \ - rm -f ${DOC}/define.boot ) + ${TANGLE} ${IN}/define.lisp.pamphlet >define.lisp ) @ @@ -5458,10 +5433,8 @@ clean: <> <> -<> <> -<> -<> +<> <> <> diff --git a/src/interp/define.boot.pamphlet b/src/interp/define.boot.pamphlet deleted file mode 100644 index 08a5310..0000000 --- a/src/interp/define.boot.pamphlet +++ /dev/null @@ -1,1550 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp define.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{compCapsuleItems} -The variable [[data]] appears to be unbound at runtime. Optimized -code won't check for this but interpreted code fails. We should -PROVE that data is unbound at runtime but have not done so yet. -Rather than remove the code entirely (since there MIGHT be a -path where it is used) we check for the runtime bound case and -assign [[$myFunctorBody]] if data has a value. - -The [[compCapsuleInner]] function in this file LOOKS like it sets -data and expects code to manipulate the assigned data structure. -Since we can't be sure we take the least disruptive course of action. -<>= -compCapsuleItems(itemlist,$predl,$e) == - $TOP__LEVEL: local := nil - $myFunctorBody :local -- := data ---needed for translator - if (BOUNDP 'data) then $myFunctorBody:=data -- unbound at runtime? - $signatureOfForm: local := nil - $suffix: local:= 0 - for item in itemlist repeat $e:= compSingleCapsuleItem(item,$predl,$e) - $e - -@ -\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. - -@ -<<*>>= -<> - ---% FUNCTIONS WHICH MUNCH ON == STATEMENTS - -compDefine(form,m,e) == - $tripleCache: local:= nil - $tripleHits: local:= 0 - $macroIfTrue: local := nil - $packagesUsed: local := nil - result:= compDefine1(form,m,e) - result - -compDefine1(form,m,e) == - $insideExpressionIfTrue: local:= false - --1. decompose after macro-expanding form - ['DEF,lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e) - $insideWhereIfTrue and isMacro(form,e) and (m=$EmptyMode or m=$NoValueMode) - => [lhs,m,put(first lhs,'macro,rhs,e)] - null signature.target and not MEMQ(KAR rhs,$ConstructorNames) and - (sig:= getSignatureFromMode(lhs,e)) => - -- here signature of lhs is determined by a previous declaration - compDefine1(['DEF,lhs,[first sig,:rest signature],specialCases,rhs],m,e) - $insideCapsuleFunctionIfTrue => - --stackAndThrow ["Internal functions unsupported:",form] - compInternalFunction(form,m,e) - if signature.target=$Category then $insideCategoryIfTrue:= true ---?? following 3 lines seem bogus, BMT 6/23/93 ---? if signature.target is ['Mapping,:map] then ---? signature:= map ---? form:= ['DEF,lhs,signature,specialCases,rhs] - --- RDJ (11/83): when argument and return types are all declared, --- or arguments have types declared in the environment, --- and there is no existing modemap for this signature, add --- the modemap by a declaration, then strip off declarations and recurse - e := compDefineAddSignature(lhs,signature,e) --- 2. if signature list for arguments is not empty, replace ('DEF,..) by --- ('where,('DEF,..),..) with an empty signature list; --- otherwise, fill in all NILs in the signature - not (and/[null x for x in rest signature]) => compDefWhereClause(form,m,e) - signature.target=$Category => - compDefineCategory(form,m,e,nil,$formalArgList) - isDomainForm(rhs,e) and not $insideFunctorIfTrue => - if null signature.target then signature:= - [getTargetFromRhs(lhs,rhs,giveFormalParametersValues(rest lhs,e)),: - rest signature] - rhs:= addEmptyCapsuleIfNecessary(signature.target,rhs) - compDefineFunctor(['DEF,lhs,signature,specialCases,rhs],m,e,nil, - $formalArgList) - null $form => stackAndThrow ['"bad == form ",form] - newPrefix:= - $prefix => INTERN STRCONC(encodeItem $prefix,'",",encodeItem $op) - getAbbreviation($op,#rest $form) - compDefineCapsuleFunction(form,m,e,newPrefix,$formalArgList) - -compDefineAddSignature([op,:argl],signature,e) == - (sig:= hasFullSignature(argl,signature,e)) and - not ASSOC(['$,:sig],LASSOC('modemap,getProplist(op,e))) => - declForm:= - [":",[op,:[[":",x,m] for x in argl for m in rest sig]],first signature] - [.,.,e]:= comp(declForm,$EmptyMode,e) - e - e - -hasFullSignature(argl,[target,:ml],e) == - target => - u:= [m or get(x,"mode",e) or return 'failed for x in argl for m in ml] - u^='failed => [target,:u] - -addEmptyCapsuleIfNecessary(target,rhs) == - MEMQ(KAR rhs,$SpecialDomainNames) => rhs - ['add,rhs,['CAPSULE]] - -getTargetFromRhs(lhs,rhs,e) == - --undeclared target mode obtained from rhs expression - rhs is ['CAPSULE,:.] => - stackSemanticError(['"target category of ",lhs, - '" cannot be determined from definition"],nil) - rhs is ['SubDomain,D,:.] => getTargetFromRhs(lhs,D,e) - rhs is ['add,D,['CAPSULE,:.]] => getTargetFromRhs(lhs,D,e) - rhs is ['Record,:l] => ['RecordCategory,:l] - rhs is ['Union,:l] => ['UnionCategory,:l] - rhs is ['List,:l] => ['ListCategory,:l] - rhs is ['Vector,:l] => ['VectorCategory,:l] - [.,target,.]:= compOrCroak(rhs,$EmptyMode,e) - target - -giveFormalParametersValues(argl,e) == - for x in argl repeat - e:= put(x,'value,[genSomeVariable(),get(x,'mode,e),nil],e) - e - -macroExpandInPlace(x,e) == - y:= macroExpand(x,e) - atom x or atom y => y - RPLACA(x,first y) - RPLACD(x,rest y) - x - -macroExpand(x,e) == --not worked out yet - atom x => (u:= get(x,'macro,e) => macroExpand(u,e); x) - x is ['DEF,lhs,sig,spCases,rhs] => - ['DEF,macroExpand(lhs,e),macroExpandList(sig,e),macroExpandList(spCases,e), - macroExpand(rhs,e)] - macroExpandList(x,e) - -macroExpandList(l,e) == - -- macros should override niladic props - (l is [name]) and IDENTP name and GETDATABASE(name, 'NILADIC) and - (u := get(name, 'macro, e)) => macroExpand(u,e) - [macroExpand(x,e) for x in l] - -compDefineCategory1(df is ['DEF,form,sig,sc,body],m,e,prefix,fal) == - categoryCapsule := ---+ - body is ['add,cat,capsule] => - body := cat - capsule - nil - [d,m,e]:= compDefineCategory2(form,sig,sc,body,m,e,prefix,fal) ---+ next two lines - if categoryCapsule and not $bootStrapMode then [.,.,e] := - $insideCategoryPackageIfTrue: local := true --see NRTmakeSlot1 ---> - $categoryPredicateList: local := - makeCategoryPredicates(form,$lisplibCategory) - compDefine1(mkCategoryPackage(form,cat,categoryCapsule),$EmptyMode,e) - [d,m,e] - -makeCategoryPredicates(form,u) == - $tvl := TAKE(#rest form,$TriangleVariableList) - $mvl := TAKE(#rest form,rest $FormalMapVariableList) - fn(u,nil) where - fn(u,pl) == - u is ['Join,:.,a] => fn(a,pl) - u is ['has,:.] => insert(EQSUBSTLIST($mvl,$tvl,u),pl) - u is [op,:.] and MEMQ(op,'(SIGNATURE ATTRIBUTE)) => pl - atom u => pl - fnl(u,pl) - fnl(u,pl) == - for x in u repeat pl := fn(x,pl) - pl - ---+ the following function -mkCategoryPackage(form is [op,:argl],cat,def) == - packageName:= INTERN(STRCONC(PNAME op,'"&")) - packageAbb := INTERN(STRCONC(GETDATABASE(op,'ABBREVIATION),'"-")) - $options:local := [] - -- This stops the next line from becoming confused - abbreviationsSpad2Cmd ['domain,packageAbb,packageName] - -- This is a little odd, but the parser insists on calling - -- domains, rather than packages - nameForDollar := first SETDIFFERENCE('(S A B C D E F G H I),argl) - packageArgl := [nameForDollar,:argl] - capsuleDefAlist := fn(def,nil) where fn(x,oplist) == - atom x => oplist - x is ['DEF,y,:.] => [y,:oplist] - fn(rest x,fn(first x,oplist)) - explicitCatPart := gn cat where gn cat == - cat is ['CATEGORY,:.] => rest rest cat - cat is ['Join,:u] => gn last u - nil - catvec := eval mkEvalableCategoryForm form - fullCatOpList:=JoinInner([catvec],$e).1 - catOpList := - --note: this gets too many modemaps in general - -- this is cut down in NRTmakeSlot1 - [['SIGNATURE,op1,sig] for [[op1,sig],:.] in fullCatOpList - --above line calls the category constructor just compiled - | ASSOC(op1,capsuleDefAlist)] - null catOpList => nil - packageCategory := ['CATEGORY,'domain, - :SUBLISLIS(argl,$FormalMapVariableList,catOpList)] - nils:= [nil for x in argl] - packageSig := [packageCategory,form,:nils] - $categoryPredicateList := SUBST(nameForDollar,'$,$categoryPredicateList) - SUBST(nameForDollar,'$, - ['DEF,[packageName,:packageArgl],packageSig,[nil,:nils],def]) - -compDefineCategory2(form,signature,specialCases,body,m,e, - $prefix,$formalArgList) == - --1. bind global variables - $insideCategoryIfTrue: local:= true - $TOP__LEVEL: local := nil - $definition: local := nil - --used by DomainSubstitutionFunction - $form: local := nil - $op: local := nil - $extraParms: local := nil - --Set in DomainSubstitutionFunction, used further down --- 1.1 augment e to add declaration $:
- [$op,:argl]:= $definition:= form - e:= addBinding("$",[['mode,:$definition]],e) - --- 2. obtain signature - signature':= - [first signature,:[getArgumentModeOrMoan(a,$definition,e) for a in argl]] - e:= giveFormalParametersValues(argl,e) - --- 3. replace arguments by $1,..., substitute into body, --- and introduce declarations into environment - sargl:= TAKE(# argl, $TriangleVariableList) - $functorForm:= $form:= [$op,:sargl] - $formalArgList:= [:sargl,:$formalArgList] - aList:= [[a,:sa] for a in argl for sa in sargl] - formalBody:= SUBLIS(aList,body) - signature' := SUBLIS(aList,signature') ---Begin lines for category default definitions - $functionStats: local:= [0,0] - $functorStats: local:= [0,0] - $frontier: local := 0 - $getDomainCode: local := nil - $addForm: local:= nil - for x in sargl for t in rest signature' repeat - [.,.,e]:= compMakeDeclaration([":",x,t],m,e) - --- 4. compile body in environment of %type declarations for arguments - op':= $op - -- following line causes cats with no with or Join to be fresh copies - if opOf(formalBody)^='Join and opOf(formalBody)^='mkCategory then - formalBody := ['Join, formalBody] - body:= optFunctorBody (compOrCroak(formalBody,signature'.target,e)).expr - if $extraParms then - formals:=actuals:=nil - for u in $extraParms repeat - formals:=[CAR u,:formals] - actuals:=[MKQ CDR u,:actuals] - body := ['sublisV,['PAIR,['QUOTE,formals],['LIST,:actuals]],body] - if argl then body:= -- always subst for args after extraparms - ['sublisV,['PAIR,['QUOTE,sargl],['LIST,: - [['devaluate,u] for u in sargl]]],body] - body:= - ['PROG1,['LET,g:= GENSYM(),body],['SETELT,g,0,mkConstructor $form]] - fun:= compile [op',['LAM,sargl,body]] - --- 5. give operator a 'modemap property - pairlis:= [[a,:v] for a in argl for v in $FormalMapVariableList] - parSignature:= SUBLIS(pairlis,signature') - parForm:= SUBLIS(pairlis,form) - lisplibWrite('"compilerInfo", - removeZeroOne ['SETQ,'$CategoryFrame, - ['put,['QUOTE,op'],' - (QUOTE isCategory),true,['addModemap,MKQ op',MKQ parForm, - MKQ parSignature,true,MKQ fun,'$CategoryFrame]]],$libFile) - --Equivalent to the following two lines, we hope - if null sargl then - evalAndRwriteLispForm('NILADIC, - ['MAKEPROP,['QUOTE,op'],'(QUOTE NILADIC),true]) - --- 6. put modemaps into InteractiveModemapFrame - $domainShell := eval [op',:MAPCAR('MKQ,sargl)] - $lisplibCategory:= formalBody - if $LISPLIB then - $lisplibForm:= form - $lisplibKind:= 'category - modemap:= [[parForm,:parSignature],[true,op']] - $lisplibModemap:= modemap - $lisplibParents := - getParentsFor($op,$FormalMapVariableList,$lisplibCategory) - $lisplibAncestors := computeAncestorsOf($form,nil) - $lisplibAbbreviation := constructor? $op - form':=[op',:sargl] - augLisplibModemapsFromCategory(form',formalBody,signature') - [fun,'(Category),e] - -mkConstructor form == - atom form => ['devaluate,form] - null rest form => ['QUOTE,[first form]] - ['LIST,MKQ first form,:[mkConstructor x for x in rest form]] - -compDefineCategory(df,m,e,prefix,fal) == - $domainShell: local -- holds the category of the object being compiled - $lisplibCategory: local := nil - not $insideFunctorIfTrue and $LISPLIB => - compDefineLisplib(df,m,e,prefix,fal,'compDefineCategory1) - compDefineCategory1(df,m,e,prefix,fal) - -compDefineFunctor(df,m,e,prefix,fal) == - $domainShell: local -- holds the category of the object being compiled - $profileCompiler: local := true - $profileAlist: local := nil - $LISPLIB => compDefineLisplib(df,m,e,prefix,fal,'compDefineFunctor1) - compDefineFunctor1(df,m,e,prefix,fal) - -compDefineFunctor1(df is ['DEF,form,signature,$functorSpecialCases,body], - m,$e,$prefix,$formalArgList) == - if NRTPARSE = true then - [lineNumber,:$functorSpecialCases] := $functorSpecialCases --- 1. bind global variables - $addForm: local := nil - $viewNames: local:= nil - - --This list is only used in genDomainViewName, for generating names - --for alternate views, if they do not already exist. - --format: Alist: (domain name . sublist) - --sublist is alist: category . name of view - $functionStats: local:= [0,0] - $functorStats: local:= [0,0] - $form: local := nil - $op: local := nil - $signature: local := nil - $functorTarget: local := nil - $Representation: local := nil - --Set in doIt, accessed in the compiler - compNoStacking - $LocalDomainAlist: local := nil --set in doIt, accessed in genDeltaEntry - $LocalDomainAlist := nil - $functorForm: local := nil - $functorLocalParameters: local := nil - SETQ($myFunctorBody, body) - $CheckVectorList: local := nil - --prevents CheckVector from printing out same message twice - $getDomainCode: local := nil -- code for getting views - $insideFunctorIfTrue: local:= true - $functorsUsed: local := nil --not currently used, finds dependent functors - $setelt: local := - $QuickCode = true => 'QSETREFV - 'SETELT - $TOP__LEVEL: local := nil - $genFVar: local:= 0 - $genSDVar: local:= 0 - originale:= $e - [$op,:argl]:= form - $formalArgList:= [:argl,:$formalArgList] - $pairlis := [[a,:v] for a in argl for v in $FormalMapVariableList] - $mutableDomain: local := - -- all defaulting packages should have caching turned off - isCategoryPackageName $op or - (if BOUNDP '$mutableDomains then MEMQ($op,$mutableDomains) - else false ) --true if domain has mutable state - signature':= - [first signature,:[getArgumentModeOrMoan(a,form,$e) for a in argl]] - $functorForm:= $form:= [$op,:argl] - if null first signature' then signature':= - modemap2Signature getModemap($form,$e) - target:= first signature' - $functorTarget:= target - $e:= giveFormalParametersValues(argl,$e) - [ds,.,$e]:= compMakeCategoryObject(target,$e) or ---+ copy needed since slot1 is reset; compMake.. can return a cached vector - sayBrightly '" cannot produce category object:" - pp target - return nil - $domainShell:= COPY_-SEQ ds - $attributesName:local := INTERN STRCONC(PNAME $op,'";attributes") - attributeList := disallowNilAttribute ds.2 --see below under "loadTimeAlist" ---+ 7 lines for $NRT follow - $goGetList: local := nil --->--these globals used by NRTmakeCategoryAlist, set by NRTsetVector4Part1 - $condAlist: local := nil - $uncondAlist: local := nil --->>-- next global initialized here, reset by NRTbuildFunctor - $NRTslot1PredicateList: local := - REMDUP [CADR x for x in attributeList] --->>-- next global initialized here, used by NRTgenAttributeAlist (NRUNOPT) - $NRTattributeAlist: local := NRTgenInitialAttributeAlist attributeList - $NRTslot1Info: local --set in NRTmakeSlot1 called by NRTbuildFunctor - --this is used below to set $lisplibSlot1 global - $NRTbase: local := 6 -- equals length of $domainShell - $NRTaddForm: local := nil -- see compAdd; NRTmakeSlot1 - $NRTdeltaList: local := nil --list of misc. elts used in compiled fncts - $NRTdeltaListComp: local := nil --list of COMP-ed forms for $NRTdeltaList - $NRTaddList: local := nil --list of fncts not defined in capsule (added) - $NRTdeltaLength: local := 0 -- =length of block of extra entries in vector - $NRTloadTimeAlist: local := nil --used for things in slot4 (NRTsetVector4) - $NRTdomainFormList: local := nil -- of form ((gensym . (Repe...)) ... - -- the above optimizes the calls to local domains - $template: local:= nil --stored in the lisplib (if $NRTvec = true) - $functionLocations: local := nil --locations of defined functions in source - -- generate slots for arguments first, then for $NRTaddForm in compAdd - for x in argl repeat NRTgetLocalIndex x - [.,.,$e]:= compMakeDeclaration([":",'_$,target],m,$e) - --The following loop sees if we can economise on ADDed operations - --by using those of Rep, if that is the same. Example: DIRPROD - if $insideCategoryPackageIfTrue^= true then - if body is ['add,ab:=[fn,:.],['CAPSULE,:cb]] and MEMQ(fn,'(List Vector)) - and FindRep(cb) = ab - where FindRep cb == - u:= - while cb repeat - ATOM cb => return nil - cb is [['LET,'Rep,v,:.],:.] => return (u:=v) - cb:=CDR cb - u - then $e:= augModemapsFromCategoryRep('_$,ab,cb,target,$e) - else $e:= augModemapsFromCategory('_$,'_$,'_$,target,$e) - $signature:= signature' - operationAlist:= SUBLIS($pairlis,$domainShell.(1)) - parSignature:= SUBLIS($pairlis,signature') - parForm:= SUBLIS($pairlis,form) - --- (3.1) now make a list of the functor's local parameters; for --- domain D in argl,check its signature: if domain, its type is Join(A1,..,An); --- in this case, D is replaced by D1,..,Dn (gensyms) which are set --- to the A1,..,An view of D - if isPackageFunction() then $functorLocalParameters:= - [nil,: - [nil - for i in 6..MAXINDEX $domainShell | - $domainShell.i is [.,.,['ELT,'_$,.]]]] - --leave space for vector ops and package name to be stored ---+ - $functorLocalParameters:= - argPars := - makeFunctorArgumentParameters(argl,rest signature',first signature') - -- must do above to bring categories into scope --see line 5 of genDomainView - argl --- 4. compile body in environment of %type declarations for arguments - op':= $op - rettype:= signature'.target - T:= compFunctorBody(body,rettype,$e,parForm) - -- If only compiling certain items, then ignore the body shell. - $compileOnlyCertainItems => - reportOnFunctorCompilation() - [nil, ['Mapping, :signature'], originale] - - body':= T.expr - lamOrSlam:= if $mutableDomain then 'LAM else 'SPADSLAM - fun:= compile SUBLIS($pairlis, [op',[lamOrSlam,argl,body']]) - --The above statement stops substitutions gettting in one another's way ---+ - operationAlist := SUBLIS($pairlis,$lisplibOperationAlist) - if $LISPLIB then - augmentLisplibModemapsFromFunctor(parForm,operationAlist,parSignature) - reportOnFunctorCompilation() - --- 5. give operator a 'modemap property --- if $functorsUsed then MAKEPROP(op',"NEEDS",$functorsUsed) - if $LISPLIB then - modemap:= [[parForm,:parSignature],[true,op']] - $lisplibModemap:= modemap - $lisplibCategory := modemap.mmTarget - $lisplibParents := - getParentsFor($op,$FormalMapVariableList,$lisplibCategory) - $lisplibAncestors := computeAncestorsOf($form,nil) - $lisplibAbbreviation := constructor? $op - $insideFunctorIfTrue:= false - if $LISPLIB then - $lisplibKind:= -------->This next line prohibits changing the KIND once given ---------kk:=GETDATABASE($op,'CONSTRUCTORKIND) => kk - $functorTarget is ["CATEGORY",key,:.] and key^="domain" => 'package - 'domain - $lisplibForm:= form - if null $bootStrapMode then - $NRTslot1Info := NRTmakeSlot1Info() - $isOpPackageName: local := isCategoryPackageName $op - if $isOpPackageName then lisplibWrite('"slot1DataBase", - ['updateSlot1DataBase,MKQ $NRTslot1Info],$libFile) - $lisplibFunctionLocations := SUBLIS($pairlis,$functionLocations) - $lisplibCategoriesExtended := SUBLIS($pairlis,$lisplibCategoriesExtended) - -- see NRTsetVector4 for initial setting of $lisplibCategoriesExtended - libFn := GETDATABASE(op','ABBREVIATION) - $lookupFunction: local := - NRTgetLookupFunction($functorForm,CADAR $lisplibModemap,$NRTaddForm) - --either lookupComplete (for forgetful guys) or lookupIncomplete - $byteAddress :local := 0 - $byteVec :local := nil - $NRTslot1PredicateList := - [simpBool x for x in $NRTslot1PredicateList] - rwriteLispForm('loadTimeStuff, - ['MAKEPROP,MKQ $op,''infovec,getInfovecCode()]) - $lisplibSlot1 := $NRTslot1Info --NIL or set by $NRTmakeSlot1 - $lisplibOperationAlist:= operationAlist - $lisplibMissingFunctions:= $CheckVectorList - lisplibWrite('"compilerInfo", - removeZeroOne ['SETQ,'$CategoryFrame, - ['put,['QUOTE,op'],' - (QUOTE isFunctor), - ['QUOTE,operationAlist],['addModemap,['QUOTE,op'],[' - QUOTE,parForm],['QUOTE,parSignature],true,['QUOTE,op'], - ['put,['QUOTE,op' ],'(QUOTE mode), - ['QUOTE,['Mapping,:parSignature]],'$CategoryFrame]]]], $libFile) - if null argl then - evalAndRwriteLispForm('NILADIC, - ['MAKEPROP, ['QUOTE,op'], ['QUOTE,'NILADIC], true]) - [fun,['Mapping,:signature'],originale] - -disallowNilAttribute x == - res := [y for y in x | car y and car y ^= "nil"] ---HACK to get rid of nil attibutes ---NOTE: nil is RENAMED to NIL - -compFunctorBody(body,m,e,parForm) == - $bootStrapMode = true => - [bootStrapError($functorForm, _/EDITFILE),m,e] - T:= compOrCroak(body,m,e) - body is [op,:.] and MEMQ(op,'(add CAPSULE)) => T - $NRTaddForm := - body is ["SubDomain",domainForm,predicate] => domainForm - body - T - -reportOnFunctorCompilation() == - displayMissingFunctions() - if $semanticErrorStack then sayBrightly '" " - displaySemanticErrors() - if $warningStack then sayBrightly '" " - displayWarnings() - $functorStats:= addStats($functorStats,$functionStats) - [byteCount,elapsedSeconds] := $functorStats - sayBrightly ['%l,:bright '" Cumulative Statistics for Constructor", - $op] - timeString := normalizeStatAndStringify elapsedSeconds - sayBrightly ['" Time:",:bright timeString,'"seconds"] - sayBrightly '" " - 'done - -displayMissingFunctions() == - null $CheckVectorList => nil - loc := nil - exp := nil - for [[op,sig,:.],:pred] in $CheckVectorList | null pred repeat - null MEMBER(op,$formalArgList) and - getmode(op,$env) is ['Mapping,:.] => - loc := [[op,sig],:loc] - exp := [[op,sig],:exp] - if loc then - sayBrightly ['%l,:bright '" Missing Local Functions:"] - for [op,sig] in loc for i in 1.. repeat - sayBrightly ['" [",i,'"]",:bright op, - ": ",:formatUnabbreviatedSig sig] - if exp then - sayBrightly ['%l,:bright '" Missing Exported Functions:"] - for [op,sig] in exp for i in 1.. repeat - sayBrightly ['" [",i,'"]",:bright op, - ": ",:formatUnabbreviatedSig sig] - ---% domain view code - -makeFunctorArgumentParameters(argl,sigl,target) == - $alternateViewList: local:= nil - $forceAdd: local:= true - $ConditionalOperators: local := nil - ("append"/[fn(a,augmentSig(s,findExtras(a,target))) - for a in argl for s in sigl]) where - findExtras(a,target) == - -- see if conditional information implies anything else - -- in the signature of a - target is ['Join,:l] => "union"/[findExtras(a,x) for x in l] - target is ['CATEGORY,.,:l] => "union"/[findExtras1(a,x) for x in l] where - findExtras1(a,x) == - x is ['AND,:l] => "union"/[findExtras1(a,y) for y in l] - x is ['OR,:l] => "union"/[findExtras1(a,y) for y in l] - x is ['IF,c,p,q] => - union(findExtrasP(a,c), - union(findExtras1(a,p),findExtras1(a,q))) where - findExtrasP(a,x) == - x is ['AND,:l] => "union"/[findExtrasP(a,y) for y in l] - x is ['OR,:l] => "union"/[findExtrasP(a,y) for y in l] - x is ['has,=a,y] and y is ['SIGNATURE,:.] => [y] - nil - nil - augmentSig(s,ss) == - -- if we find something extra, add it to the signature - null ss => s - for u in ss repeat - $ConditionalOperators:=[CDR u,:$ConditionalOperators] - s is ['Join,:sl] => - u:=ASSQ('CATEGORY,ss) => - SUBST([:u,:ss],u,s) - ['Join,:sl,['CATEGORY,'package,:ss]] - ['Join,s,['CATEGORY,'package,:ss]] - fn(a,s) == - isCategoryForm(s,$CategoryFrame) => - s is ["Join",:catlist] => genDomainViewList0(a,rest s) - [genDomainView(a,a,s,"getDomainView")] - [a] - -genDomainViewList0(id,catlist) == - l:= genDomainViewList(id,catlist,true) - l - -genDomainViewList(id,catlist,firsttime) == - null catlist => nil - catlist is [y] and not isCategoryForm(y,$EmptyEnvironment) => nil - [genDomainView(if firsttime then id else genDomainViewName(id,first catlist), - id,first catlist,"getDomainView"),:genDomainViewList(id,rest catlist,nil)] - -genDomainView(viewName,originalName,c,viewSelector) == - c is ['CATEGORY,.,:l] => genDomainOps(viewName,originalName,c) - code:= - c is ['SubsetCategory,c',.] => c' - c - $e:= augModemapsFromCategory(originalName,viewName,nil,c,$e) - --$alternateViewList:= ((viewName,:code),:$alternateViewList) - cd:= ['LET,viewName,[viewSelector,originalName,mkDomainConstructor code]] - if null MEMBER(cd,$getDomainCode) then - $getDomainCode:= [cd,:$getDomainCode] - viewName - -genDomainOps(viewName,dom,cat) == - oplist:= getOperationAlist(dom,dom,cat) - siglist:= [sig for [sig,:.] in oplist] - oplist:= substNames(dom,viewName,dom,oplist) - cd:= - ['LET,viewName,['mkOpVec,dom,['LIST,: - [['LIST,MKQ op,['LIST,:[mkDomainConstructor mode for mode in sig]]] - for [op,sig] in siglist]]]] - $getDomainCode:= [cd,:$getDomainCode] - for [opsig,cond,:.] in oplist for i in 0.. repeat - if opsig in $ConditionalOperators then cond:=nil - [op,sig]:=opsig - $e:= addModemap(op,dom,sig,cond,['ELT,viewName,i],$e) - viewName - -mkOpVec(dom,siglist) == - dom:= getPrincipalView dom - substargs:= [['$,:dom.0],: - [[a,:x] for a in $FormalMapVariableList for x in rest dom.0]] - oplist:= getOperationAlistFromLisplib opOf dom.0 - --new form is ( ) - ops:= MAKE_-VEC (#siglist) - for (opSig:= [op,sig]) in siglist for i in 0.. repeat - u:= ASSQ(op,oplist) - ASSOC(sig,u) is [.,n,.,'ELT] => ops.i := dom.n - noplist:= SUBLIS(substargs,u) - -- following variation on ASSOC needed for GENSYMS in Mutable domains - AssocBarGensym(SUBST(dom.0,'$,sig),noplist) is [.,n,.,'ELT] => - ops.i := dom.n - ops.i := [Undef,[dom.0,i],:opSig] - ops - -genDomainViewName(a,category) == ---+ - a - -compDefWhereClause(['DEF,form,signature,specialCases,body],m,e) == --- form is lhs (f a1 ... an) of definition; body is rhs; --- signature is (t0 t1 ... tn) where t0= target type, ti=type of ai, i > 0; --- specialCases is (NIL l1 ... ln) where li is list of special cases --- which can be given for each ti - --- removes declarative and assignment information from form and --- signature, placing it in list L, replacing form by ("where",form',:L), --- signature by a list of NILs (signifying declarations are in e) - $sigAlist: local := nil - $predAlist: local := nil - --- 1. create sigList= list of all signatures which have embedded --- declarations moved into global variable $sigAlist - sigList:= - [transformType fetchType(a,x,e,form) for a in rest form for x in rest signature] - where - fetchType(a,x,e,form) == - x => x - getmode(a,e) or userError concat( - '"There is no mode for argument",a,'"of function",first form) - transformType x == - atom x => x - x is [":",R,Rtype] => - ($sigAlist:= [[R,:transformType Rtype],:$sigAlist]; x) - x is ['Record,:.] => x --RDJ 8/83 - [first x,:[transformType y for y in rest x]] - --- 2. replace each argument of the form (|| x p) by x, recording --- the given predicate in global variable $predAlist - argList:= - [removeSuchthat a for a in rest form] where - removeSuchthat x == - x is ["|",y,p] => ($predAlist:= [[y,:p],:$predAlist]; y) - x - --- 3. obtain a list of parameter identifiers (x1 .. xn) ordered so that --- the type of xi is independent of xj if i < j - varList:= - orderByDependency(ASSOCLEFT argDepAlist,ASSOCRIGHT argDepAlist) where - argDepAlist:= - [[x,:dependencies] for [x,:y] in argSigAlist] where - dependencies() == - setUnion(listOfIdentifiersIn y, - DELETE(x,listOfIdentifiersIn LASSOC(x,$predAlist))) - argSigAlist:= [:$sigAlist,:pairList(argList,sigList)] - --- 4. construct a WhereList which declares and/or defines the xi's in --- the order constructed in step 3 - (whereList:= [addSuchthat(x,[":",x,LASSOC(x,argSigAlist)]) for x in varList]) - where addSuchthat(x,y) == (p:= LASSOC(x,$predAlist) => ["|",y,p]; y) - --- 5. compile new ('DEF,("where",form',:WhereList),:.) where --- all argument parameters of form' are bound/declared in WhereList - comp(form',m,e) where - form':= - ["where",defform,:whereList] where - defform:= - ['DEF,form'',signature',specialCases,body] where - form'':= [first form,:argList] - signature':= [first signature,:[nil for x in rest signature]] - -orderByDependency(vl,dl) == - -- vl is list of variables, dl is list of dependency-lists - selfDependents:= [v for v in vl for d in dl | MEMQ(v,d)] - for v in vl for d in dl | MEMQ(v,d) repeat - (SAY(v," depends on itself"); fatalError:= true) - fatalError => userError '"Parameter specification error" - until (null vl) repeat - newl:= - [v for v in vl for d in dl | null setIntersection(d,vl)] or return nil - orderedVarList:= [:newl,:orderedVarList] - vl':= setDifference(vl,newl) - dl':= [setDifference(d,newl) for x in vl for d in dl | MEMBER(x,vl')] - vl:= vl' - dl:= dl' - REMDUP NREVERSE orderedVarList --ordered so ith is indep. of jth if i < j - -compInternalFunction(df is ['DEF,form,signature,specialCases,body],m,e) == - -- $insideExpressionIfTrue:=false - [op,:argl]:=form - not(IDENTP(op)) => - stackAndThrow ["Bad name for internal function:",op] - #argl=0 => - stackAndThrow ["Argumentless internal functions unsupported:",op] - --nf:=["where",["LET",[":",op,["Mapping",:signature]],nbody],_ - -- :whereList1,:whereList2] - nbody:=["+->",argl,body] - nf:=["LET",[":",op,["Mapping",:signature]],nbody] - ress:=comp(nf,m,e) - ress - -compDefineCapsuleFunction(df is ['DEF,form,signature,specialCases,body], - m,oldE,$prefix,$formalArgList) == - [lineNumber,:specialCases] := specialCases - e := oldE - --1. bind global variables - $form: local := nil - $op: local := nil - $functionStats: local:= [0,0] - $argumentConditionList: local := nil - $finalEnv: local := nil - --used by ReplaceExitEtc to get a common environment - $initCapsuleErrorCount: local:= #$semanticErrorStack - $insideCapsuleFunctionIfTrue: local:= true - $CapsuleModemapFrame: local:= e - $CapsuleDomainsInScope: local:= get("$DomainsInScope","special",e) - $insideExpressionIfTrue: local:= true - $returnMode:= m - [$op,:argl]:= form - $form:= [$op,:argl] - argl:= stripOffArgumentConditions argl - $formalArgList:= [:argl,:$formalArgList] - - --let target and local signatures help determine modes of arguments - argModeList:= - identSig:= hasSigInTargetCategory(argl,form,first signature,e) => - (e:= checkAndDeclare(argl,form,identSig,e); rest identSig) - [getArgumentModeOrMoan(a,form,e) for a in argl] - argModeList:= stripOffSubdomainConditions(argModeList,argl) - signature':= [first signature,:argModeList] - if null identSig then --make $op a local function - oldE := put($op,'mode,['Mapping,:signature'],oldE) - - --obtain target type if not given - if null first signature' then signature':= - identSig => identSig - getSignature($op,rest signature',e) or return nil - e:= giveFormalParametersValues(argl,e) - - $signatureOfForm:= signature' --this global is bound in compCapsuleItems - $functionLocations := [[[$op,$signatureOfForm],:lineNumber], - :$functionLocations] - e:= addDomain(first signature',e) - e:= compArgumentConditions e - - if $profileCompiler then - for x in argl for t in rest signature' repeat profileRecord('arguments,x,t) - - - --4. introduce needed domains into extendedEnv - for domain in signature' repeat e:= addDomain(domain,e) - - --6. compile body in environment with extended environment - rettype:= resolve(signature'.target,$returnMode) - - localOrExported := - null MEMBER($op,$formalArgList) and - getmode($op,e) is ['Mapping,:.] => 'local - 'exported - - --6a skip if compiling only certain items but not this one - -- could be moved closer to the top - formattedSig := formatUnabbreviated ['Mapping,:signature'] - $compileOnlyCertainItems and _ - not MEMBER($op, $compileOnlyCertainItems) => - sayBrightly ['" skipping ", localOrExported,:bright $op] - [nil,['Mapping,:signature'],oldE] - sayBrightly ['" compiling ",localOrExported, - :bright $op,'": ",:formattedSig] - - if $newComp = true then - wholeBody := ['DEF, form, signature', specialCases, body] - T := CATCH('compCapsuleBody, newComp(wholeBody,$NoValueMode,e)) - or [" ",rettype,e] - T := [T.expr.2.2, rettype, T.env] - if $newCompCompare=true then - oldT := CATCH('compCapsuleBody, compOrCroak(body,rettype,e)) - or [" ",rettype,e] - SAY '"The old compiler generates:" - prTriple oldT - SAY '"The new compiler generates:" - prTriple T - else - T := CATCH('compCapsuleBody, compOrCroak(body,rettype,e)) - or [" ",rettype,e] ---+ - NRTassignCapsuleFunctionSlot($op,signature') - if $newCompCompare=true then - SAY '"The old compiler generates:" - prTriple T --- A THROW to the above CATCH occurs if too many semantic errors occur --- see stackSemanticError - catchTag:= MKQ GENSYM() - fun:= - body':= replaceExitEtc(T.expr,catchTag,"TAGGEDreturn",$returnMode) - body':= addArgumentConditions(body',$op) - finalBody:= ["CATCH",catchTag,body'] - compileCases([$op,["LAM",[:argl,'_$],finalBody]],oldE) - $functorStats:= addStats($functorStats,$functionStats) - - --- 7. give operator a 'value property - val:= [fun,signature',e] - [fun,['Mapping,:signature'],oldE] -- oldE:= put($op,'value,removeEnv val,e) - -getSignatureFromMode(form,e) == - getmode(opOf form,e) is ['Mapping,:signature] => - #form^=#signature => stackAndThrow ["Wrong number of arguments: ",form] - EQSUBSTLIST(rest form,take(#rest form,$FormalMapVariableList),signature) - -hasSigInTargetCategory(argl,form,opsig,e) == - mList:= [getArgumentMode(x,e) for x in argl] - --each element is a declared mode for the variable or nil if none exists - potentialSigList:= - REMDUP - [sig - for [[opName,sig,:.],:.] in $domainShell.(1) | - fn(opName,sig,opsig,mList,form)] where - fn(opName,sig,opsig,mList,form) == - opName=$op and #sig=#form and (null opsig or opsig=first sig) and - (and/[compareMode2Arg(x,m) for x in mList for m in rest sig]) - c:= #potentialSigList - 1=c => first potentialSigList - --accept only those signatures op right length which match declared modes - 0=c => (#(sig:= getSignatureFromMode(form,e))=#form => sig; nil) - 1 - sig:= first potentialSigList - stackWarning ["signature of lhs not unique:",:bright sig,"chosen"] - sig - nil --this branch will force all arguments to be declared - -compareMode2Arg(x,m) == null x or modeEqual(x,m) - -getArgumentModeOrMoan(x,form,e) == - getArgumentMode(x,e) or - stackSemanticError(["argument ",x," of ",form," is not declared"],nil) - -getArgumentMode(x,e) == - STRINGP x => x - m:= get(x,'mode,e) => m - -checkAndDeclare(argl,form,sig,e) == - --- arguments with declared types must agree with those in sig; --- those that don't get declarations put into e - for a in argl for m in rest sig repeat - m1:= getArgumentMode(a,e) => - ^modeEqual(m1,m) => - stack:= [" ",:bright a,'"must have type ",m, - '" not ",m1,'%l,:stack] - e:= put(a,'mode,m,e) - if stack then - sayBrightly ['" Parameters of ",:bright first form, - '" are of wrong type:",'%l,:stack] - e - -getSignature(op,argModeList,$e) == - --tpd mmList:= get(op,'modemap,$e) - --tpd for [[dc,:sig],:.] in mmList repeat printSignature(" ",op,sig) - 1=# - (sigl:= - REMDUP - [sig - for [[dc,:sig],[pred,:.]] in (mmList:= get(op,'modemap,$e)) | dc='_$ - and rest sig=argModeList and knownInfo pred]) => first sigl - null sigl => - (u:= getmode(op,$e)) is ['Mapping,:sig] => sig - SAY '"************* USER ERROR **********" - SAY("available signatures for ",op,": ") - if null mmList - then SAY " NONE" - else for [[dc,:sig],:.] in mmList repeat printSignature(" ",op,sig) - printSignature("NEED ",op,["?",:argModeList]) - nil - for u in sigl repeat - for v in sigl | not (u=v) repeat - if SourceLevelSubsume(u,v) then sigl:= DELETE(v,sigl) - --before we complain about duplicate signatures, we should - --check that we do not have for example, a partial - as - --well as a total one. SourceLevelSubsume (from CATEGORY BOOT) - --should do this - 1=#sigl => first sigl - stackSemanticError(["duplicate signatures for ",op,": ",argModeList],nil) - ---% ARGUMENT CONDITION CODE - -stripOffArgumentConditions argl == - [f for x in argl for i in 1..] where - f() == - x is ["|",arg,condition] => - condition:= SUBST('_#1,arg,condition) - -- in case conditions are given in terms of argument names, replace - $argumentConditionList:= [[i,arg,condition],:$argumentConditionList] - arg - x - -stripOffSubdomainConditions(margl,argl) == - [f for x in margl for arg in argl for i in 1..] where - f == - x is ['SubDomain,marg,condition] => - pair:= ASSOC(i,$argumentConditionList) => - (RPLAC(CADR pair,MKPF([condition,CADR pair],'AND)); marg) - $argumentConditionList:= [[i,arg,condition],:$argumentConditionList] - marg - x - -compArgumentConditions e == - $argumentConditionList:= - [f for [n,a,x] in $argumentConditionList] where - f == - y:= SUBST(a,'_#1,x) - T := [.,.,e]:= compOrCroak(y,$Boolean,e) - [n,x,T.expr] - e - -addArgumentConditions($body,$functionName) == - $argumentConditionList => - --$body is only used in this function - fn $argumentConditionList where - fn clist == - clist is [[n,untypedCondition,typedCondition],:.] => - ['COND,[typedCondition,fn rest clist], - [$true,["argumentDataError",n, - MKQ untypedCondition,MKQ $functionName]]] - null clist => $body - systemErrorHere '"addArgumentConditions" - $body - -putInLocalDomainReferences (def := [opName,[lam,varl,body]]) == - $elt: local := ($QuickCode => 'QREFELT; 'ELT) ---+ - NRTputInTail CDDADR def - def - - -canCacheLocalDomain(dom,elt)== - dom is [op,'_$,n] and MEMQ(op,'(ELT QREFELT)) => nil - domargsglobal(dom) => - $functorLocalParameters:= [:$functorLocalParameters,dom] - PUSH([dom,GENVAR(),[elt,$selector,$funcLocLen]],$usedDomList) - $selcount:= $selcount+1 - $funcLocLen:= $funcLocLen+1 - nil - where - domargsglobal(dom) == - dom='_$ => true - IDENTP dom => MEMQ(dom,$functorLocalParameters) - ATOM dom => true - and/[domargsglobal(arg) for arg in rest dom] - - -compileCases(x,$e) == -- $e is referenced in compile - $specialCaseKeyList: local := nil - not ($insideFunctorIfTrue=true) => compile x - specialCaseAssoc:= - [y for y in getSpecialCaseAssoc() | not get(first y,"specialCase",$e) and - ([R,R']:= y) and isEltArgumentIn(FindNamesFor(R,R'),x)] where - FindNamesFor(R,R') == - [R,: - [v - for ['LET,v,u,:.] in $getDomainCode | CADR u=R and - eval substitute(R',R,u)]] - isEltArgumentIn(Rlist,x) == - atom x => nil - x is ['ELT,R,.] => MEMQ(R,Rlist) or isEltArgumentIn(Rlist,rest x) - x is ["QREFELT",R,.] => MEMQ(R,Rlist) or isEltArgumentIn(Rlist,rest x) - isEltArgumentIn(Rlist,first x) or isEltArgumentIn(Rlist,rest x) - null specialCaseAssoc => compile x - listOfDomains:= ASSOCLEFT specialCaseAssoc - listOfAllCases:= outerProduct ASSOCRIGHT specialCaseAssoc - cl:= - [u for l in listOfAllCases] where - u() == - $specialCaseKeyList:= [[D,:C] for D in listOfDomains for C in l] - [MKPF([["EQUAL",D,C] for D in listOfDomains for C in l],"AND"), - compile COPY x] - $specialCaseKeyList:= nil - ["COND",:cl,[$true,compile x]] - -getSpecialCaseAssoc() == - [[R,:l] for R in rest $functorForm - for l in rest $functorSpecialCases | l] - -compile u == - [op,lamExpr] := u - if $suffix then - $suffix:= $suffix+1 - op':= - opexport:=nil - opmodes:= - [sel - for [[DC,:sig],[.,sel]] in get(op,'modemap,$e) | - DC='_$ and (opexport:=true) and - (and/[modeEqual(x,y) for x in sig for y in $signatureOfForm])] - isLocalFunction op => - if opexport then userError ['%b,op,'%d,'" is local and exported"] - INTERN STRCONC(encodeItem $prefix,'";",encodeItem op) where - isLocalFunction op == - null MEMBER(op,$formalArgList) and - getmode(op,$e) is ['Mapping,:.] - isPackageFunction() and KAR $functorForm^="CategoryDefaults" => - if null opmodes then userError ['"no modemap for ",op] - opmodes is [['PAC,.,name]] => name - encodeFunctionName(op,$functorForm,$signatureOfForm,";",$suffix) - encodeFunctionName(op,$functorForm,$signatureOfForm,";",$suffix) - u:= [op',lamExpr] - -- If just updating certain functions, check for previous existence. - -- Deduce old sequence number and use it (items have been skipped). - if $LISPLIB and $compileOnlyCertainItems then - parts := splitEncodedFunctionName(u.0, ";") --- Next line JHD/SMWATT 7/17/86 to deal with inner functions - parts='inner => $savableItems:=[u.0,:$savableItems] - unew := nil - for [s,t] in $splitUpItemsAlreadyThere repeat - if parts.0=s.0 and parts.1=s.1 and parts.2=s.2 then unew := t - null unew => - sayBrightly ['" Error: Item did not previously exist"] - sayBrightly ['" Item not saved: ", :bright u.0] - sayBrightly ['" What's there is: ", $lisplibItemsAlreadyThere] - nil - sayBrightly ['" Renaming ", u.0, '" as ", unew] - u := [unew, :rest u] - $savableItems := [unew, :$saveableItems] -- tested by embedded RWRITE - optimizedBody:= optimizeFunctionDef u - stuffToCompile:= - if null $insideCapsuleFunctionIfTrue - then optimizedBody - else putInLocalDomainReferences optimizedBody - $doNotCompileJustPrint=true => (PRETTYPRINT stuffToCompile; op') - $macroIfTrue => constructMacro stuffToCompile - result:= spadCompileOrSetq stuffToCompile - functionStats:=[0,elapsedTime()] - $functionStats:= addStats($functionStats,functionStats) - printStats functionStats - result - -spadCompileOrSetq (form is [nam,[lam,vl,body]]) == - --bizarre hack to take account of the existence of "known" functions - --good for performance (LISPLLIB size, BPI size, NILSEC) - CONTAINED(" ",body) => sayBrightly ['" ",:bright nam,'" not compiled"] - if vl is [:vl',E] and body is [nam',: =vl'] then - LAM_,EVALANDFILEACTQ ['PUT,MKQ nam,MKQ 'SPADreplace,MKQ nam'] - sayBrightly ['" ",:bright nam,'"is replaced by",:bright nam'] - else if (ATOM body or and/[ATOM x for x in body]) - and vl is [:vl',E] and not CONTAINED(E,body) then - macform := ['XLAM,vl',body] - LAM_,EVALANDFILEACTQ ['PUT,MKQ nam,MKQ 'SPADreplace,MKQ macform] - sayBrightly ['" ",:bright nam,'"is replaced by",:bright body] - $insideCapsuleFunctionIfTrue => first COMP LIST form - compileConstructor form - -compileConstructor form == - u:= compileConstructor1 form - clearClams() --clear all CLAMmed functions - u - -compileConstructor1 (form:=[fn,[key,vl,:bodyl]]) == --- fn is the name of some category/domain/package constructor; --- we will cache all of its values on $ConstructorCache with reference --- counts - $clamList: local := nil - lambdaOrSlam := - GETDATABASE(fn,'CONSTRUCTORKIND) = 'category => 'SPADSLAM - $mutableDomain => 'LAMBDA - $clamList:= - [[fn,"$ConstructorCache",'domainEqualList,'count],:$clamList] - 'LAMBDA - compForm:= LIST [fn,[lambdaOrSlam,vl,:bodyl]] - if GETDATABASE(fn,'CONSTRUCTORKIND) = 'category - then u:= compAndDefine compForm - else u:=COMP compForm - clearConstructorCache fn --clear cache for constructor - first u - -constructMacro (form is [nam,[lam,vl,body]]) == - ^(and/[atom x for x in vl]) => - stackSemanticError(["illegal parameters for macro: ",vl],nil) - ["XLAM",vl':= [x for x in vl | IDENTP x],body] - -listInitialSegment(u,v) == - null u => true - null v => nil - first u=first v and listInitialSegment(rest u,rest v) - --returns true iff u.i=v.i for i in 1..(#u)-1 - -modemap2Signature [[.,:sig],:.] == sig - -uncons x == - atom x => x - x is ["CONS",a,b] => [a,:uncons b] - ---% CAPSULE - -bootStrapError(functorForm,sourceFile) == - ['COND, _ - ['$bootStrapMode, _ - ['VECTOR,mkDomainConstructor functorForm,nil,nil,nil,nil,nil]], - [''T, ['systemError,['LIST,''%b,MKQ CAR functorForm,''%d,'"from", _ - ''%b,MKQ namestring sourceFile,''%d,'"needs to be compiled"]]]] - -compAdd(['add,$addForm,capsule],m,e) == - $bootStrapMode = true => - if $addForm is ['Tuple,:.] then code := nil - else [code,m,e]:= comp($addForm,m,e) - [['COND, _ - ['$bootStrapMode, _ - code],_ - [''T, ['systemError,['LIST,''%b,MKQ CAR $functorForm,''%d,'"from", _ - ''%b,MKQ namestring _/EDITFILE,''%d,'"needs to be compiled"]]]],m,e] - $addFormLhs: local:= $addForm - if $addForm is ["SubDomain",domainForm,predicate] then - $packagesUsed := [domainForm,:$packagesUsed] ---+ - $NRTaddForm := domainForm - NRTgetLocalIndex domainForm - --need to generate slot for add form since all $ go-get - -- slots will need to access it - [$addForm,.,e]:= compSubDomain1(domainForm,predicate,m,e) - else - $packagesUsed := - $addForm is ['Tuple,:u] => [:u,:$packagesUsed] - [$addForm,:$packagesUsed] ---+ - $NRTaddForm := $addForm - [$addForm,.,e]:= - $addForm is ['Tuple,:.] => - $NRTaddForm := ['Tuple,:[NRTgetLocalIndex x for x in rest $addForm]] - compOrCroak(compTuple2Record $addForm,$EmptyMode,e) - compOrCroak($addForm,$EmptyMode,e) - compCapsule(capsule,m,e) - -compTuple2Record u == ['Record,:[[":",i,x] for i in 1.. for x in rest u]] - -compCapsule(['CAPSULE,:itemList],m,e) == - $bootStrapMode = true => - [bootStrapError($functorForm, _/EDITFILE),m,e] - $insideExpressionIfTrue: local:= false - compCapsuleInner(itemList,m,addDomain('_$,e)) - -compSubDomain(["SubDomain",domainForm,predicate],m,e) == - $addFormLhs: local:= domainForm - $addForm: local := nil - $NRTaddForm := domainForm - [$addForm,.,e]:= compSubDomain1(domainForm,predicate,m,e) ---+ - compCapsule(['CAPSULE],m,e) - -compSubDomain1(domainForm,predicate,m,e) == - [.,.,e]:= - compMakeDeclaration([":","#1",domainForm],$EmptyMode,addDomain(domainForm,e)) - u:= - compOrCroak(predicate,$Boolean,e) or - stackSemanticError(["predicate: ",predicate, - " cannot be interpreted with #1: ",domainForm],nil) - prefixPredicate:= lispize u.expr - $lisplibSuperDomain:= - [domainForm,predicate] - evalAndRwriteLispForm('evalOnLoad2, - ['SETQ,'$CategoryFrame,['put,op':= ['QUOTE,$op],' - (QUOTE SuperDomain),dF':= ['QUOTE,domainForm],['put,dF','(QUOTE SubDomain),[ - 'CONS,['QUOTE,[$op,:prefixPredicate]],['DELASC,op',['get,dF',' - (QUOTE SubDomain),'$CategoryFrame]]],'$CategoryFrame]]]) - [domainForm,m,e] - -compCapsuleInner(itemList,m,e) == - e:= addInformation(m,e) - --puts a new 'special' property of $Information - data:= ["PROGN",:itemList] - --RPLACd by compCapsuleItems and Friends - e:= compCapsuleItems(itemList,nil,e) - localParList:= $functorLocalParameters - if $addForm then data:= ['add,$addForm,data] - code:= - $insideCategoryIfTrue and not $insideCategoryPackageIfTrue => data - processFunctorOrPackage($form,$signature,data,localParList,m,e) - [MKPF([:$getDomainCode,code],"PROGN"),m,e] - ---% PROCESS FUNCTOR CODE - -processFunctor(form,signature,data,localParList,e) == - form is ["CategoryDefaults"] => - error "CategoryDefaults is a reserved name" - buildFunctor(form,signature,data,localParList,e) - -<> -compSingleCapsuleItem(item,$predl,$e) == - doIt(macroExpandInPlace(item,$e),$predl) - $e - -doIt(item,$predl) == - $GENNO: local:= 0 - item is ['SEQ,:l,['exit,1,x]] => - RPLACA(item,"PROGN") - RPLACA(LASTNODE item,x) - for it1 in rest item repeat $e:= compSingleCapsuleItem(it1,$predl,$e) - --This will RPLAC as appropriate - isDomainForm(item,$e) => - -- convert naked top level domains to import - u:= ['import, [first item,:rest item]] - stackWarning ["Use: import ", [first item,:rest item]] - RPLACA(item,first u) - RPLACD(item,rest u) - doIt(item,$predl) - item is ['LET,lhs,rhs,:.] => - not (compOrCroak(item,$EmptyMode,$e) is [code,.,$e]) => - stackSemanticError(["cannot compile assigned value to",:bright lhs],nil) - not (code is ['LET,lhs',rhs',:.] and atom lhs') => - code is ["PROGN",:.] => - stackSemanticError(["multiple assignment ",item," not allowed"],nil) - RPLACA(item,first code) - RPLACD(item,rest code) - lhs:= lhs' - if not MEMBER(KAR rhs,$NonMentionableDomainNames) and - not MEMQ(lhs, $functorLocalParameters) then - $functorLocalParameters:= [:$functorLocalParameters,lhs] - if code is ['LET,.,rhs',:.] and isDomainForm(rhs',$e) then - if isFunctor rhs' then - $functorsUsed:= insert(opOf rhs',$functorsUsed) - $packagesUsed:= insert([opOf rhs'],$packagesUsed) - if lhs="Rep" then - $Representation:= (get("Rep",'value,$e)).(0) - --$Representation bound by compDefineFunctor, used in compNoStacking ---+ - if $NRTopt = true - then NRTgetLocalIndex $Representation ---+ - $LocalDomainAlist:= --see genDeltaEntry - [[lhs,:SUBLIS($LocalDomainAlist,get(lhs,'value,$e).0)],:$LocalDomainAlist] ---+ - code is ['LET,:.] => - RPLACA(item,($QuickCode => 'QSETREFV;'SETELT)) - rhsCode:= - rhs' - RPLACD(item,['$,NRTgetLocalIndexClear lhs,rhsCode]) - RPLACA(item,first code) - RPLACD(item,rest code) - item is [":",a,t] => [.,.,$e]:= compOrCroak(item,$EmptyMode,$e) - item is ['import,:doms] => - for dom in doms repeat - sayBrightly ['" importing ",:formatUnabbreviated dom] - [.,.,$e] := compOrCroak(item,$EmptyMode,$e) - RPLACA(item,'PROGN) - RPLACD(item,NIL) -- creates a no-op - item is ["IF",:.] => doItIf(item,$predl,$e) - item is ["where",b,:l] => compOrCroak(item,$EmptyMode,$e) - item is ["MDEF",:.] => [.,.,$e]:= compOrCroak(item,$EmptyMode,$e) - item is ['DEF,[op,:.],:.] => - body:= isMacro(item,$e) => $e:= put(op,'macro,body,$e) - [.,.,$e]:= t:= compOrCroak(item,$EmptyMode,$e) - RPLACA(item,"CodeDefine") - --Note that DescendCode, in CodeDefine, is looking for this - RPLACD(CADR item,[$signatureOfForm]) - --This is how the signature is updated for buildFunctor to recognise ---+ - functionPart:= ['dispatchFunction,t.expr] - RPLACA(CDDR item,functionPart) - RPLACD(CDDR item,nil) - u:= compOrCroak(item,$EmptyMode,$e) => - ([code,.,$e]:= u; RPLACA(item,first code); RPLACD(item,rest code)) - true => cannotDo() - -isMacro(x,e) == - x is ['DEF,[op,:args],signature,specialCases,body] and - null get(op,'modemap,e) and null args and null get(op,'mode,e) - and signature is [nil] => body - -doItIf(item is [.,p,x,y],$predl,$e) == - olde:= $e - [p',.,$e]:= comp(p,$Boolean,$e) or userError ['"not a Boolean:",p] - oldFLP:=$functorLocalParameters - if x^="noBranch" then - compSingleCapsuleItem(x,$predl,getSuccessEnvironment(p,$e)) - x':=localExtras(oldFLP) - where localExtras(oldFLP) == - EQ(oldFLP,$functorLocalParameters) => NIL - flp1:=$functorLocalParameters - oldFLP':=oldFLP - n:=0 - while oldFLP' repeat - oldFLP':=CDR oldFLP' - flp1:=CDR flp1 - n:=n+1 - -- Now we have to add code to compile all the elements - -- of functorLocalParameters that were added during the - -- conditional compilation - nils:=ans:=[] - for u in flp1 repeat -- is =u form always an ATOM? - if ATOM u or (or/[v is [.,=u,:.] for v in $getDomainCode]) - then - nils:=[u,:nils] - else - gv := GENSYM() - ans:=[['LET,gv,u],:ans] - nils:=[gv,:nils] - n:=n+1 - $functorLocalParameters:=[:oldFLP,:NREVERSE nils] - NREVERSE ans - oldFLP:=$functorLocalParameters - if y^="noBranch" then - compSingleCapsuleItem(y,$predl,getInverseEnvironment(p,olde)) - y':=localExtras(oldFLP) - RPLACA(item,"COND") - RPLACD(item,[[p',x,:x'],['(QUOTE T),y,:y']]) - ---compSingleCapsuleIf(x,predl,e,$functorLocalParameters) == --- compSingleCapsuleItem(x,predl,e) - ---% CATEGORY AND DOMAIN FUNCTIONS -compContained(["CONTAINED",a,b],m,e) == - [a,ma,e]:= comp(a,$EmptyMode,e) or return nil - [b,mb,e]:= comp(b,$EmptyMode,e) or return nil - isCategoryForm(ma,e) and isCategoryForm(mb,e) => - (T:= [["CONTAINED",a,b],$Boolean,e]; convert(T,m)) - nil - -compJoin(["Join",:argl],m,e) == - catList:= [(compForMode(x,$Category,e) or return 'failed).expr for x in argl] - catList='failed => stackSemanticError(["cannot form Join of: ",argl],nil) - catList':= - [extract for x in catList] where - extract() == - isCategoryForm(x,e) => - parameters:= - UNION("append"/[getParms(y,e) for y in rest x],parameters) - where getParms(y,e) == - atom y => - isDomainForm(y,e) => LIST y - nil - y is ['LENGTH,y'] => [y,y'] - LIST y - x - x is ["DomainSubstitutionMacro",pl,body] => - (parameters:= UNION(pl,parameters); body) - x is ["mkCategory",:.] => x - atom x and getmode(x,e)=$Category => x - stackSemanticError(["invalid argument to Join: ",x],nil) - x - T:= [wrapDomainSub(parameters,["Join",:catList']),$Category,e] - convert(T,m) - -compForMode(x,m,e) == - $compForModeIfTrue: local:= true - comp(x,m,e) - -compMakeCategoryObject(c,$e) == - not isCategoryForm(c,$e) => nil - u:= mkEvalableCategoryForm c => [eval u,$Category,$e] - nil - -quotifyCategoryArgument x == MKQ x - -makeCategoryForm(c,e) == - not isCategoryForm(c,e) => nil - [x,m,e]:= compOrCroak(c,$EmptyMode,e) - [x,e] - -compCategory(x,m,e) == - $TOP__LEVEL: local:= true - (m:= resolve(m,["Category"]))=["Category"] and x is ['CATEGORY, - domainOrPackage,:l] => - $sigList: local := nil - $atList: local := nil - $sigList:= $atList:= nil - for x in l repeat compCategoryItem(x,nil) - rep:= mkExplicitCategoryFunction(domainOrPackage,$sigList,$atList) - --if inside compDefineCategory, provide for category argument substitution - [rep,m,e] - systemErrorHere '"compCategory" - -mkExplicitCategoryFunction(domainOrPackage,sigList,atList) == - body:= - ["mkCategory",MKQ domainOrPackage,['LIST,:REVERSE sigList],['LIST,: - REVERSE atList],MKQ domList,nil] where - domList() == - ("UNION"/[fn sig for ["QUOTE",[[.,sig,:.],:.]] in sigList]) where - fn sig == [D for D in sig | mustInstantiate D] - parameters:= - REMDUP - ("append"/ - [[x for x in sig | IDENTP x and x^='_$] - for ["QUOTE",[[.,sig,:.],:.]] in sigList]) - wrapDomainSub(parameters,body) - -wrapDomainSub(parameters,x) == - ["DomainSubstitutionMacro",parameters,x] - -mustInstantiate D == - D is [fn,:.] and ^(MEMQ(fn,$DummyFunctorNames) or GET(fn,"makeFunctionList")) - -DomainSubstitutionFunction(parameters,body) == - --see definition of DomainSubstitutionMacro in SPAD LISP - if parameters then - (body:= Subst(parameters,body)) where - Subst(parameters,body) == - ATOM body => - MEMQ(body,parameters) => MKQ body - body - MEMBER(body,parameters) => - g:=GENSYM() - $extraParms:=PUSH([g,:body],$extraParms) - --Used in SetVector12 to generate a substitution list - --bound in buildFunctor - --For categories, bound and used in compDefineCategory - MKQ g - first body="QUOTE" => body - PAIRP $definition and - isFunctor first body and - first body ^= first $definition - => ['QUOTE,optimize body] - [Subst(parameters,u) for u in body] - not (body is ["Join",:.]) => body - atom $definition => body - null rest $definition => body - --should not bother if it will only be called once - name:= INTERN STRCONC(KAR $definition,";CAT") - SETANDFILE(name,nil) - body:= ["COND",[name],['(QUOTE T),['SETQ,name,body]]] - body - -compCategoryItem(x,predl) == - x is nil => nil - --1. if x is a conditional expression, recurse; otherwise, form the predicate - x is ["COND",[p,e]] => - predl':= [p,:predl] - e is ["PROGN",:l] => for y in l repeat compCategoryItem(y,predl') - compCategoryItem(e,predl') - x is ["IF",a,b,c] => - predl':= [a,:predl] - if b^="noBranch" then - b is ["PROGN",:l] => for y in l repeat compCategoryItem(y,predl') - compCategoryItem(b,predl') - c="noBranch" => nil - predl':= [["not",a],:predl] - c is ["PROGN",:l] => for y in l repeat compCategoryItem(y,predl') - compCategoryItem(c,predl') - pred:= (predl => MKPF(predl,"AND"); true) - - --2. if attribute, push it and return - x is ["ATTRIBUTE",y] => PUSH(MKQ [y,pred],$atList) - - --3. it may be a list, with PROGN as the CAR, and some information as the CDR - x is ["PROGN",:l] => for u in l repeat compCategoryItem(u,predl) - --- 4. otherwise, x gives a signature for a --- single operator name or a list of names; if a list of names, --- recurse - ["SIGNATURE",op,:sig]:= x - null atom op => - for y in op repeat compCategoryItem(["SIGNATURE",y,:sig],predl) - - --4. branch on a single type or a signature %with source and target - PUSH(MKQ [rest x,pred],$sigList) - - - - - - - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/define.lisp.pamphlet b/src/interp/define.lisp.pamphlet new file mode 100644 index 0000000..6c9b06b --- /dev/null +++ b/src/interp/define.lisp.pamphlet @@ -0,0 +1,6549 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp define.lisp} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +<<*>>= +(IN-PACKAGE "BOOT" ) + +;--% FUNCTIONS WHICH MUNCH ON == STATEMENTS +; +;compDefine(form,m,e) == +; $tripleCache: local:= nil +; $tripleHits: local:= 0 +; $macroIfTrue: local := nil +; $packagesUsed: local := nil +; result:= compDefine1(form,m,e) +; result + +(DEFUN |compDefine| (|form| |m| |e|) + (PROG (|$tripleCache| |$tripleHits| |$macroIfTrue| |$packagesUsed| + |result|) + (DECLARE (SPECIAL |$tripleCache| |$tripleHits| |$macroIfTrue| + |$packagesUsed|)) + (RETURN + (PROGN + (SPADLET |$tripleCache| NIL) + (SPADLET |$tripleHits| 0) + (SPADLET |$macroIfTrue| NIL) + (SPADLET |$packagesUsed| NIL) + (SPADLET |result| (|compDefine1| |form| |m| |e|)) + |result|)))) + +;compDefine1(form,m,e) == +; $insideExpressionIfTrue: local:= false +; --1. decompose after macro-expanding form +; ['DEF,lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e) +; $insideWhereIfTrue and isMacro(form,e) and (m=$EmptyMode or m=$NoValueMode) +; => [lhs,m,put(first lhs,'macro,rhs,e)] +; null signature.target and not MEMQ(KAR rhs,$ConstructorNames) and +; (sig:= getSignatureFromMode(lhs,e)) => +; -- here signature of lhs is determined by a previous declaration +; compDefine1(['DEF,lhs,[first sig,:rest signature],specialCases,rhs],m,e) +; $insideCapsuleFunctionIfTrue => +; --stackAndThrow ["Internal functions unsupported:",form] +; compInternalFunction(form,m,e) +; if signature.target=$Category then $insideCategoryIfTrue:= true +;--?? following 3 lines seem bogus, BMT 6/23/93 +;--? if signature.target is ['Mapping,:map] then +;--? signature:= map +;--? form:= ['DEF,lhs,signature,specialCases,rhs] +; +;-- RDJ (11/83): when argument and return types are all declared, +;-- or arguments have types declared in the environment, +;-- and there is no existing modemap for this signature, add +;-- the modemap by a declaration, then strip off declarations and recurse +; e := compDefineAddSignature(lhs,signature,e) +;-- 2. if signature list for arguments is not empty, replace ('DEF,..) by +;-- ('where,('DEF,..),..) with an empty signature list; +;-- otherwise, fill in all NILs in the signature +; not (and/[null x for x in rest signature]) => compDefWhereClause(form,m,e) +; signature.target=$Category => +; compDefineCategory(form,m,e,nil,$formalArgList) +; isDomainForm(rhs,e) and not $insideFunctorIfTrue => +; if null signature.target then signature:= +; [getTargetFromRhs(lhs,rhs,giveFormalParametersValues(rest lhs,e)),: +; rest signature] +; rhs:= addEmptyCapsuleIfNecessary(signature.target,rhs) +; compDefineFunctor(['DEF,lhs,signature,specialCases,rhs],m,e,nil, +; $formalArgList) +; null $form => stackAndThrow ['"bad == form ",form] +; newPrefix:= +; $prefix => INTERN STRCONC(encodeItem $prefix,'",",encodeItem $op) +; getAbbreviation($op,#rest $form) +; compDefineCapsuleFunction(form,m,e,newPrefix,$formalArgList) + +(DEFUN |compDefine1| (|form| |m| |e|) + (PROG (|$insideExpressionIfTrue| |lhs| |specialCases| |sig| + |signature| |rhs| |newPrefix|) + (DECLARE (SPECIAL |$insideExpressionIfTrue|)) + (RETURN + (SEQ (PROGN + (SPADLET |$insideExpressionIfTrue| NIL) + (SPADLET |form| (|macroExpand| |form| |e|)) + (SPADLET |lhs| (CADR |form|)) + (SPADLET |signature| (CADDR |form|)) + (SPADLET |specialCases| (CADDDR |form|)) + (SPADLET |rhs| (CAR (CDDDDR |form|))) + (COND + ((AND |$insideWhereIfTrue| (|isMacro| |form| |e|) + (OR (BOOT-EQUAL |m| |$EmptyMode|) + (BOOT-EQUAL |m| |$NoValueMode|))) + (CONS |lhs| + (CONS |m| + (CONS (|put| (CAR |lhs|) '|macro| |rhs| + |e|) + NIL)))) + ((AND (NULL (CAR |signature|)) + (NULL (MEMQ (KAR |rhs|) |$ConstructorNames|)) + (SPADLET |sig| (|getSignatureFromMode| |lhs| |e|))) + (|compDefine1| + (CONS 'DEF + (CONS |lhs| + (CONS (CONS (CAR |sig|) + (CDR |signature|)) + (CONS |specialCases| + (CONS |rhs| NIL))))) + |m| |e|)) + (|$insideCapsuleFunctionIfTrue| + (|compInternalFunction| |form| |m| |e|)) + ('T + (COND + ((BOOT-EQUAL (CAR |signature|) |$Category|) + (SPADLET |$insideCategoryIfTrue| 'T))) + (SPADLET |e| + (|compDefineAddSignature| |lhs| |signature| + |e|)) + (COND + ((NULL (PROG (G166088) + (SPADLET G166088 'T) + (RETURN + (DO ((G166094 NIL (NULL G166088)) + (G166095 (CDR |signature|) + (CDR G166095)) + (|x| NIL)) + ((OR G166094 (ATOM G166095) + (PROGN + (SETQ |x| (CAR G166095)) + NIL)) + G166088) + (SEQ (EXIT + (SETQ G166088 + (AND G166088 (NULL |x|))))))))) + (|compDefWhereClause| |form| |m| |e|)) + ((BOOT-EQUAL (CAR |signature|) |$Category|) + (|compDefineCategory| |form| |m| |e| NIL + |$formalArgList|)) + ((AND (|isDomainForm| |rhs| |e|) + (NULL |$insideFunctorIfTrue|)) + (COND + ((NULL (CAR |signature|)) + (SPADLET |signature| + (CONS (|getTargetFromRhs| |lhs| |rhs| + (|giveFormalParametersValues| + (CDR |lhs|) |e|)) + (CDR |signature|))))) + (SPADLET |rhs| + (|addEmptyCapsuleIfNecessary| + (CAR |signature|) |rhs|)) + (|compDefineFunctor| + (CONS 'DEF + (CONS |lhs| + (CONS |signature| + (CONS |specialCases| + (CONS |rhs| NIL))))) + |m| |e| NIL |$formalArgList|)) + ((NULL |$form|) + (|stackAndThrow| + (CONS (MAKESTRING "bad == form ") + (CONS |form| NIL)))) + ('T + (SPADLET |newPrefix| + (COND + (|$prefix| + (INTERN (STRCONC + (|encodeItem| |$prefix|) + (MAKESTRING ",") + (|encodeItem| |$op|)))) + ('T + (|getAbbreviation| |$op| + (|#| (CDR |$form|)))))) + (|compDefineCapsuleFunction| |form| |m| |e| + |newPrefix| |$formalArgList|)))))))))) + +;compDefineAddSignature([op,:argl],signature,e) == +; (sig:= hasFullSignature(argl,signature,e)) and +; not ASSOC(['$,:sig],LASSOC('modemap,getProplist(op,e))) => +; declForm:= +; [":",[op,:[[":",x,m] for x in argl for m in rest sig]],first signature] +; [.,.,e]:= comp(declForm,$EmptyMode,e) +; e +; e + +(DEFUN |compDefineAddSignature| (G166127 |signature| |e|) + (PROG (|op| |argl| |sig| |declForm| |LETTMP#1|) + (RETURN + (SEQ (PROGN + (SPADLET |op| (CAR G166127)) + (SPADLET |argl| (CDR G166127)) + (COND + ((AND (SPADLET |sig| + (|hasFullSignature| |argl| |signature| + |e|)) + (NULL (|assoc| (CONS '$ |sig|) + (LASSOC '|modemap| + (|getProplist| |op| |e|))))) + (SPADLET |declForm| + (CONS '|:| + (CONS (CONS |op| + (PROG (G166144) + (SPADLET G166144 NIL) + (RETURN + (DO + ((G166150 |argl| + (CDR G166150)) + (|x| NIL) + (G166151 (CDR |sig|) + (CDR G166151)) + (|m| NIL)) + ((OR (ATOM G166150) + (PROGN + (SETQ |x| + (CAR G166150)) + NIL) + (ATOM G166151) + (PROGN + (SETQ |m| + (CAR G166151)) + NIL)) + (NREVERSE0 G166144)) + (SEQ + (EXIT + (SETQ G166144 + (CONS + (CONS '|:| + (CONS |x| + (CONS |m| NIL))) + G166144)))))))) + (CONS (CAR |signature|) NIL)))) + (SPADLET |LETTMP#1| + (|comp| |declForm| |$EmptyMode| |e|)) + (SPADLET |e| (CADDR |LETTMP#1|)) |e|) + ('T |e|))))))) + +;hasFullSignature(argl,[target,:ml],e) == +; target => +; u:= [m or get(x,"mode",e) or return 'failed for x in argl for m in ml] +; u^='failed => [target,:u] + +(DEFUN |hasFullSignature| (|argl| G166171 |e|) + (PROG (|target| |ml| |u|) + (RETURN + (SEQ (PROGN + (SPADLET |target| (CAR G166171)) + (SPADLET |ml| (CDR G166171)) + (COND + (|target| + (PROGN + (SPADLET |u| + (PROG (G166185) + (SPADLET G166185 NIL) + (RETURN + (DO ((G166191 |argl| + (CDR G166191)) + (|x| NIL) + (G166192 |ml| (CDR G166192)) + (|m| NIL)) + ((OR (ATOM G166191) + (PROGN + (SETQ |x| (CAR G166191)) + NIL) + (ATOM G166192) + (PROGN + (SETQ |m| (CAR G166192)) + NIL)) + (NREVERSE0 G166185)) + (SEQ + (EXIT + (SETQ G166185 + (CONS + (OR |m| (|get| |x| '|mode| |e|) + (RETURN '|failed|)) + G166185)))))))) + (COND + ((NEQUAL |u| '|failed|) (CONS |target| |u|))))))))))) + +;addEmptyCapsuleIfNecessary(target,rhs) == +; MEMQ(KAR rhs,$SpecialDomainNames) => rhs +; ['add,rhs,['CAPSULE]] + +(DEFUN |addEmptyCapsuleIfNecessary| (|target| |rhs|) + (COND + ((MEMQ (KAR |rhs|) |$SpecialDomainNames|) |rhs|) + ('T (CONS '|add| (CONS |rhs| (CONS (CONS 'CAPSULE NIL) NIL)))))) + +;getTargetFromRhs(lhs,rhs,e) == +; --undeclared target mode obtained from rhs expression +; rhs is ['CAPSULE,:.] => +; stackSemanticError(['"target category of ",lhs, +; '" cannot be determined from definition"],nil) +; rhs is ['SubDomain,D,:.] => getTargetFromRhs(lhs,D,e) +; rhs is ['add,D,['CAPSULE,:.]] => getTargetFromRhs(lhs,D,e) +; rhs is ['Record,:l] => ['RecordCategory,:l] +; rhs is ['Union,:l] => ['UnionCategory,:l] +; rhs is ['List,:l] => ['ListCategory,:l] +; rhs is ['Vector,:l] => ['VectorCategory,:l] +; [.,target,.]:= compOrCroak(rhs,$EmptyMode,e) +; target + +(DEFUN |getTargetFromRhs| (|lhs| |rhs| |e|) + (PROG (|ISTMP#1| D |ISTMP#2| |ISTMP#3| |l| |LETTMP#1| |target|) + (RETURN + (COND + ((AND (PAIRP |rhs|) (EQ (QCAR |rhs|) 'CAPSULE)) + (|stackSemanticError| + (CONS (MAKESTRING "target category of ") + (CONS |lhs| + (CONS (MAKESTRING + " cannot be determined from definition") + NIL))) + NIL)) + ((AND (PAIRP |rhs|) (EQ (QCAR |rhs|) '|SubDomain|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |rhs|)) + (AND (PAIRP |ISTMP#1|) + (PROGN (SPADLET D (QCAR |ISTMP#1|)) 'T)))) + (|getTargetFromRhs| |lhs| D |e|)) + ((AND (PAIRP |rhs|) (EQ (QCAR |rhs|) '|add|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |rhs|)) + (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) + (PROGN + (SPADLET |ISTMP#3| (QCAR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCAR |ISTMP#3|) 'CAPSULE)))))))) + (|getTargetFromRhs| |lhs| D |e|)) + ((AND (PAIRP |rhs|) (EQ (QCAR |rhs|) '|Record|) + (PROGN (SPADLET |l| (QCDR |rhs|)) 'T)) + (CONS '|RecordCategory| |l|)) + ((AND (PAIRP |rhs|) (EQ (QCAR |rhs|) '|Union|) + (PROGN (SPADLET |l| (QCDR |rhs|)) 'T)) + (CONS '|UnionCategory| |l|)) + ((AND (PAIRP |rhs|) (EQ (QCAR |rhs|) '|List|) + (PROGN (SPADLET |l| (QCDR |rhs|)) 'T)) + (CONS '|ListCategory| |l|)) + ((AND (PAIRP |rhs|) (EQ (QCAR |rhs|) '|Vector|) + (PROGN (SPADLET |l| (QCDR |rhs|)) 'T)) + (CONS '|VectorCategory| |l|)) + ('T (SPADLET |LETTMP#1| (|compOrCroak| |rhs| |$EmptyMode| |e|)) + (SPADLET |target| (CADR |LETTMP#1|)) |target|))))) + +;giveFormalParametersValues(argl,e) == +; for x in argl repeat +; e:= put(x,'value,[genSomeVariable(),get(x,'mode,e),nil],e) +; e + +(DEFUN |giveFormalParametersValues| (|argl| |e|) + (SEQ (PROGN + (DO ((G166259 |argl| (CDR G166259)) (|x| NIL)) + ((OR (ATOM G166259) + (PROGN (SETQ |x| (CAR G166259)) NIL)) + NIL) + (SEQ (EXIT (SPADLET |e| + (|put| |x| '|value| + (CONS (|genSomeVariable|) + (CONS (|get| |x| '|mode| |e|) + (CONS NIL NIL))) + |e|))))) + |e|))) + +;macroExpandInPlace(x,e) == +; y:= macroExpand(x,e) +; atom x or atom y => y +; RPLACA(x,first y) +; RPLACD(x,rest y) +; x + +(DEFUN |macroExpandInPlace| (|x| |e|) + (PROG (|y|) + (RETURN + (PROGN + (SPADLET |y| (|macroExpand| |x| |e|)) + (COND + ((OR (ATOM |x|) (ATOM |y|)) |y|) + ('T (RPLACA |x| (CAR |y|)) (RPLACD |x| (CDR |y|)) |x|)))))) + +;macroExpand(x,e) == --not worked out yet +; atom x => (u:= get(x,'macro,e) => macroExpand(u,e); x) +; x is ['DEF,lhs,sig,spCases,rhs] => +; ['DEF,macroExpand(lhs,e),macroExpandList(sig,e),macroExpandList(spCases,e), +; macroExpand(rhs,e)] +; macroExpandList(x,e) + +(DEFUN |macroExpand| (|x| |e|) + (PROG (|u| |ISTMP#1| |lhs| |ISTMP#2| |sig| |ISTMP#3| |spCases| + |ISTMP#4| |rhs|) + (RETURN + (COND + ((ATOM |x|) + (COND + ((SPADLET |u| (|get| |x| '|macro| |e|)) + (|macroExpand| |u| |e|)) + ('T |x|))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'DEF) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |lhs| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |sig| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |spCases| + (QCAR |ISTMP#3|)) + (SPADLET |ISTMP#4| + (QCDR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) + (EQ (QCDR |ISTMP#4|) NIL) + (PROGN + (SPADLET |rhs| + (QCAR |ISTMP#4|)) + 'T)))))))))) + (CONS 'DEF + (CONS (|macroExpand| |lhs| |e|) + (CONS (|macroExpandList| |sig| |e|) + (CONS (|macroExpandList| |spCases| |e|) + (CONS (|macroExpand| |rhs| |e|) NIL)))))) + ('T (|macroExpandList| |x| |e|)))))) + +;macroExpandList(l,e) == +; -- macros should override niladic props +; (l is [name]) and IDENTP name and GETDATABASE(name, 'NILADIC) and +; (u := get(name, 'macro, e)) => macroExpand(u,e) +; [macroExpand(x,e) for x in l] + +(DEFUN |macroExpandList| (|l| |e|) + (PROG (|name| |u|) + (RETURN + (SEQ (COND + ((AND (PAIRP |l|) (EQ (QCDR |l|) NIL) + (PROGN (SPADLET |name| (QCAR |l|)) 'T) + (IDENTP |name|) (GETDATABASE |name| 'NILADIC) + (SPADLET |u| (|get| |name| '|macro| |e|))) + (|macroExpand| |u| |e|)) + ('T + (PROG (G166351) + (SPADLET G166351 NIL) + (RETURN + (DO ((G166356 |l| (CDR G166356)) (|x| NIL)) + ((OR (ATOM G166356) + (PROGN (SETQ |x| (CAR G166356)) NIL)) + (NREVERSE0 G166351)) + (SEQ (EXIT (SETQ G166351 + (CONS (|macroExpand| |x| |e|) + G166351))))))))))))) + +;compDefineCategory1(df is ['DEF,form,sig,sc,body],m,e,prefix,fal) == +; categoryCapsule := +;--+ +; body is ['add,cat,capsule] => +; body := cat +; capsule +; nil +; [d,m,e]:= compDefineCategory2(form,sig,sc,body,m,e,prefix,fal) +;--+ next two lines +; if categoryCapsule and not $bootStrapMode then [.,.,e] := +; $insideCategoryPackageIfTrue: local := true --see NRTmakeSlot1 +;--> +; $categoryPredicateList: local := +; makeCategoryPredicates(form,$lisplibCategory) +; compDefine1(mkCategoryPackage(form,cat,categoryCapsule),$EmptyMode,e) +; [d,m,e] + +(DEFUN |compDefineCategory1| (|df| |m| |e| |prefix| |fal|) + (PROG (|$insideCategoryPackageIfTrue| |$categoryPredicateList| |form| + |sig| |sc| |ISTMP#1| |cat| |ISTMP#2| |capsule| |body| + |categoryCapsule| |d| |LETTMP#1|) + (DECLARE (SPECIAL |$insideCategoryPackageIfTrue| + |$categoryPredicateList|)) + (RETURN + (PROGN + (SPADLET |form| (CADR |df|)) + (SPADLET |sig| (CADDR |df|)) + (SPADLET |sc| (CADDDR |df|)) + (SPADLET |body| (CAR (CDDDDR |df|))) + (SPADLET |categoryCapsule| + (COND + ((AND (PAIRP |body|) (EQ (QCAR |body|) '|add|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |body|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |cat| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |capsule| + (QCAR |ISTMP#2|)) + 'T)))))) + (SPADLET |body| |cat|) |capsule|) + ('T NIL))) + (SPADLET |LETTMP#1| + (|compDefineCategory2| |form| |sig| |sc| |body| |m| + |e| |prefix| |fal|)) + (SPADLET |d| (CAR |LETTMP#1|)) + (SPADLET |m| (CADR |LETTMP#1|)) + (SPADLET |e| (CADDR |LETTMP#1|)) + (COND + ((AND |categoryCapsule| (NULL |$bootStrapMode|)) + (SPADLET |LETTMP#1| + (PROGN + (SPADLET |$insideCategoryPackageIfTrue| 'T) + (SPADLET |$categoryPredicateList| + (|makeCategoryPredicates| |form| + |$lisplibCategory|)) + (|compDefine1| + (|mkCategoryPackage| |form| |cat| + |categoryCapsule|) + |$EmptyMode| |e|))) + (SPADLET |e| (CADDR |LETTMP#1|)) |LETTMP#1|)) + (CONS |d| (CONS |m| (CONS |e| NIL))))))) + +;makeCategoryPredicates(form,u) == +; $tvl := TAKE(#rest form,$TriangleVariableList) +; $mvl := TAKE(#rest form,rest $FormalMapVariableList) +; fn(u,nil) where +; fn(u,pl) == +; u is ['Join,:.,a] => fn(a,pl) +; u is ['has,:.] => insert(EQSUBSTLIST($mvl,$tvl,u),pl) +; u is [op,:.] and MEMQ(op,'(SIGNATURE ATTRIBUTE)) => pl +; atom u => pl +; fnl(u,pl) +; fnl(u,pl) == +; for x in u repeat pl := fn(x,pl) +; pl + +(DEFUN |makeCategoryPredicates,fnl| (|u| |pl|) + (SEQ (DO ((G166465 |u| (CDR G166465)) (|x| NIL)) + ((OR (ATOM G166465) + (PROGN (SETQ |x| (CAR G166465)) NIL)) + NIL) + (SEQ (EXIT (SPADLET |pl| + (|makeCategoryPredicates,fn| |x| |pl|))))) + (EXIT |pl|))) + +(DEFUN |makeCategoryPredicates,fn| (|u| |pl|) + (PROG (|ISTMP#1| |ISTMP#2| |a| |op|) + (RETURN + (SEQ (IF (AND (PAIRP |u|) (EQ (QCAR |u|) '|Join|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |u|)) + (AND (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| + (REVERSE |ISTMP#1|)) + 'T)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#2|)) + 'T))))) + (EXIT (|makeCategoryPredicates,fn| |a| |pl|))) + (IF (AND (PAIRP |u|) (EQ (QCAR |u|) '|has|)) + (EXIT (|insert| (EQSUBSTLIST |$mvl| |$tvl| |u|) |pl|))) + (IF (AND (AND (PAIRP |u|) + (PROGN (SPADLET |op| (QCAR |u|)) 'T)) + (MEMQ |op| '(SIGNATURE ATTRIBUTE))) + (EXIT |pl|)) + (IF (ATOM |u|) (EXIT |pl|)) + (EXIT (|makeCategoryPredicates,fnl| |u| |pl|)))))) + +(DEFUN |makeCategoryPredicates| (|form| |u|) + (PROGN + (SPADLET |$tvl| (TAKE (|#| (CDR |form|)) |$TriangleVariableList|)) + (SPADLET |$mvl| + (TAKE (|#| (CDR |form|)) (CDR |$FormalMapVariableList|))) + (|makeCategoryPredicates,fn| |u| NIL))) + +;--+ the following function +;mkCategoryPackage(form is [op,:argl],cat,def) == +; packageName:= INTERN(STRCONC(PNAME op,'"&")) +; packageAbb := INTERN(STRCONC(GETDATABASE(op,'ABBREVIATION),'"-")) +; $options:local := [] +; -- This stops the next line from becoming confused +; abbreviationsSpad2Cmd ['domain,packageAbb,packageName] +; -- This is a little odd, but the parser insists on calling +; -- domains, rather than packages +; nameForDollar := first SETDIFFERENCE('(S A B C D E F G H I),argl) +; packageArgl := [nameForDollar,:argl] +; capsuleDefAlist := fn(def,nil) where fn(x,oplist) == +; atom x => oplist +; x is ['DEF,y,:.] => [y,:oplist] +; fn(rest x,fn(first x,oplist)) +; explicitCatPart := gn cat where gn cat == +; cat is ['CATEGORY,:.] => rest rest cat +; cat is ['Join,:u] => gn last u +; nil +; catvec := eval mkEvalableCategoryForm form +; fullCatOpList:=JoinInner([catvec],$e).1 +; catOpList := +; --note: this gets too many modemaps in general +; -- this is cut down in NRTmakeSlot1 +; [['SIGNATURE,op1,sig] for [[op1,sig],:.] in fullCatOpList +; --above line calls the category constructor just compiled +; | ASSOC(op1,capsuleDefAlist)] +; null catOpList => nil +; packageCategory := ['CATEGORY,'domain, +; :SUBLISLIS(argl,$FormalMapVariableList,catOpList)] +; nils:= [nil for x in argl] +; packageSig := [packageCategory,form,:nils] +; $categoryPredicateList := SUBST(nameForDollar,'$,$categoryPredicateList) +; SUBST(nameForDollar,'$, +; ['DEF,[packageName,:packageArgl],packageSig,[nil,:nils],def]) + +(DEFUN |mkCategoryPackage,fn| (|x| |oplist|) + (PROG (|ISTMP#1| |y|) + (RETURN + (SEQ (IF (ATOM |x|) (EXIT |oplist|)) + (IF (AND (PAIRP |x|) (EQ (QCAR |x|) 'DEF) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN (SPADLET |y| (QCAR |ISTMP#1|)) 'T)))) + (EXIT (CONS |y| |oplist|))) + (EXIT (|mkCategoryPackage,fn| (CDR |x|) + (|mkCategoryPackage,fn| (CAR |x|) |oplist|))))))) + +(DEFUN |mkCategoryPackage,gn| (|cat|) + (PROG (|u|) + (RETURN + (SEQ (IF (AND (PAIRP |cat|) (EQ (QCAR |cat|) 'CATEGORY)) + (EXIT (CDR (CDR |cat|)))) + (IF (AND (PAIRP |cat|) (EQ (QCAR |cat|) '|Join|) + (PROGN (SPADLET |u| (QCDR |cat|)) 'T)) + (EXIT (|mkCategoryPackage,gn| (|last| |u|)))) + (EXIT NIL))))) + +(DEFUN |mkCategoryPackage| (|form| |cat| |def|) + (PROG (|$options| |op| |argl| |packageName| |packageAbb| + |nameForDollar| |packageArgl| |capsuleDefAlist| + |explicitCatPart| |catvec| |fullCatOpList| |op1| |sig| + |catOpList| |packageCategory| |nils| |packageSig|) + (DECLARE (SPECIAL |$options|)) + (RETURN + (SEQ (PROGN + (SPADLET |op| (CAR |form|)) + (SPADLET |argl| (CDR |form|)) + (SPADLET |packageName| + (INTERN (STRCONC (PNAME |op|) (MAKESTRING "&")))) + (SPADLET |packageAbb| + (INTERN (STRCONC (GETDATABASE |op| 'ABBREVIATION) + (MAKESTRING "-")))) + (SPADLET |$options| NIL) + (|abbreviationsSpad2Cmd| + (CONS '|domain| + (CONS |packageAbb| (CONS |packageName| NIL)))) + (SPADLET |nameForDollar| + (CAR (SETDIFFERENCE '(S A B C D E F G H I) + |argl|))) + (SPADLET |packageArgl| (CONS |nameForDollar| |argl|)) + (SPADLET |capsuleDefAlist| + (|mkCategoryPackage,fn| |def| NIL)) + (SPADLET |explicitCatPart| (|mkCategoryPackage,gn| |cat|)) + (SPADLET |catvec| + (|eval| (|mkEvalableCategoryForm| |form|))) + (SPADLET |fullCatOpList| + (ELT (|JoinInner| (CONS |catvec| NIL) |$e|) 1)) + (SPADLET |catOpList| + (PROG (G166528) + (SPADLET G166528 NIL) + (RETURN + (DO ((G166535 |fullCatOpList| + (CDR G166535)) + (G166506 NIL)) + ((OR (ATOM G166535) + (PROGN + (SETQ G166506 (CAR G166535)) + NIL) + (PROGN + (PROGN + (SPADLET |op1| (CAAR G166506)) + (SPADLET |sig| + (CADAR G166506)) + G166506) + NIL)) + (NREVERSE0 G166528)) + (SEQ (EXIT (COND + ((|assoc| |op1| + |capsuleDefAlist|) + (SETQ G166528 + (CONS + (CONS 'SIGNATURE + (CONS |op1| + (CONS |sig| NIL))) + G166528)))))))))) + (COND + ((NULL |catOpList|) NIL) + ('T + (SPADLET |packageCategory| + (CONS 'CATEGORY + (CONS '|domain| + (SUBLISLIS |argl| + |$FormalMapVariableList| + |catOpList|)))) + (SPADLET |nils| + (PROG (G166546) + (SPADLET G166546 NIL) + (RETURN + (DO ((G166551 |argl| (CDR G166551)) + (|x| NIL)) + ((OR (ATOM G166551) + (PROGN + (SETQ |x| (CAR G166551)) + NIL)) + (NREVERSE0 G166546)) + (SEQ (EXIT + (SETQ G166546 + (CONS NIL G166546)))))))) + (SPADLET |packageSig| + (CONS |packageCategory| (CONS |form| |nils|))) + (SPADLET |$categoryPredicateList| + (MSUBST |nameForDollar| '$ + |$categoryPredicateList|)) + (MSUBST |nameForDollar| '$ + (CONS 'DEF + (CONS (CONS |packageName| |packageArgl|) + (CONS |packageSig| + (CONS (CONS NIL |nils|) + (CONS |def| NIL))))))))))))) + +;compDefineCategory2(form,signature,specialCases,body,m,e, +; $prefix,$formalArgList) == +; --1. bind global variables +; $insideCategoryIfTrue: local:= true +; $TOP__LEVEL: local := nil +; $definition: local := nil +; --used by DomainSubstitutionFunction +; $form: local := nil +; $op: local := nil +; $extraParms: local := nil +; --Set in DomainSubstitutionFunction, used further down +;-- 1.1 augment e to add declaration $: +; [$op,:argl]:= $definition:= form +; e:= addBinding("$",[['mode,:$definition]],e) +; +;-- 2. obtain signature +; signature':= +; [first signature,:[getArgumentModeOrMoan(a,$definition,e) for a in argl]] +; e:= giveFormalParametersValues(argl,e) +; +;-- 3. replace arguments by $1,..., substitute into body, +;-- and introduce declarations into environment +; sargl:= TAKE(# argl, $TriangleVariableList) +; $functorForm:= $form:= [$op,:sargl] +; $formalArgList:= [:sargl,:$formalArgList] +; aList:= [[a,:sa] for a in argl for sa in sargl] +; formalBody:= SUBLIS(aList,body) +; signature' := SUBLIS(aList,signature') +;--Begin lines for category default definitions +; $functionStats: local:= [0,0] +; $functorStats: local:= [0,0] +; $frontier: local := 0 +; $getDomainCode: local := nil +; $addForm: local:= nil +; for x in sargl for t in rest signature' repeat +; [.,.,e]:= compMakeDeclaration([":",x,t],m,e) +; +;-- 4. compile body in environment of %type declarations for arguments +; op':= $op +; -- following line causes cats with no with or Join to be fresh copies +; if opOf(formalBody)^='Join and opOf(formalBody)^='mkCategory then +; formalBody := ['Join, formalBody] +; body:= optFunctorBody (compOrCroak(formalBody,signature'.target,e)).expr +; if $extraParms then +; formals:=actuals:=nil +; for u in $extraParms repeat +; formals:=[CAR u,:formals] +; actuals:=[MKQ CDR u,:actuals] +; body := ['sublisV,['PAIR,['QUOTE,formals],['LIST,:actuals]],body] +; if argl then body:= -- always subst for args after extraparms +; ['sublisV,['PAIR,['QUOTE,sargl],['LIST,: +; [['devaluate,u] for u in sargl]]],body] +; body:= +; ['PROG1,['LET,g:= GENSYM(),body],['SETELT,g,0,mkConstructor $form]] +; fun:= compile [op',['LAM,sargl,body]] +; +;-- 5. give operator a 'modemap property +; pairlis:= [[a,:v] for a in argl for v in $FormalMapVariableList] +; parSignature:= SUBLIS(pairlis,signature') +; parForm:= SUBLIS(pairlis,form) +; lisplibWrite('"compilerInfo", +; removeZeroOne ['SETQ,'$CategoryFrame, +; ['put,['QUOTE,op'],' +; (QUOTE isCategory),true,['addModemap,MKQ op',MKQ parForm, +; MKQ parSignature,true,MKQ fun,'$CategoryFrame]]],$libFile) +; --Equivalent to the following two lines, we hope +; if null sargl then +; evalAndRwriteLispForm('NILADIC, +; ['MAKEPROP,['QUOTE,op'],'(QUOTE NILADIC),true]) +; +;-- 6. put modemaps into InteractiveModemapFrame +; $domainShell := eval [op',:MAPCAR('MKQ,sargl)] +; $lisplibCategory:= formalBody +; if $LISPLIB then +; $lisplibForm:= form +; $lisplibKind:= 'category +; modemap:= [[parForm,:parSignature],[true,op']] +; $lisplibModemap:= modemap +; $lisplibParents := +; getParentsFor($op,$FormalMapVariableList,$lisplibCategory) +; $lisplibAncestors := computeAncestorsOf($form,nil) +; $lisplibAbbreviation := constructor? $op +; form':=[op',:sargl] +; augLisplibModemapsFromCategory(form',formalBody,signature') +; [fun,'(Category),e] + +(DEFUN |compDefineCategory2| + (|form| |signature| |specialCases| |body| |m| |e| |$prefix| + |$formalArgList|) + (DECLARE (SPECIAL |$prefix| |$formalArgList|)) + (PROG (|$insideCategoryIfTrue| $TOP_LEVEL |$definition| |$form| |$op| + |$extraParms| |$functionStats| |$functorStats| |$frontier| + |$getDomainCode| |$addForm| |argl| |sargl| |aList| + |signature'| |LETTMP#1| |op'| |formalBody| |formals| + |actuals| |g| |fun| |pairlis| |parSignature| |parForm| + |modemap| |form'|) + (DECLARE (SPECIAL |$insideCategoryIfTrue| $TOP_LEVEL |$definition| + |$form| |$op| |$extraParms| |$functionStats| + |$functorStats| |$frontier| |$getDomainCode| + |$addForm|)) + (RETURN + (SEQ (PROGN + (SPADLET |$insideCategoryIfTrue| 'T) + (SPADLET $TOP_LEVEL NIL) + (SPADLET |$definition| NIL) + (SPADLET |$form| NIL) + (SPADLET |$op| NIL) + (SPADLET |$extraParms| NIL) + (SPADLET |$definition| |form|) + (SPADLET |$op| (CAR |$definition|)) + (SPADLET |argl| (CDR |$definition|)) + (SPADLET |e| + (|addBinding| '$ + (CONS (CONS '|mode| |$definition|) NIL) |e|)) + (SPADLET |signature'| + (CONS (CAR |signature|) + (PROG (G166602) + (SPADLET G166602 NIL) + (RETURN + (DO ((G166607 |argl| (CDR G166607)) + (|a| NIL)) + ((OR (ATOM G166607) + (PROGN + (SETQ |a| (CAR G166607)) + NIL)) + (NREVERSE0 G166602)) + (SEQ (EXIT + (SETQ G166602 + (CONS + (|getArgumentModeOrMoan| |a| + |$definition| |e|) + G166602))))))))) + (SPADLET |e| (|giveFormalParametersValues| |argl| |e|)) + (SPADLET |sargl| + (TAKE (|#| |argl|) |$TriangleVariableList|)) + (SPADLET |$functorForm| + (SPADLET |$form| (CONS |$op| |sargl|))) + (SPADLET |$formalArgList| + (APPEND |sargl| |$formalArgList|)) + (SPADLET |aList| + (PROG (G166618) + (SPADLET G166618 NIL) + (RETURN + (DO ((G166624 |argl| (CDR G166624)) + (|a| NIL) + (G166625 |sargl| (CDR G166625)) + (|sa| NIL)) + ((OR (ATOM G166624) + (PROGN + (SETQ |a| (CAR G166624)) + NIL) + (ATOM G166625) + (PROGN + (SETQ |sa| (CAR G166625)) + NIL)) + (NREVERSE0 G166618)) + (SEQ (EXIT (SETQ G166618 + (CONS (CONS |a| |sa|) + G166618)))))))) + (SPADLET |formalBody| (SUBLIS |aList| |body|)) + (SPADLET |signature'| (SUBLIS |aList| |signature'|)) + (SPADLET |$functionStats| (CONS 0 (CONS 0 NIL))) + (SPADLET |$functorStats| (CONS 0 (CONS 0 NIL))) + (SPADLET |$frontier| 0) + (SPADLET |$getDomainCode| NIL) + (SPADLET |$addForm| NIL) + (DO ((G166641 |sargl| (CDR G166641)) (|x| NIL) + (G166642 (CDR |signature'|) (CDR G166642)) + (|t| NIL)) + ((OR (ATOM G166641) + (PROGN (SETQ |x| (CAR G166641)) NIL) + (ATOM G166642) + (PROGN (SETQ |t| (CAR G166642)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |LETTMP#1| + (|compMakeDeclaration| + (CONS '|:| + (CONS |x| (CONS |t| NIL))) + |m| |e|)) + (SPADLET |e| (CADDR |LETTMP#1|)) + |LETTMP#1|)))) + (SPADLET |op'| |$op|) + (COND + ((AND (NEQUAL (|opOf| |formalBody|) '|Join|) + (NEQUAL (|opOf| |formalBody|) '|mkCategory|)) + (SPADLET |formalBody| + (CONS '|Join| (CONS |formalBody| NIL))))) + (SPADLET |body| + (|optFunctorBody| + (CAR (|compOrCroak| |formalBody| + (CAR |signature'|) |e|)))) + (COND + (|$extraParms| + (SPADLET |formals| (SPADLET |actuals| NIL)) + (DO ((G166656 |$extraParms| (CDR G166656)) + (|u| NIL)) + ((OR (ATOM G166656) + (PROGN (SETQ |u| (CAR G166656)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |formals| + (CONS (CAR |u|) |formals|)) + (SPADLET |actuals| + (CONS (MKQ (CDR |u|)) + |actuals|)))))) + (SPADLET |body| + (CONS '|sublisV| + (CONS (CONS 'PAIR + (CONS + (CONS 'QUOTE + (CONS |formals| NIL)) + (CONS (CONS 'LIST |actuals|) + NIL))) + (CONS |body| NIL)))))) + (COND + (|argl| (SPADLET |body| + (CONS '|sublisV| + (CONS + (CONS 'PAIR + (CONS + (CONS 'QUOTE + (CONS |sargl| NIL)) + (CONS + (CONS 'LIST + (PROG (G166666) + (SPADLET G166666 NIL) + (RETURN + (DO + ((G166671 |sargl| + (CDR G166671)) + (|u| NIL)) + ((OR (ATOM G166671) + (PROGN + (SETQ |u| + (CAR G166671)) + NIL)) + (NREVERSE0 G166666)) + (SEQ + (EXIT + (SETQ G166666 + (CONS + (CONS '|devaluate| + (CONS |u| NIL)) + G166666)))))))) + NIL))) + (CONS |body| NIL)))))) + (SPADLET |body| + (CONS 'PROG1 + (CONS (CONS 'LET + (CONS (SPADLET |g| (GENSYM)) + (CONS |body| NIL))) + (CONS (CONS 'SETELT + (CONS |g| + (CONS 0 + (CONS + (|mkConstructor| |$form|) + NIL)))) + NIL)))) + (SPADLET |fun| + (|compile| + (CONS |op'| + (CONS (CONS 'LAM + (CONS |sargl| (CONS |body| NIL))) + NIL)))) + (SPADLET |pairlis| + (PROG (G166682) + (SPADLET G166682 NIL) + (RETURN + (DO ((G166688 |argl| (CDR G166688)) + (|a| NIL) + (G166689 |$FormalMapVariableList| + (CDR G166689)) + (|v| NIL)) + ((OR (ATOM G166688) + (PROGN + (SETQ |a| (CAR G166688)) + NIL) + (ATOM G166689) + (PROGN + (SETQ |v| (CAR G166689)) + NIL)) + (NREVERSE0 G166682)) + (SEQ (EXIT (SETQ G166682 + (CONS (CONS |a| |v|) G166682)))))))) + (SPADLET |parSignature| (SUBLIS |pairlis| |signature'|)) + (SPADLET |parForm| (SUBLIS |pairlis| |form|)) + (|lisplibWrite| (MAKESTRING "compilerInfo") + (|removeZeroOne| + (CONS 'SETQ + (CONS '|$CategoryFrame| + (CONS (CONS '|put| + (CONS + (CONS 'QUOTE (CONS |op'| NIL)) + (CONS ''|isCategory| + (CONS 'T + (CONS + (CONS '|addModemap| + (CONS (MKQ |op'|) + (CONS (MKQ |parForm|) + (CONS + (MKQ |parSignature|) + (CONS 'T + (CONS (MKQ |fun|) + (CONS + '|$CategoryFrame| + NIL))))))) + NIL))))) + NIL)))) + |$libFile|) + (COND + ((NULL |sargl|) + (|evalAndRwriteLispForm| 'NILADIC + (CONS 'MAKEPROP + (CONS (CONS 'QUOTE (CONS |op'| NIL)) + (CONS ''NILADIC (CONS 'T NIL))))))) + (SPADLET |$domainShell| + (|eval| (CONS |op'| (MAPCAR 'MKQ |sargl|)))) + (SPADLET |$lisplibCategory| |formalBody|) + (COND + ($LISPLIB (SPADLET |$lisplibForm| |form|) + (SPADLET |$lisplibKind| '|category|) + (SPADLET |modemap| + (CONS (CONS |parForm| |parSignature|) + (CONS (CONS 'T (CONS |op'| NIL)) NIL))) + (SPADLET |$lisplibModemap| |modemap|) + (SPADLET |$lisplibParents| + (|getParentsFor| |$op| + |$FormalMapVariableList| + |$lisplibCategory|)) + (SPADLET |$lisplibAncestors| + (|computeAncestorsOf| |$form| NIL)) + (SPADLET |$lisplibAbbreviation| + (|constructor?| |$op|)) + (SPADLET |form'| (CONS |op'| |sargl|)) + (|augLisplibModemapsFromCategory| |form'| + |formalBody| |signature'|))) + (CONS |fun| (CONS '(|Category|) (CONS |e| NIL)))))))) + +;mkConstructor form == +; atom form => ['devaluate,form] +; null rest form => ['QUOTE,[first form]] +; ['LIST,MKQ first form,:[mkConstructor x for x in rest form]] + +(DEFUN |mkConstructor| (|form|) + (PROG () + (RETURN + (SEQ (COND + ((ATOM |form|) (CONS '|devaluate| (CONS |form| NIL))) + ((NULL (CDR |form|)) + (CONS 'QUOTE (CONS (CONS (CAR |form|) NIL) NIL))) + ('T + (CONS 'LIST + (CONS (MKQ (CAR |form|)) + (PROG (G166784) + (SPADLET G166784 NIL) + (RETURN + (DO ((G166789 (CDR |form|) + (CDR G166789)) + (|x| NIL)) + ((OR (ATOM G166789) + (PROGN + (SETQ |x| (CAR G166789)) + NIL)) + (NREVERSE0 G166784)) + (SEQ (EXIT + (SETQ G166784 + (CONS (|mkConstructor| |x|) + G166784))))))))))))))) + +;compDefineCategory(df,m,e,prefix,fal) == +; $domainShell: local -- holds the category of the object being compiled +; $lisplibCategory: local := nil +; not $insideFunctorIfTrue and $LISPLIB => +; compDefineLisplib(df,m,e,prefix,fal,'compDefineCategory1) +; compDefineCategory1(df,m,e,prefix,fal) + +(DEFUN |compDefineCategory| (|df| |m| |e| |prefix| |fal|) + (PROG (|$domainShell| |$lisplibCategory|) + (DECLARE (SPECIAL |$domainShell| |$lisplibCategory|)) + (RETURN + (PROGN + (SPADLET |$domainShell| NIL) + (SPADLET |$lisplibCategory| NIL) + (COND + ((AND (NULL |$insideFunctorIfTrue|) $LISPLIB) + (|compDefineLisplib| |df| |m| |e| |prefix| |fal| + '|compDefineCategory1|)) + ('T (|compDefineCategory1| |df| |m| |e| |prefix| |fal|))))))) + +;compDefineFunctor(df,m,e,prefix,fal) == +; $domainShell: local -- holds the category of the object being compiled +; $profileCompiler: local := true +; $profileAlist: local := nil +; $LISPLIB => compDefineLisplib(df,m,e,prefix,fal,'compDefineFunctor1) +; compDefineFunctor1(df,m,e,prefix,fal) + +(DEFUN |compDefineFunctor| (|df| |m| |e| |prefix| |fal|) + (PROG (|$domainShell| |$profileCompiler| |$profileAlist|) + (DECLARE (SPECIAL |$domainShell| |$profileCompiler| + |$profileAlist|)) + (RETURN + (PROGN + (SPADLET |$domainShell| NIL) + (SPADLET |$profileCompiler| 'T) + (SPADLET |$profileAlist| NIL) + (COND + ($LISPLIB + (|compDefineLisplib| |df| |m| |e| |prefix| |fal| + '|compDefineFunctor1|)) + ('T (|compDefineFunctor1| |df| |m| |e| |prefix| |fal|))))))) + +;compDefineFunctor1(df is ['DEF,form,signature,$functorSpecialCases,body], +; m,$e,$prefix,$formalArgList) == +; if NRTPARSE = true then +; [lineNumber,:$functorSpecialCases] := $functorSpecialCases +;-- 1. bind global variables +; $addForm: local := nil +; $viewNames: local:= nil +; +; --This list is only used in genDomainViewName, for generating names +; --for alternate views, if they do not already exist. +; --format: Alist: (domain name . sublist) +; --sublist is alist: category . name of view +; $functionStats: local:= [0,0] +; $functorStats: local:= [0,0] +; $form: local := nil +; $op: local := nil +; $signature: local := nil +; $functorTarget: local := nil +; $Representation: local := nil +; --Set in doIt, accessed in the compiler - compNoStacking +; $LocalDomainAlist: local := nil --set in doIt, accessed in genDeltaEntry +; $LocalDomainAlist := nil +; $functorForm: local := nil +; $functorLocalParameters: local := nil +; SETQ($myFunctorBody, body) +; $CheckVectorList: local := nil +; --prevents CheckVector from printing out same message twice +; $getDomainCode: local := nil -- code for getting views +; $insideFunctorIfTrue: local:= true +; $functorsUsed: local := nil --not currently used, finds dependent functors +; $setelt: local := +; $QuickCode = true => 'QSETREFV +; 'SETELT +; $TOP__LEVEL: local := nil +; $genFVar: local:= 0 +; $genSDVar: local:= 0 +; originale:= $e +; [$op,:argl]:= form +; $formalArgList:= [:argl,:$formalArgList] +; $pairlis := [[a,:v] for a in argl for v in $FormalMapVariableList] +; $mutableDomain: local := +; -- all defaulting packages should have caching turned off +; isCategoryPackageName $op or +; (if BOUNDP '$mutableDomains then MEMQ($op,$mutableDomains) +; else false ) --true if domain has mutable state +; signature':= +; [first signature,:[getArgumentModeOrMoan(a,form,$e) for a in argl]] +; $functorForm:= $form:= [$op,:argl] +; if null first signature' then signature':= +; modemap2Signature getModemap($form,$e) +; target:= first signature' +; $functorTarget:= target +; $e:= giveFormalParametersValues(argl,$e) +; [ds,.,$e]:= compMakeCategoryObject(target,$e) or +;--+ copy needed since slot1 is reset; compMake.. can return a cached vector +; sayBrightly '" cannot produce category object:" +; pp target +; return nil +; $domainShell:= COPY_-SEQ ds +; $attributesName:local := INTERN STRCONC(PNAME $op,'";attributes") +; attributeList := disallowNilAttribute ds.2 --see below under "loadTimeAlist" +;--+ 7 lines for $NRT follow +; $goGetList: local := nil +;-->--these globals used by NRTmakeCategoryAlist, set by NRTsetVector4Part1 +; $condAlist: local := nil +; $uncondAlist: local := nil +;-->>-- next global initialized here, reset by NRTbuildFunctor +; $NRTslot1PredicateList: local := +; REMDUP [CADR x for x in attributeList] +;-->>-- next global initialized here, used by NRTgenAttributeAlist (NRUNOPT) +; $NRTattributeAlist: local := NRTgenInitialAttributeAlist attributeList +; $NRTslot1Info: local --set in NRTmakeSlot1 called by NRTbuildFunctor +; --this is used below to set $lisplibSlot1 global +; $NRTbase: local := 6 -- equals length of $domainShell +; $NRTaddForm: local := nil -- see compAdd; NRTmakeSlot1 +; $NRTdeltaList: local := nil --list of misc. elts used in compiled fncts +; $NRTdeltaListComp: local := nil --list of COMP-ed forms for $NRTdeltaList +; $NRTaddList: local := nil --list of fncts not defined in capsule (added) +; $NRTdeltaLength: local := 0 -- =length of block of extra entries in vector +; $NRTloadTimeAlist: local := nil --used for things in slot4 (NRTsetVector4) +; $NRTdomainFormList: local := nil -- of form ((gensym . (Repe...)) ... +; -- the above optimizes the calls to local domains +; $template: local:= nil --stored in the lisplib (if $NRTvec = true) +; $functionLocations: local := nil --locations of defined functions in source +; -- generate slots for arguments first, then for $NRTaddForm in compAdd +; for x in argl repeat NRTgetLocalIndex x +; [.,.,$e]:= compMakeDeclaration([":",'_$,target],m,$e) +; --The following loop sees if we can economise on ADDed operations +; --by using those of Rep, if that is the same. Example: DIRPROD +; if $insideCategoryPackageIfTrue^= true then +; if body is ['add,ab:=[fn,:.],['CAPSULE,:cb]] and MEMQ(fn,'(List Vector)) +; and FindRep(cb) = ab +; where FindRep cb == +; u:= +; while cb repeat +; ATOM cb => return nil +; cb is [['LET,'Rep,v,:.],:.] => return (u:=v) +; cb:=CDR cb +; u +; then $e:= augModemapsFromCategoryRep('_$,ab,cb,target,$e) +; else $e:= augModemapsFromCategory('_$,'_$,'_$,target,$e) +; $signature:= signature' +; operationAlist:= SUBLIS($pairlis,$domainShell.(1)) +; parSignature:= SUBLIS($pairlis,signature') +; parForm:= SUBLIS($pairlis,form) +; +;-- (3.1) now make a list of the functor's local parameters; for +;-- domain D in argl,check its signature: if domain, its type is Join(A1,..,An); +;-- in this case, D is replaced by D1,..,Dn (gensyms) which are set +;-- to the A1,..,An view of D +; if isPackageFunction() then $functorLocalParameters:= +; [nil,: +; [nil +; for i in 6..MAXINDEX $domainShell | +; $domainShell.i is [.,.,['ELT,'_$,.]]]] +; --leave space for vector ops and package name to be stored +;--+ +; $functorLocalParameters:= +; argPars := +; makeFunctorArgumentParameters(argl,rest signature',first signature') +; -- must do above to bring categories into scope --see line 5 of genDomainView +; argl +;-- 4. compile body in environment of %type declarations for arguments +; op':= $op +; rettype:= signature'.target +; T:= compFunctorBody(body,rettype,$e,parForm) +; -- If only compiling certain items, then ignore the body shell. +; $compileOnlyCertainItems => +; reportOnFunctorCompilation() +; [nil, ['Mapping, :signature'], originale] +; +; body':= T.expr +; lamOrSlam:= if $mutableDomain then 'LAM else 'SPADSLAM +; fun:= compile SUBLIS($pairlis, [op',[lamOrSlam,argl,body']]) +; --The above statement stops substitutions gettting in one another's way +;--+ +; operationAlist := SUBLIS($pairlis,$lisplibOperationAlist) +; if $LISPLIB then +; augmentLisplibModemapsFromFunctor(parForm,operationAlist,parSignature) +; reportOnFunctorCompilation() +; +;-- 5. give operator a 'modemap property +;-- if $functorsUsed then MAKEPROP(op',"NEEDS",$functorsUsed) +; if $LISPLIB then +; modemap:= [[parForm,:parSignature],[true,op']] +; $lisplibModemap:= modemap +; $lisplibCategory := modemap.mmTarget +; $lisplibParents := +; getParentsFor($op,$FormalMapVariableList,$lisplibCategory) +; $lisplibAncestors := computeAncestorsOf($form,nil) +; $lisplibAbbreviation := constructor? $op +; $insideFunctorIfTrue:= false +; if $LISPLIB then +; $lisplibKind:= +;------->This next line prohibits changing the KIND once given +;--------kk:=GETDATABASE($op,'CONSTRUCTORKIND) => kk +; $functorTarget is ["CATEGORY",key,:.] and key^="domain" => 'package +; 'domain +; $lisplibForm:= form +; if null $bootStrapMode then +; $NRTslot1Info := NRTmakeSlot1Info() +; $isOpPackageName: local := isCategoryPackageName $op +; if $isOpPackageName then lisplibWrite('"slot1DataBase", +; ['updateSlot1DataBase,MKQ $NRTslot1Info],$libFile) +; $lisplibFunctionLocations := SUBLIS($pairlis,$functionLocations) +; $lisplibCategoriesExtended := SUBLIS($pairlis,$lisplibCategoriesExtended) +; -- see NRTsetVector4 for initial setting of $lisplibCategoriesExtended +; libFn := GETDATABASE(op','ABBREVIATION) +; $lookupFunction: local := +; NRTgetLookupFunction($functorForm,CADAR $lisplibModemap,$NRTaddForm) +; --either lookupComplete (for forgetful guys) or lookupIncomplete +; $byteAddress :local := 0 +; $byteVec :local := nil +; $NRTslot1PredicateList := +; [simpBool x for x in $NRTslot1PredicateList] +; rwriteLispForm('loadTimeStuff, +; ['MAKEPROP,MKQ $op,''infovec,getInfovecCode()]) +; $lisplibSlot1 := $NRTslot1Info --NIL or set by $NRTmakeSlot1 +; $lisplibOperationAlist:= operationAlist +; $lisplibMissingFunctions:= $CheckVectorList +; lisplibWrite('"compilerInfo", +; removeZeroOne ['SETQ,'$CategoryFrame, +; ['put,['QUOTE,op'],' +; (QUOTE isFunctor), +; ['QUOTE,operationAlist],['addModemap,['QUOTE,op'],[' +; QUOTE,parForm],['QUOTE,parSignature],true,['QUOTE,op'], +; ['put,['QUOTE,op' ],'(QUOTE mode), +; ['QUOTE,['Mapping,:parSignature]],'$CategoryFrame]]]], $libFile) +; if null argl then +; evalAndRwriteLispForm('NILADIC, +; ['MAKEPROP, ['QUOTE,op'], ['QUOTE,'NILADIC], true]) +; [fun,['Mapping,:signature'],originale] + +(DEFUN |compDefineFunctor1,FindRep| (|cb|) + (PROG (|ISTMP#1| |ISTMP#2| |ISTMP#3| |v| |u|) + (RETURN + (SEQ (SPADLET |u| + (DO () ((NULL |cb|) NIL) + (SEQ (IF (ATOM |cb|) (EXIT (RETURN NIL))) + (IF (AND (PAIRP |cb|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |cb|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) 'LET) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCAR |ISTMP#2|) '|Rep|) + (PROGN + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |v| + (QCAR |ISTMP#3|)) + 'T)))))))) + (EXIT (RETURN (SPADLET |u| |v|)))) + (EXIT (SPADLET |cb| (CDR |cb|)))))) + (EXIT |u|))))) + +(DEFUN |compDefineFunctor1| (|df| |m| |$e| |$prefix| |$formalArgList|) + (DECLARE (SPECIAL |$e| |$prefix| |$formalArgList|)) + (PROG (|$addForm| |$viewNames| |$functionStats| |$functorStats| + |$form| |$op| |$signature| |$functorTarget| + |$Representation| |$LocalDomainAlist| |$functorForm| + |$functorLocalParameters| |$CheckVectorList| + |$getDomainCode| |$insideFunctorIfTrue| |$functorsUsed| + |$setelt| $TOP_LEVEL |$genFVar| |$genSDVar| + |$mutableDomain| |$attributesName| |$goGetList| + |$condAlist| |$uncondAlist| |$NRTslot1PredicateList| + |$NRTattributeAlist| |$NRTslot1Info| |$NRTbase| + |$NRTaddForm| |$NRTdeltaList| |$NRTdeltaListComp| + |$NRTaddList| |$NRTdeltaLength| |$NRTloadTimeAlist| + |$NRTdomainFormList| |$template| |$functionLocations| + |$isOpPackageName| |$lookupFunction| |$byteAddress| + |$byteVec| |form| |signature| |body| |lineNumber| + |originale| |argl| |signature'| |target| |ds| + |attributeList| |LETTMP#1| |fn| |ab| |cb| |parSignature| + |parForm| |ISTMP#2| |ISTMP#3| |ISTMP#4| |ISTMP#5| |ISTMP#6| + |argPars| |op'| |rettype| T$ |body'| |lamOrSlam| |fun| + |operationAlist| |modemap| |ISTMP#1| |key| |libFn|) + (DECLARE (SPECIAL |$addForm| |$viewNames| |$functionStats| + |$functorStats| |$form| |$op| |$signature| + |$functorTarget| |$Representation| + |$LocalDomainAlist| |$functorForm| + |$functorLocalParameters| |$CheckVectorList| + |$getDomainCode| |$insideFunctorIfTrue| + |$functorsUsed| |$setelt| $TOP_LEVEL |$genFVar| + |$genSDVar| |$mutableDomain| |$attributesName| + |$goGetList| |$condAlist| |$uncondAlist| + |$NRTslot1PredicateList| |$NRTattributeAlist| + |$NRTslot1Info| |$NRTbase| |$NRTaddForm| + |$NRTdeltaList| |$NRTdeltaListComp| |$NRTaddList| + |$NRTdeltaLength| |$NRTloadTimeAlist| + |$NRTdomainFormList| |$template| + |$functionLocations| |$isOpPackageName| + |$lookupFunction| |$byteAddress| |$byteVec|)) + (RETURN + (SEQ (PROGN + (SPADLET |form| (CADR |df|)) + (SPADLET |signature| (CADDR |df|)) + (SPADLET |$functorSpecialCases| (CADDDR |df|)) + (SPADLET |body| (CAR (CDDDDR |df|))) + (COND + ((BOOT-EQUAL NRTPARSE 'T) + (SPADLET |LETTMP#1| |$functorSpecialCases|) + (SPADLET |lineNumber| (CAR |LETTMP#1|)) + (SPADLET |$functorSpecialCases| (CDR |LETTMP#1|)) + |LETTMP#1|)) + (SPADLET |$addForm| NIL) + (SPADLET |$viewNames| NIL) + (SPADLET |$functionStats| (CONS 0 (CONS 0 NIL))) + (SPADLET |$functorStats| (CONS 0 (CONS 0 NIL))) + (SPADLET |$form| NIL) + (SPADLET |$op| NIL) + (SPADLET |$signature| NIL) + (SPADLET |$functorTarget| NIL) + (SPADLET |$Representation| NIL) + (SPADLET |$LocalDomainAlist| NIL) + (SPADLET |$LocalDomainAlist| NIL) + (SPADLET |$functorForm| NIL) + (SPADLET |$functorLocalParameters| NIL) + (SETQ |$myFunctorBody| |body|) + (SPADLET |$CheckVectorList| NIL) + (SPADLET |$getDomainCode| NIL) + (SPADLET |$insideFunctorIfTrue| 'T) + (SPADLET |$functorsUsed| NIL) + (SPADLET |$setelt| + (COND + ((BOOT-EQUAL |$QuickCode| 'T) 'QSETREFV) + ('T 'SETELT))) + (SPADLET $TOP_LEVEL NIL) + (SPADLET |$genFVar| 0) + (SPADLET |$genSDVar| 0) + (SPADLET |originale| |$e|) + (SPADLET |$op| (CAR |form|)) + (SPADLET |argl| (CDR |form|)) + (SPADLET |$formalArgList| + (APPEND |argl| |$formalArgList|)) + (SPADLET |$pairlis| + (PROG (G167049) + (SPADLET G167049 NIL) + (RETURN + (DO ((G167055 |argl| (CDR G167055)) + (|a| NIL) + (G167056 |$FormalMapVariableList| + (CDR G167056)) + (|v| NIL)) + ((OR (ATOM G167055) + (PROGN + (SETQ |a| (CAR G167055)) + NIL) + (ATOM G167056) + (PROGN + (SETQ |v| (CAR G167056)) + NIL)) + (NREVERSE0 G167049)) + (SEQ (EXIT (SETQ G167049 + (CONS (CONS |a| |v|) G167049)))))))) + (SPADLET |$mutableDomain| + (OR (|isCategoryPackageName| |$op|) + (COND + ((BOUNDP '|$mutableDomains|) + (MEMQ |$op| |$mutableDomains|)) + ('T NIL)))) + (SPADLET |signature'| + (CONS (CAR |signature|) + (PROG (G167069) + (SPADLET G167069 NIL) + (RETURN + (DO ((G167074 |argl| (CDR G167074)) + (|a| NIL)) + ((OR (ATOM G167074) + (PROGN + (SETQ |a| (CAR G167074)) + NIL)) + (NREVERSE0 G167069)) + (SEQ (EXIT + (SETQ G167069 + (CONS + (|getArgumentModeOrMoan| |a| + |form| |$e|) + G167069))))))))) + (SPADLET |$functorForm| + (SPADLET |$form| (CONS |$op| |argl|))) + (COND + ((NULL (CAR |signature'|)) + (SPADLET |signature'| + (|modemap2Signature| + (|getModemap| |$form| |$e|))))) + (SPADLET |target| (CAR |signature'|)) + (SPADLET |$functorTarget| |target|) + (SPADLET |$e| (|giveFormalParametersValues| |argl| |$e|)) + (SPADLET |LETTMP#1| + (OR (|compMakeCategoryObject| |target| |$e|) + (PROGN + (|sayBrightly| + (MAKESTRING + " cannot produce category object:")) + (|pp| |target|) + (RETURN NIL)))) + (SPADLET |ds| (CAR |LETTMP#1|)) + (SPADLET |$e| (CADDR |LETTMP#1|)) + (SPADLET |$domainShell| (COPY-SEQ |ds|)) + (SPADLET |$attributesName| + (INTERN (STRCONC (PNAME |$op|) + (MAKESTRING ";attributes")))) + (SPADLET |attributeList| + (|disallowNilAttribute| (ELT |ds| 2))) + (SPADLET |$goGetList| NIL) + (SPADLET |$condAlist| NIL) + (SPADLET |$uncondAlist| NIL) + (SPADLET |$NRTslot1PredicateList| + (REMDUP (PROG (G167084) + (SPADLET G167084 NIL) + (RETURN + (DO ((G167089 |attributeList| + (CDR G167089)) + (|x| NIL)) + ((OR (ATOM G167089) + (PROGN + (SETQ |x| (CAR G167089)) + NIL)) + (NREVERSE0 G167084)) + (SEQ + (EXIT + (SETQ G167084 + (CONS (CADR |x|) G167084))))))))) + (SPADLET |$NRTattributeAlist| + (|NRTgenInitialAttributeAlist| |attributeList|)) + (SPADLET |$NRTslot1Info| NIL) + (SPADLET |$NRTbase| 6) + (SPADLET |$NRTaddForm| NIL) + (SPADLET |$NRTdeltaList| NIL) + (SPADLET |$NRTdeltaListComp| NIL) + (SPADLET |$NRTaddList| NIL) + (SPADLET |$NRTdeltaLength| 0) + (SPADLET |$NRTloadTimeAlist| NIL) + (SPADLET |$NRTdomainFormList| NIL) + (SPADLET |$template| NIL) + (SPADLET |$functionLocations| NIL) + (DO ((G167098 |argl| (CDR G167098)) (|x| NIL)) + ((OR (ATOM G167098) + (PROGN (SETQ |x| (CAR G167098)) NIL)) + NIL) + (SEQ (EXIT (|NRTgetLocalIndex| |x|)))) + (SPADLET |LETTMP#1| + (|compMakeDeclaration| + (CONS '|:| (CONS '$ (CONS |target| NIL))) |m| + |$e|)) + (SPADLET |$e| (CADDR |LETTMP#1|)) + (COND + ((NEQUAL |$insideCategoryPackageIfTrue| 'T) + (COND + ((AND (PAIRP |body|) (EQ (QCAR |body|) '|add|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |body|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |fn| (QCAR |ISTMP#2|)) + 'T))) + (PROGN + (SPADLET |ab| (QCAR |ISTMP#1|)) + 'T) + (PROGN + (SPADLET |ISTMP#3| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |ISTMP#4| + (QCAR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) + (EQ (QCAR |ISTMP#4|) 'CAPSULE) + (PROGN + (SPADLET |cb| + (QCDR |ISTMP#4|)) + 'T))))))) + (MEMQ |fn| '(|List| |Vector|)) + (BOOT-EQUAL (|compDefineFunctor1,FindRep| |cb|) + |ab|)) + (SPADLET |$e| + (|augModemapsFromCategoryRep| '$ |ab| |cb| + |target| |$e|))) + ('T + (SPADLET |$e| + (|augModemapsFromCategory| '$ '$ '$ + |target| |$e|)))))) + (SPADLET |$signature| |signature'|) + (SPADLET |operationAlist| + (SUBLIS |$pairlis| (ELT |$domainShell| 1))) + (SPADLET |parSignature| (SUBLIS |$pairlis| |signature'|)) + (SPADLET |parForm| (SUBLIS |$pairlis| |form|)) + (COND + ((|isPackageFunction|) + (SPADLET |$functorLocalParameters| + (CONS NIL + (PROG (G167109) + (SPADLET G167109 NIL) + (RETURN + (DO + ((G167115 + (MAXINDEX |$domainShell|)) + (|i| 6 (+ |i| 1))) + ((> |i| G167115) + (NREVERSE0 G167109)) + (SEQ + (EXIT + (COND + ((PROGN + (SPADLET |ISTMP#1| + (ELT |$domainShell| |i|)) + (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 |ISTMP#4| + (QCAR |ISTMP#3|)) + (AND + (PAIRP |ISTMP#4|) + (EQ + (QCAR |ISTMP#4|) + 'ELT) + (PROGN + (SPADLET + |ISTMP#5| + (QCDR + |ISTMP#4|)) + (AND + (PAIRP + |ISTMP#5|) + (EQ + (QCAR + |ISTMP#5|) + '$) + (PROGN + (SPADLET + |ISTMP#6| + (QCDR + |ISTMP#5|)) + (AND + (PAIRP + |ISTMP#6|) + (EQ + (QCDR + |ISTMP#6|) + NIL))))))))))))) + (SETQ G167109 + (CONS NIL G167109))))))))))))) + (SPADLET |$functorLocalParameters| + (PROGN + (SPADLET |argPars| + (|makeFunctorArgumentParameters| + |argl| (CDR |signature'|) + (CAR |signature'|))) + |argl|)) + (SPADLET |op'| |$op|) + (SPADLET |rettype| (CAR |signature'|)) + (SPADLET T$ + (|compFunctorBody| |body| |rettype| |$e| + |parForm|)) + (COND + (|$compileOnlyCertainItems| + (|reportOnFunctorCompilation|) + (CONS NIL + (CONS (CONS '|Mapping| |signature'|) + (CONS |originale| NIL)))) + ('T (SPADLET |body'| (CAR T$)) + (SPADLET |lamOrSlam| + (COND (|$mutableDomain| 'LAM) ('T 'SPADSLAM))) + (SPADLET |fun| + (|compile| + (SUBLIS |$pairlis| + (CONS |op'| + (CONS + (CONS |lamOrSlam| + (CONS |argl| + (CONS |body'| NIL))) + NIL))))) + (SPADLET |operationAlist| + (SUBLIS |$pairlis| |$lisplibOperationAlist|)) + (COND + ($LISPLIB + (|augmentLisplibModemapsFromFunctor| |parForm| + |operationAlist| |parSignature|))) + (|reportOnFunctorCompilation|) + (COND + ($LISPLIB + (SPADLET |modemap| + (CONS (CONS |parForm| |parSignature|) + (CONS (CONS 'T (CONS |op'| NIL)) + NIL))) + (SPADLET |$lisplibModemap| |modemap|) + (SPADLET |$lisplibCategory| (CADAR |modemap|)) + (SPADLET |$lisplibParents| + (|getParentsFor| |$op| + |$FormalMapVariableList| + |$lisplibCategory|)) + (SPADLET |$lisplibAncestors| + (|computeAncestorsOf| |$form| NIL)) + (SPADLET |$lisplibAbbreviation| + (|constructor?| |$op|)))) + (SPADLET |$insideFunctorIfTrue| NIL) + (COND + ($LISPLIB + (SPADLET |$lisplibKind| + (COND + ((AND (PAIRP |$functorTarget|) + (EQ (QCAR |$functorTarget|) + 'CATEGORY) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |$functorTarget|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |key| + (QCAR |ISTMP#1|)) + 'T))) + (NEQUAL |key| '|domain|)) + '|package|) + ('T '|domain|))) + (SPADLET |$lisplibForm| |form|) + (COND + ((NULL |$bootStrapMode|) + (SPADLET |$NRTslot1Info| (|NRTmakeSlot1Info|)) + (SPADLET |$isOpPackageName| + (|isCategoryPackageName| |$op|)) + (COND + (|$isOpPackageName| + (|lisplibWrite| + (MAKESTRING "slot1DataBase") + (CONS '|updateSlot1DataBase| + (CONS (MKQ |$NRTslot1Info|) NIL)) + |$libFile|))) + (SPADLET |$lisplibFunctionLocations| + (SUBLIS |$pairlis| + |$functionLocations|)) + (SPADLET |$lisplibCategoriesExtended| + (SUBLIS |$pairlis| + |$lisplibCategoriesExtended|)) + (SPADLET |libFn| + (GETDATABASE |op'| 'ABBREVIATION)) + (SPADLET |$lookupFunction| + (|NRTgetLookupFunction| + |$functorForm| + (CADAR |$lisplibModemap|) + |$NRTaddForm|)) + (SPADLET |$byteAddress| 0) + (SPADLET |$byteVec| NIL) + (SPADLET |$NRTslot1PredicateList| + (PROG (G167123) + (SPADLET G167123 NIL) + (RETURN + (DO + ((G167128 + |$NRTslot1PredicateList| + (CDR G167128)) + (|x| NIL)) + ((OR (ATOM G167128) + (PROGN + (SETQ |x| (CAR G167128)) + NIL)) + (NREVERSE0 G167123)) + (SEQ + (EXIT + (SETQ G167123 + (CONS (|simpBool| |x|) + G167123)))))))) + (|rwriteLispForm| '|loadTimeStuff| + (CONS 'MAKEPROP + (CONS (MKQ |$op|) + (CONS ''|infovec| + (CONS (|getInfovecCode|) NIL))))))) + (SPADLET |$lisplibSlot1| |$NRTslot1Info|) + (SPADLET |$lisplibOperationAlist| + |operationAlist|) + (SPADLET |$lisplibMissingFunctions| + |$CheckVectorList|))) + (|lisplibWrite| (MAKESTRING "compilerInfo") + (|removeZeroOne| + (CONS 'SETQ + (CONS '|$CategoryFrame| + (CONS + (CONS '|put| + (CONS + (CONS 'QUOTE (CONS |op'| NIL)) + (CONS ''|isFunctor| + (CONS + (CONS 'QUOTE + (CONS |operationAlist| NIL)) + (CONS + (CONS '|addModemap| + (CONS + (CONS 'QUOTE + (CONS |op'| NIL)) + (CONS + (CONS 'QUOTE + (CONS |parForm| NIL)) + (CONS + (CONS 'QUOTE + (CONS |parSignature| + NIL)) + (CONS 'T + (CONS + (CONS 'QUOTE + (CONS |op'| NIL)) + (CONS + (CONS '|put| + (CONS + (CONS 'QUOTE + (CONS |op'| NIL)) + (CONS ''|mode| + (CONS + (CONS 'QUOTE + (CONS + (CONS '|Mapping| + |parSignature|) + NIL)) + (CONS + '|$CategoryFrame| + NIL))))) + NIL))))))) + NIL))))) + NIL)))) + |$libFile|) + (COND + ((NULL |argl|) + (|evalAndRwriteLispForm| 'NILADIC + (CONS 'MAKEPROP + (CONS (CONS 'QUOTE (CONS |op'| NIL)) + (CONS + (CONS 'QUOTE (CONS 'NILADIC NIL)) + (CONS 'T NIL))))))) + (CONS |fun| + (CONS (CONS '|Mapping| |signature'|) + (CONS |originale| NIL)))))))))) + +;disallowNilAttribute x == +; res := [y for y in x | car y and car y ^= "nil"] + +(DEFUN |disallowNilAttribute| (|x|) + (PROG (|res|) + (RETURN + (SEQ (SPADLET |res| + (PROG (G167349) + (SPADLET G167349 NIL) + (RETURN + (DO ((G167355 |x| (CDR G167355)) (|y| NIL)) + ((OR (ATOM G167355) + (PROGN + (SETQ |y| (CAR G167355)) + NIL)) + (NREVERSE0 G167349)) + (SEQ (EXIT (COND + ((AND (CAR |y|) + (NEQUAL (CAR |y|) '|nil|)) + (SETQ G167349 + (CONS |y| G167349)))))))))))))) + +;--HACK to get rid of nil attibutes ---NOTE: nil is RENAMED to NIL +;compFunctorBody(body,m,e,parForm) == +; $bootStrapMode = true => +; [bootStrapError($functorForm, _/EDITFILE),m,e] +; T:= compOrCroak(body,m,e) +; body is [op,:.] and MEMQ(op,'(add CAPSULE)) => T +; $NRTaddForm := +; body is ["SubDomain",domainForm,predicate] => domainForm +; body +; T + +(DEFUN |compFunctorBody| (|body| |m| |e| |parForm|) + (PROG (T$ |op| |ISTMP#1| |domainForm| |ISTMP#2| |predicate|) + (RETURN + (COND + ((BOOT-EQUAL |$bootStrapMode| 'T) + (CONS (|bootStrapError| |$functorForm| /EDITFILE) + (CONS |m| (CONS |e| NIL)))) + ('T (SPADLET T$ (|compOrCroak| |body| |m| |e|)) + (COND + ((AND (PAIRP |body|) (PROGN (SPADLET |op| (QCAR |body|)) 'T) + (MEMQ |op| '(|add| CAPSULE))) + T$) + ('T + (SPADLET |$NRTaddForm| + (COND + ((AND (PAIRP |body|) + (EQ (QCAR |body|) '|SubDomain|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |body|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |domainForm| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |predicate| + (QCAR |ISTMP#2|)) + 'T)))))) + |domainForm|) + ('T |body|))) + T$))))))) + +;reportOnFunctorCompilation() == +; displayMissingFunctions() +; if $semanticErrorStack then sayBrightly '" " +; displaySemanticErrors() +; if $warningStack then sayBrightly '" " +; displayWarnings() +; $functorStats:= addStats($functorStats,$functionStats) +; [byteCount,elapsedSeconds] := $functorStats +; sayBrightly ['%l,:bright '" Cumulative Statistics for Constructor", +; $op] +; timeString := normalizeStatAndStringify elapsedSeconds +; sayBrightly ['" Time:",:bright timeString,'"seconds"] +; sayBrightly '" " +; 'done + +(DEFUN |reportOnFunctorCompilation| () + (PROG (|byteCount| |elapsedSeconds| |timeString|) + (RETURN + (PROGN + (|displayMissingFunctions|) + (COND + (|$semanticErrorStack| (|sayBrightly| (MAKESTRING " ")))) + (|displaySemanticErrors|) + (COND (|$warningStack| (|sayBrightly| (MAKESTRING " ")))) + (|displayWarnings|) + (SPADLET |$functorStats| + (|addStats| |$functorStats| |$functionStats|)) + (SPADLET |byteCount| (CAR |$functorStats|)) + (SPADLET |elapsedSeconds| (CADR |$functorStats|)) + (|sayBrightly| + (CONS '|%l| + (APPEND (|bright| + (MAKESTRING + " Cumulative Statistics for Constructor")) + (CONS |$op| NIL)))) + (SPADLET |timeString| + (|normalizeStatAndStringify| |elapsedSeconds|)) + (|sayBrightly| + (CONS (MAKESTRING " Time:") + (APPEND (|bright| |timeString|) + (CONS (MAKESTRING "seconds") NIL)))) + (|sayBrightly| (MAKESTRING " ")) + '|done|)))) + +;displayMissingFunctions() == +; null $CheckVectorList => nil +; loc := nil +; exp := nil +; for [[op,sig,:.],:pred] in $CheckVectorList | null pred repeat +; null MEMBER(op,$formalArgList) and +; getmode(op,$env) is ['Mapping,:.] => +; loc := [[op,sig],:loc] +; exp := [[op,sig],:exp] +; if loc then +; sayBrightly ['%l,:bright '" Missing Local Functions:"] +; for [op,sig] in loc for i in 1.. repeat +; sayBrightly ['" [",i,'"]",:bright op, +; ": ",:formatUnabbreviatedSig sig] +; if exp then +; sayBrightly ['%l,:bright '" Missing Exported Functions:"] +; for [op,sig] in exp for i in 1.. repeat +; sayBrightly ['" [",i,'"]",:bright op, +; ": ",:formatUnabbreviatedSig sig] + +(DEFUN |displayMissingFunctions| () + (PROG (|pred| |ISTMP#1| |loc| |exp| |op| |sig|) + (RETURN + (SEQ (COND + ((NULL |$CheckVectorList|) NIL) + ('T (SPADLET |loc| NIL) (SPADLET |exp| NIL) + (DO ((G167431 |$CheckVectorList| (CDR G167431)) + (G167408 NIL)) + ((OR (ATOM G167431) + (PROGN (SETQ G167408 (CAR G167431)) NIL) + (PROGN + (PROGN + (SPADLET |op| (CAAR G167408)) + (SPADLET |sig| (CADAR G167408)) + (SPADLET |pred| (CDR G167408)) + G167408) + NIL)) + NIL) + (SEQ (EXIT (COND + ((NULL |pred|) + (COND + ((AND (NULL + (|member| |op| |$formalArgList|)) + (PROGN + (SPADLET |ISTMP#1| + (|getmode| |op| |$env|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) + '|Mapping|)))) + (SPADLET |loc| + (CONS + (CONS |op| (CONS |sig| NIL)) + |loc|))) + ('T + (SPADLET |exp| + (CONS + (CONS |op| (CONS |sig| NIL)) + |exp|))))))))) + (COND + (|loc| (|sayBrightly| + (CONS '|%l| + (|bright| + (MAKESTRING + " Missing Local Functions:")))) + (DO ((G167443 |loc| (CDR G167443)) + (G167413 NIL) (|i| 1 (QSADD1 |i|))) + ((OR (ATOM G167443) + (PROGN + (SETQ G167413 (CAR G167443)) + NIL) + (PROGN + (PROGN + (SPADLET |op| (CAR G167413)) + (SPADLET |sig| (CADR G167413)) + G167413) + NIL)) + NIL) + (SEQ (EXIT (|sayBrightly| + (CONS (MAKESTRING " [") + (CONS |i| + (CONS (MAKESTRING "]") + (APPEND (|bright| |op|) + (CONS '|: | + (|formatUnabbreviatedSig| + |sig|)))))))))))) + (COND + (|exp| (|sayBrightly| + (CONS '|%l| + (|bright| + (MAKESTRING + " Missing Exported Functions:")))) + (DO ((G167455 |exp| (CDR G167455)) + (G167418 NIL) (|i| 1 (QSADD1 |i|))) + ((OR (ATOM G167455) + (PROGN + (SETQ G167418 (CAR G167455)) + NIL) + (PROGN + (PROGN + (SPADLET |op| (CAR G167418)) + (SPADLET |sig| (CADR G167418)) + G167418) + NIL)) + NIL) + (SEQ (EXIT (|sayBrightly| + (CONS (MAKESTRING " [") + (CONS |i| + (CONS (MAKESTRING "]") + (APPEND (|bright| |op|) + (CONS '|: | + (|formatUnabbreviatedSig| + |sig|))))))))))) + ('T NIL)))))))) + +;--% domain view code +; +;makeFunctorArgumentParameters(argl,sigl,target) == +; $alternateViewList: local:= nil +; $forceAdd: local:= true +; $ConditionalOperators: local := nil +; ("append"/[fn(a,augmentSig(s,findExtras(a,target))) +; for a in argl for s in sigl]) where +; findExtras(a,target) == +; -- see if conditional information implies anything else +; -- in the signature of a +; target is ['Join,:l] => "union"/[findExtras(a,x) for x in l] +; target is ['CATEGORY,.,:l] => "union"/[findExtras1(a,x) for x in l] where +; findExtras1(a,x) == +; x is ['AND,:l] => "union"/[findExtras1(a,y) for y in l] +; x is ['OR,:l] => "union"/[findExtras1(a,y) for y in l] +; x is ['IF,c,p,q] => +; union(findExtrasP(a,c), +; union(findExtras1(a,p),findExtras1(a,q))) where +; findExtrasP(a,x) == +; x is ['AND,:l] => "union"/[findExtrasP(a,y) for y in l] +; x is ['OR,:l] => "union"/[findExtrasP(a,y) for y in l] +; x is ['has,=a,y] and y is ['SIGNATURE,:.] => [y] +; nil +; nil +; augmentSig(s,ss) == +; -- if we find something extra, add it to the signature +; null ss => s +; for u in ss repeat +; $ConditionalOperators:=[CDR u,:$ConditionalOperators] +; s is ['Join,:sl] => +; u:=ASSQ('CATEGORY,ss) => +; SUBST([:u,:ss],u,s) +; ['Join,:sl,['CATEGORY,'package,:ss]] +; ['Join,s,['CATEGORY,'package,:ss]] +; fn(a,s) == +; isCategoryForm(s,$CategoryFrame) => +; s is ["Join",:catlist] => genDomainViewList0(a,rest s) +; [genDomainView(a,a,s,"getDomainView")] +; [a] + +(DEFUN |makeFunctorArgumentParameters,findExtrasP| (|a| |x|) + (PROG (|l| |ISTMP#1| |ISTMP#2| |y|) + (RETURN + (SEQ (IF (AND (PAIRP |x|) (EQ (QCAR |x|) 'AND) + (PROGN (SPADLET |l| (QCDR |x|)) 'T)) + (EXIT (PROG (G167526) + (SPADLET G167526 NIL) + (RETURN + (DO ((G167531 |l| (CDR G167531)) + (|y| NIL)) + ((OR (ATOM G167531) + (PROGN + (SETQ |y| (CAR G167531)) + NIL)) + G167526) + (SEQ (EXIT (SETQ G167526 + (|union| G167526 + (|makeFunctorArgumentParameters,findExtrasP| + |a| |y|)))))))))) + (IF (AND (PAIRP |x|) (EQ (QCAR |x|) 'OR) + (PROGN (SPADLET |l| (QCDR |x|)) 'T)) + (EXIT (PROG (G167537) + (SPADLET G167537 NIL) + (RETURN + (DO ((G167542 |l| (CDR G167542)) + (|y| NIL)) + ((OR (ATOM G167542) + (PROGN + (SETQ |y| (CAR G167542)) + NIL)) + G167537) + (SEQ (EXIT (SETQ G167537 + (|union| G167537 + (|makeFunctorArgumentParameters,findExtrasP| + |a| |y|)))))))))) + (IF (AND (AND (PAIRP |x|) (EQ (QCAR |x|) '|has|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (EQUAL (QCAR |ISTMP#1|) |a|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |y| (QCAR |ISTMP#2|)) + 'T)))))) + (AND (PAIRP |y|) (EQ (QCAR |y|) 'SIGNATURE))) + (EXIT (CONS |y| NIL))) + (EXIT NIL))))) + +(DEFUN |makeFunctorArgumentParameters,findExtras1| (|a| |x|) + (PROG (|l| |ISTMP#1| |c| |ISTMP#2| |p| |ISTMP#3| |q|) + (RETURN + (SEQ (IF (AND (PAIRP |x|) (EQ (QCAR |x|) 'AND) + (PROGN (SPADLET |l| (QCDR |x|)) 'T)) + (EXIT (PROG (G167560) + (SPADLET G167560 NIL) + (RETURN + (DO ((G167565 |l| (CDR G167565)) + (|y| NIL)) + ((OR (ATOM G167565) + (PROGN + (SETQ |y| (CAR G167565)) + NIL)) + G167560) + (SEQ (EXIT (SETQ G167560 + (|union| G167560 + (|makeFunctorArgumentParameters,findExtras1| + |a| |y|)))))))))) + (IF (AND (PAIRP |x|) (EQ (QCAR |x|) 'OR) + (PROGN (SPADLET |l| (QCDR |x|)) 'T)) + (EXIT (PROG (G167571) + (SPADLET G167571 NIL) + (RETURN + (DO ((G167576 |l| (CDR G167576)) + (|y| NIL)) + ((OR (ATOM G167576) + (PROGN + (SETQ |y| (CAR G167576)) + NIL)) + G167571) + (SEQ (EXIT (SETQ G167571 + (|union| G167571 + (|makeFunctorArgumentParameters,findExtras1| + |a| |y|)))))))))) + (EXIT (IF (AND (PAIRP |x|) (EQ (QCAR |x|) 'IF) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |c| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |p| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |q| (QCAR |ISTMP#3|)) + 'T)))))))) + (EXIT (|union| (|makeFunctorArgumentParameters,findExtrasP| + |a| |c|) + (|union| + (|makeFunctorArgumentParameters,findExtras1| + |a| |p|) + (|makeFunctorArgumentParameters,findExtras1| + |a| |q|)))))))))) + +(DEFUN |makeFunctorArgumentParameters,fn| (|a| |s|) + (PROG (|catlist|) + (RETURN + (SEQ (IF (|isCategoryForm| |s| |$CategoryFrame|) + (EXIT (SEQ (IF (AND (PAIRP |s|) (EQ (QCAR |s|) '|Join|) + (PROGN + (SPADLET |catlist| (QCDR |s|)) + 'T)) + (EXIT (|genDomainViewList0| |a| + (CDR |s|)))) + (EXIT (CONS (|genDomainView| |a| |a| |s| + '|getDomainView|) + NIL))))) + (EXIT (CONS |a| NIL)))))) + +(DEFUN |makeFunctorArgumentParameters,augmentSig| (|s| |ss|) + (PROG (|sl| |u|) + (RETURN + (SEQ (IF (NULL |ss|) (EXIT |s|)) + (DO ((G167609 |ss| (CDR G167609)) (|u| NIL)) + ((OR (ATOM G167609) + (PROGN (SETQ |u| (CAR G167609)) NIL)) + NIL) + (SEQ (EXIT (SPADLET |$ConditionalOperators| + (CONS (CDR |u|) + |$ConditionalOperators|))))) + (IF (AND (PAIRP |s|) (EQ (QCAR |s|) '|Join|) + (PROGN (SPADLET |sl| (QCDR |s|)) 'T)) + (EXIT (SEQ (IF (SPADLET |u| (ASSQ 'CATEGORY |ss|)) + (EXIT (MSUBST (APPEND |u| |ss|) |u| |s|))) + (EXIT (CONS '|Join| + (APPEND |sl| + (CONS + (CONS 'CATEGORY + (CONS '|package| |ss|)) + NIL))))))) + (EXIT (CONS '|Join| + (CONS |s| + (CONS (CONS 'CATEGORY + (CONS '|package| |ss|)) + NIL)))))))) + +(DEFUN |makeFunctorArgumentParameters,findExtras| (|a| |target|) + (PROG (|ISTMP#1| |l|) + (RETURN + (SEQ (IF (AND (PAIRP |target|) (EQ (QCAR |target|) '|Join|) + (PROGN (SPADLET |l| (QCDR |target|)) 'T)) + (EXIT (PROG (G167621) + (SPADLET G167621 NIL) + (RETURN + (DO ((G167626 |l| (CDR G167626)) + (|x| NIL)) + ((OR (ATOM G167626) + (PROGN + (SETQ |x| (CAR G167626)) + NIL)) + G167621) + (SEQ (EXIT (SETQ G167621 + (|union| G167621 + (|makeFunctorArgumentParameters,findExtras| + |a| |x|)))))))))) + (EXIT (IF (AND (PAIRP |target|) + (EQ (QCAR |target|) 'CATEGORY) + (PROGN + (SPADLET |ISTMP#1| (QCDR |target|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |l| (QCDR |ISTMP#1|)) + 'T)))) + (EXIT (PROG (G167632) + (SPADLET G167632 NIL) + (RETURN + (DO ((G167637 |l| (CDR G167637)) + (|x| NIL)) + ((OR (ATOM G167637) + (PROGN + (SETQ |x| (CAR G167637)) + NIL)) + G167632) + (SEQ (EXIT + (SETQ G167632 + (|union| G167632 + (|makeFunctorArgumentParameters,findExtras1| + |a| |x|))))))))))))))) + +(DEFUN |makeFunctorArgumentParameters| (|argl| |sigl| |target|) + (PROG (|$alternateViewList| |$forceAdd| |$ConditionalOperators|) + (DECLARE (SPECIAL |$alternateViewList| |$forceAdd| + |$ConditionalOperators|)) + (RETURN + (SEQ (PROGN + (SPADLET |$alternateViewList| NIL) + (SPADLET |$forceAdd| 'T) + (SPADLET |$ConditionalOperators| NIL) + (PROG (G167653) + (SPADLET G167653 NIL) + (RETURN + (DO ((G167659 |argl| (CDR G167659)) (|a| NIL) + (G167660 |sigl| (CDR G167660)) (|s| NIL)) + ((OR (ATOM G167659) + (PROGN (SETQ |a| (CAR G167659)) NIL) + (ATOM G167660) + (PROGN (SETQ |s| (CAR G167660)) NIL)) + G167653) + (SEQ (EXIT (SETQ G167653 + (APPEND G167653 + (|makeFunctorArgumentParameters,fn| + |a| + (|makeFunctorArgumentParameters,augmentSig| + |s| + (|makeFunctorArgumentParameters,findExtras| + |a| |target|))))))))))))))) + +;genDomainViewList0(id,catlist) == +; l:= genDomainViewList(id,catlist,true) +; l + +(DEFUN |genDomainViewList0| (|id| |catlist|) + (PROG (|l|) + (RETURN + (PROGN + (SPADLET |l| (|genDomainViewList| |id| |catlist| 'T)) + |l|)))) + +;genDomainViewList(id,catlist,firsttime) == +; null catlist => nil +; catlist is [y] and not isCategoryForm(y,$EmptyEnvironment) => nil +; [genDomainView(if firsttime then id else genDomainViewName(id,first catlist), +; id,first catlist,"getDomainView"),:genDomainViewList(id,rest catlist,nil)] + +(DEFUN |genDomainViewList| (|id| |catlist| |firsttime|) + (PROG (|y|) + (RETURN + (COND + ((NULL |catlist|) NIL) + ((AND (PAIRP |catlist|) (EQ (QCDR |catlist|) NIL) + (PROGN (SPADLET |y| (QCAR |catlist|)) 'T) + (NULL (|isCategoryForm| |y| |$EmptyEnvironment|))) + NIL) + ('T + (CONS (|genDomainView| + (COND + (|firsttime| |id|) + ('T (|genDomainViewName| |id| (CAR |catlist|)))) + |id| (CAR |catlist|) '|getDomainView|) + (|genDomainViewList| |id| (CDR |catlist|) NIL))))))) + +;genDomainView(viewName,originalName,c,viewSelector) == +; c is ['CATEGORY,.,:l] => genDomainOps(viewName,originalName,c) +; code:= +; c is ['SubsetCategory,c',.] => c' +; c +; $e:= augModemapsFromCategory(originalName,viewName,nil,c,$e) +; --$alternateViewList:= ((viewName,:code),:$alternateViewList) +; cd:= ['LET,viewName,[viewSelector,originalName,mkDomainConstructor code]] +; if null MEMBER(cd,$getDomainCode) then +; $getDomainCode:= [cd,:$getDomainCode] +; viewName + +(DEFUN |genDomainView| (|viewName| |originalName| |c| |viewSelector|) + (PROG (|l| |ISTMP#1| |c'| |ISTMP#2| |code| |cd|) + (RETURN + (COND + ((AND (PAIRP |c|) (EQ (QCAR |c|) 'CATEGORY) + (PROGN + (SPADLET |ISTMP#1| (QCDR |c|)) + (AND (PAIRP |ISTMP#1|) + (PROGN (SPADLET |l| (QCDR |ISTMP#1|)) 'T)))) + (|genDomainOps| |viewName| |originalName| |c|)) + ('T + (SPADLET |code| + (COND + ((AND (PAIRP |c|) (EQ (QCAR |c|) '|SubsetCategory|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |c|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |c'| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL)))))) + |c'|) + ('T |c|))) + (SPADLET |$e| + (|augModemapsFromCategory| |originalName| |viewName| + NIL |c| |$e|)) + (SPADLET |cd| + (CONS 'LET + (CONS |viewName| + (CONS (CONS |viewSelector| + (CONS |originalName| + (CONS + (|mkDomainConstructor| |code|) + NIL))) + NIL)))) + (COND + ((NULL (|member| |cd| |$getDomainCode|)) + (SPADLET |$getDomainCode| (CONS |cd| |$getDomainCode|)))) + |viewName|))))) + +;genDomainOps(viewName,dom,cat) == +; oplist:= getOperationAlist(dom,dom,cat) +; siglist:= [sig for [sig,:.] in oplist] +; oplist:= substNames(dom,viewName,dom,oplist) +; cd:= +; ['LET,viewName,['mkOpVec,dom,['LIST,: +; [['LIST,MKQ op,['LIST,:[mkDomainConstructor mode for mode in sig]]] +; for [op,sig] in siglist]]]] +; $getDomainCode:= [cd,:$getDomainCode] +; for [opsig,cond,:.] in oplist for i in 0.. repeat +; if opsig in $ConditionalOperators then cond:=nil +; [op,sig]:=opsig +; $e:= addModemap(op,dom,sig,cond,['ELT,viewName,i],$e) +; viewName + +(DEFUN |genDomainOps| (|viewName| |dom| |cat|) + (PROG (|siglist| |oplist| |cd| |opsig| |cond| |op| |sig|) + (RETURN + (SEQ (PROGN + (SPADLET |oplist| (|getOperationAlist| |dom| |dom| |cat|)) + (SPADLET |siglist| + (PROG (G167741) + (SPADLET G167741 NIL) + (RETURN + (DO ((G167747 |oplist| (CDR G167747)) + (G167720 NIL)) + ((OR (ATOM G167747) + (PROGN + (SETQ G167720 (CAR G167747)) + NIL) + (PROGN + (PROGN + (SPADLET |sig| (CAR G167720)) + G167720) + NIL)) + (NREVERSE0 G167741)) + (SEQ (EXIT (SETQ G167741 + (CONS |sig| G167741)))))))) + (SPADLET |oplist| + (|substNames| |dom| |viewName| |dom| |oplist|)) + (SPADLET |cd| + (CONS 'LET + (CONS |viewName| + (CONS (CONS '|mkOpVec| + (CONS |dom| + (CONS + (CONS 'LIST + (PROG (G167759) + (SPADLET G167759 NIL) + (RETURN + (DO + ((G167765 |siglist| + (CDR G167765)) + (G167723 NIL)) + ((OR (ATOM G167765) + (PROGN + (SETQ G167723 + (CAR G167765)) + NIL) + (PROGN + (PROGN + (SPADLET |op| + (CAR G167723)) + (SPADLET |sig| + (CADR + G167723)) + G167723) + NIL)) + (NREVERSE0 G167759)) + (SEQ + (EXIT + (SETQ G167759 + (CONS + (CONS 'LIST + (CONS (MKQ |op|) + (CONS + (CONS 'LIST + (PROG + (G167776) + (SPADLET + G167776 + NIL) + (RETURN + (DO + ((G167781 + |sig| + (CDR + G167781)) + (|mode| + NIL)) + ((OR + (ATOM + G167781) + (PROGN + (SETQ + |mode| + (CAR + G167781)) + NIL)) + (NREVERSE0 + G167776)) + (SEQ + (EXIT + (SETQ + G167776 + (CONS + (|mkDomainConstructor| + |mode|) + G167776)))))))) + NIL))) + G167759)))))))) + NIL))) + NIL)))) + (SPADLET |$getDomainCode| (CONS |cd| |$getDomainCode|)) + (DO ((G167796 |oplist| (CDR G167796)) (G167731 NIL) + (|i| 0 (QSADD1 |i|))) + ((OR (ATOM G167796) + (PROGN (SETQ G167731 (CAR G167796)) NIL) + (PROGN + (PROGN + (SPADLET |opsig| (CAR G167731)) + (SPADLET |cond| (CADR G167731)) + G167731) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (COND + ((|member| |opsig| + |$ConditionalOperators|) + (SPADLET |cond| NIL))) + (SPADLET |op| (CAR |opsig|)) + (SPADLET |sig| (CADR |opsig|)) + (SPADLET |$e| + (|addModemap| |op| |dom| |sig| + |cond| + (CONS 'ELT + (CONS |viewName| (CONS |i| NIL))) + |$e|)))))) + |viewName|))))) + +;mkOpVec(dom,siglist) == +; dom:= getPrincipalView dom +; substargs:= [['$,:dom.0],: +; [[a,:x] for a in $FormalMapVariableList for x in rest dom.0]] +; oplist:= getOperationAlistFromLisplib opOf dom.0 +; --new form is ( ) +; ops:= MAKE_-VEC (#siglist) +; for (opSig:= [op,sig]) in siglist for i in 0.. repeat +; u:= ASSQ(op,oplist) +; ASSOC(sig,u) is [.,n,.,'ELT] => ops.i := dom.n +; noplist:= SUBLIS(substargs,u) +; -- following variation on ASSOC needed for GENSYMS in Mutable domains +; AssocBarGensym(SUBST(dom.0,'$,sig),noplist) is [.,n,.,'ELT] => +; ops.i := dom.n +; ops.i := [Undef,[dom.0,i],:opSig] +; ops + +(DEFUN |mkOpVec| (|dom| |siglist|) + (PROG (|substargs| |oplist| |ops| |op| |sig| |u| |noplist| |ISTMP#1| + |ISTMP#2| |n| |ISTMP#3| |ISTMP#4|) + (RETURN + (SEQ (PROGN + (SPADLET |dom| (|getPrincipalView| |dom|)) + (SPADLET |substargs| + (CONS (CONS '$ (ELT |dom| 0)) + (PROG (G167887) + (SPADLET G167887 NIL) + (RETURN + (DO ((G167893 + |$FormalMapVariableList| + (CDR G167893)) + (|a| NIL) + (G167894 (CDR (ELT |dom| 0)) + (CDR G167894)) + (|x| NIL)) + ((OR (ATOM G167893) + (PROGN + (SETQ |a| (CAR G167893)) + NIL) + (ATOM G167894) + (PROGN + (SETQ |x| (CAR G167894)) + NIL)) + (NREVERSE0 G167887)) + (SEQ (EXIT + (SETQ G167887 + (CONS (CONS |a| |x|) + G167887))))))))) + (SPADLET |oplist| + (|getOperationAlistFromLisplib| + (|opOf| (ELT |dom| 0)))) + (SPADLET |ops| (MAKE-VEC (|#| |siglist|))) + (DO ((G167928 |siglist| (CDR G167928)) (|opSig| NIL) + (|i| 0 (QSADD1 |i|))) + ((OR (ATOM G167928) + (PROGN (SETQ |opSig| (CAR G167928)) NIL) + (PROGN + (PROGN + (SPADLET |op| (CAR |opSig|)) + (SPADLET |sig| (CADR |opSig|)) + |opSig|) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |u| (ASSQ |op| |oplist|)) + (COND + ((PROGN + (SPADLET |ISTMP#1| + (|assoc| |sig| |u|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |n| + (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |ISTMP#4| + (QCDR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) + (EQ (QCDR |ISTMP#4|) + NIL) + (EQ (QCAR |ISTMP#4|) + 'ELT))))))))) + (SETELT |ops| |i| (ELT |dom| |n|))) + ('T + (SPADLET |noplist| + (SUBLIS |substargs| |u|)) + (COND + ((PROGN + (SPADLET |ISTMP#1| + (|AssocBarGensym| + (MSUBST (ELT |dom| 0) '$ |sig|) + |noplist|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |n| + (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |ISTMP#4| + (QCDR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) + (EQ (QCDR |ISTMP#4|) NIL) + (EQ (QCAR |ISTMP#4|) + 'ELT))))))))) + (SETELT |ops| |i| (ELT |dom| |n|))) + ('T + (SETELT |ops| |i| + (CONS |Undef| + (CONS + (CONS (ELT |dom| 0) + (CONS |i| NIL)) + |opSig|))))))))))) + |ops|))))) + +;genDomainViewName(a,category) == +;--+ +; a + +(DEFUN |genDomainViewName| (|a| |category|) |a|) + +;compDefWhereClause(['DEF,form,signature,specialCases,body],m,e) == +;-- form is lhs (f a1 ... an) of definition; body is rhs; +;-- signature is (t0 t1 ... tn) where t0= target type, ti=type of ai, i > 0; +;-- specialCases is (NIL l1 ... ln) where li is list of special cases +;-- which can be given for each ti +; +;-- removes declarative and assignment information from form and +;-- signature, placing it in list L, replacing form by ("where",form',:L), +;-- signature by a list of NILs (signifying declarations are in e) +; $sigAlist: local := nil +; $predAlist: local := nil +; +;-- 1. create sigList= list of all signatures which have embedded +;-- declarations moved into global variable $sigAlist +; sigList:= +; [transformType fetchType(a,x,e,form) for a in rest form for x in rest signature] +; where +; fetchType(a,x,e,form) == +; x => x +; getmode(a,e) or userError concat( +; '"There is no mode for argument",a,'"of function",first form) +; transformType x == +; atom x => x +; x is [":",R,Rtype] => +; ($sigAlist:= [[R,:transformType Rtype],:$sigAlist]; x) +; x is ['Record,:.] => x --RDJ 8/83 +; [first x,:[transformType y for y in rest x]] +; +;-- 2. replace each argument of the form (|| x p) by x, recording +;-- the given predicate in global variable $predAlist +; argList:= +; [removeSuchthat a for a in rest form] where +; removeSuchthat x == +; x is ["|",y,p] => ($predAlist:= [[y,:p],:$predAlist]; y) +; x +; +;-- 3. obtain a list of parameter identifiers (x1 .. xn) ordered so that +;-- the type of xi is independent of xj if i < j +; varList:= +; orderByDependency(ASSOCLEFT argDepAlist,ASSOCRIGHT argDepAlist) where +; argDepAlist:= +; [[x,:dependencies] for [x,:y] in argSigAlist] where +; dependencies() == +; setUnion(listOfIdentifiersIn y, +; DELETE(x,listOfIdentifiersIn LASSOC(x,$predAlist))) +; argSigAlist:= [:$sigAlist,:pairList(argList,sigList)] +; +;-- 4. construct a WhereList which declares and/or defines the xi's in +;-- the order constructed in step 3 +; (whereList:= [addSuchthat(x,[":",x,LASSOC(x,argSigAlist)]) for x in varList]) +; where addSuchthat(x,y) == (p:= LASSOC(x,$predAlist) => ["|",y,p]; y) +; +;-- 5. compile new ('DEF,("where",form',:WhereList),:.) where +;-- all argument parameters of form' are bound/declared in WhereList +; comp(form',m,e) where +; form':= +; ["where",defform,:whereList] where +; defform:= +; ['DEF,form'',signature',specialCases,body] where +; form'':= [first form,:argList] +; signature':= [first signature,:[nil for x in rest signature]] + +(DEFUN |compDefWhereClause,transformType| (|x|) + (PROG (|ISTMP#1| R |ISTMP#2| |Rtype|) + (RETURN + (SEQ (IF (ATOM |x|) (EXIT |x|)) + (IF (AND (PAIRP |x|) (EQ (QCAR |x|) '|:|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET R (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |Rtype| (QCAR |ISTMP#2|)) + 'T)))))) + (EXIT (SEQ (SPADLET |$sigAlist| + (CONS + (CONS R + (|compDefWhereClause,transformType| + |Rtype|)) + |$sigAlist|)) + (EXIT |x|)))) + (IF (AND (PAIRP |x|) (EQ (QCAR |x|) '|Record|)) (EXIT |x|)) + (EXIT (CONS (CAR |x|) + (PROG (G167983) + (SPADLET G167983 NIL) + (RETURN + (DO ((G167988 (CDR |x|) (CDR G167988)) + (|y| NIL)) + ((OR (ATOM G167988) + (PROGN + (SETQ |y| (CAR G167988)) + NIL)) + (NREVERSE0 G167983)) + (SEQ (EXIT (SETQ G167983 + (CONS + (|compDefWhereClause,transformType| + |y|) + G167983))))))))))))) + +(DEFUN |compDefWhereClause,fetchType| (|a| |x| |e| |form|) + (SEQ (IF |x| (EXIT |x|)) + (EXIT (OR (|getmode| |a| |e|) + (|userError| + (|concat| + (MAKESTRING "There is no mode for argument") + |a| (MAKESTRING "of function") (CAR |form|))))))) + +(DEFUN |compDefWhereClause,removeSuchthat| (|x|) + (PROG (|ISTMP#1| |y| |ISTMP#2| |p|) + (RETURN + (SEQ (IF (AND (PAIRP |x|) (EQ (QCAR |x|) '|\||) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |y| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |p| (QCAR |ISTMP#2|)) + 'T)))))) + (EXIT (SEQ (SPADLET |$predAlist| + (CONS (CONS |y| |p|) |$predAlist|)) + (EXIT |y|)))) + (EXIT |x|))))) + +(DEFUN |compDefWhereClause,addSuchthat| (|x| |y|) + (PROG (|p|) + (RETURN + (SEQ (IF (SPADLET |p| (LASSOC |x| |$predAlist|)) + (EXIT (CONS '|\|| (CONS |y| (CONS |p| NIL))))) + (EXIT |y|))))) + +(DEFUN |compDefWhereClause| (G168068 |m| |e|) + (PROG (|$sigAlist| |$predAlist| |form| |signature| |specialCases| + |body| |sigList| |argList| |argSigAlist| |x| |y| + |argDepAlist| |varList| |whereList| |form''| |signature'| + |defform| |form'|) + (DECLARE (SPECIAL |$sigAlist| |$predAlist|)) + (RETURN + (SEQ (PROGN + (SPADLET |form| (CADR G168068)) + (SPADLET |signature| (CADDR G168068)) + (SPADLET |specialCases| (CADDDR G168068)) + (SPADLET |body| (CAR (CDDDDR G168068))) + (SPADLET |$sigAlist| NIL) + (SPADLET |$predAlist| NIL) + (SPADLET |sigList| + (PROG (G168097) + (SPADLET G168097 NIL) + (RETURN + (DO ((G168103 (CDR |form|) (CDR G168103)) + (|a| NIL) + (G168104 (CDR |signature|) + (CDR G168104)) + (|x| NIL)) + ((OR (ATOM G168103) + (PROGN + (SETQ |a| (CAR G168103)) + NIL) + (ATOM G168104) + (PROGN + (SETQ |x| (CAR G168104)) + NIL)) + (NREVERSE0 G168097)) + (SEQ (EXIT (SETQ G168097 + (CONS + (|compDefWhereClause,transformType| + (|compDefWhereClause,fetchType| + |a| |x| |e| |form|)) + G168097)))))))) + (SPADLET |argList| + (PROG (G168117) + (SPADLET G168117 NIL) + (RETURN + (DO ((G168122 (CDR |form|) (CDR G168122)) + (|a| NIL)) + ((OR (ATOM G168122) + (PROGN + (SETQ |a| (CAR G168122)) + NIL)) + (NREVERSE0 G168117)) + (SEQ (EXIT (SETQ G168117 + (CONS + (|compDefWhereClause,removeSuchthat| + |a|) + G168117)))))))) + (SPADLET |argSigAlist| + (APPEND |$sigAlist| + (|pairList| |argList| |sigList|))) + (SPADLET |argDepAlist| + (PROG (G168133) + (SPADLET G168133 NIL) + (RETURN + (DO ((G168139 |argSigAlist| + (CDR G168139)) + (G168034 NIL)) + ((OR (ATOM G168139) + (PROGN + (SETQ G168034 (CAR G168139)) + NIL) + (PROGN + (PROGN + (SPADLET |x| (CAR G168034)) + (SPADLET |y| (CDR G168034)) + G168034) + NIL)) + (NREVERSE0 G168133)) + (SEQ (EXIT (SETQ G168133 + (CONS + (CONS |x| + (|union| + (|listOfIdentifiersIn| |y|) + (|delete| |x| + (|listOfIdentifiersIn| + (LASSOC |x| |$predAlist|))))) + G168133)))))))) + (SPADLET |varList| + (|orderByDependency| (ASSOCLEFT |argDepAlist|) + (ASSOCRIGHT |argDepAlist|))) + (SPADLET |whereList| + (PROG (G168150) + (SPADLET G168150 NIL) + (RETURN + (DO ((G168155 |varList| (CDR G168155)) + (|x| NIL)) + ((OR (ATOM G168155) + (PROGN + (SETQ |x| (CAR G168155)) + NIL)) + (NREVERSE0 G168150)) + (SEQ (EXIT (SETQ G168150 + (CONS + (|compDefWhereClause,addSuchthat| + |x| + (CONS '|:| + (CONS |x| + (CONS + (LASSOC |x| |argSigAlist|) + NIL)))) + G168150)))))))) + (SPADLET |form''| (CONS (CAR |form|) |argList|)) + (SPADLET |signature'| + (CONS (CAR |signature|) + (PROG (G168165) + (SPADLET G168165 NIL) + (RETURN + (DO ((G168170 (CDR |signature|) + (CDR G168170)) + (|x| NIL)) + ((OR (ATOM G168170) + (PROGN + (SETQ |x| (CAR G168170)) + NIL)) + (NREVERSE0 G168165)) + (SEQ (EXIT + (SETQ G168165 + (CONS NIL G168165))))))))) + (SPADLET |defform| + (CONS 'DEF + (CONS |form''| + (CONS |signature'| + (CONS |specialCases| + (CONS |body| NIL)))))) + (SPADLET |form'| + (CONS '|where| (CONS |defform| |whereList|))) + (|comp| |form'| |m| |e|)))))) + +;orderByDependency(vl,dl) == +; -- vl is list of variables, dl is list of dependency-lists +; selfDependents:= [v for v in vl for d in dl | MEMQ(v,d)] +; for v in vl for d in dl | MEMQ(v,d) repeat +; (SAY(v," depends on itself"); fatalError:= true) +; fatalError => userError '"Parameter specification error" +; until (null vl) repeat +; newl:= +; [v for v in vl for d in dl | null setIntersection(d,vl)] or return nil +; orderedVarList:= [:newl,:orderedVarList] +; vl':= setDifference(vl,newl) +; dl':= [setDifference(d,newl) for x in vl for d in dl | MEMBER(x,vl')] +; vl:= vl' +; dl:= dl' +; REMDUP NREVERSE orderedVarList --ordered so ith is indep. of jth if i < j + +(DEFUN |orderByDependency| (|vl| |dl|) + (PROG (|selfDependents| |fatalError| |newl| |orderedVarList| |vl'| + |dl'|) + (RETURN + (SEQ (PROGN + (SPADLET |selfDependents| + (PROG (G168215) + (SPADLET G168215 NIL) + (RETURN + (DO ((G168222 |vl| (CDR G168222)) + (|v| NIL) + (G168223 |dl| (CDR G168223)) + (|d| NIL)) + ((OR (ATOM G168222) + (PROGN + (SETQ |v| (CAR G168222)) + NIL) + (ATOM G168223) + (PROGN + (SETQ |d| (CAR G168223)) + NIL)) + (NREVERSE0 G168215)) + (SEQ (EXIT (COND + ((MEMQ |v| |d|) + (SETQ G168215 + (CONS |v| G168215)))))))))) + (DO ((G168239 |vl| (CDR G168239)) (|v| NIL) + (G168240 |dl| (CDR G168240)) (|d| NIL)) + ((OR (ATOM G168239) + (PROGN (SETQ |v| (CAR G168239)) NIL) + (ATOM G168240) + (PROGN (SETQ |d| (CAR G168240)) NIL)) + NIL) + (SEQ (EXIT (COND + ((MEMQ |v| |d|) + (PROGN + (SAY |v| + (MAKESTRING " depends on itself")) + (SPADLET |fatalError| 'T))))))) + (COND + (|fatalError| + (|userError| + (MAKESTRING "Parameter specification error"))) + ('T + (DO ((G168258 NIL (NULL |vl|))) (G168258 NIL) + (SEQ (EXIT (PROGN + (SPADLET |newl| + (OR + (PROG (G168268) + (SPADLET G168268 NIL) + (RETURN + (DO + ((G168275 |vl| + (CDR G168275)) + (|v| NIL) + (G168276 |dl| + (CDR G168276)) + (|d| NIL)) + ((OR (ATOM G168275) + (PROGN + (SETQ |v| + (CAR G168275)) + NIL) + (ATOM G168276) + (PROGN + (SETQ |d| + (CAR G168276)) + NIL)) + (NREVERSE0 G168268)) + (SEQ + (EXIT + (COND + ((NULL + (|intersection| + |d| |vl|)) + (SETQ G168268 + (CONS |v| + G168268))))))))) + (RETURN NIL))) + (SPADLET |orderedVarList| + (APPEND |newl| + |orderedVarList|)) + (SPADLET |vl'| + (SETDIFFERENCE |vl| |newl|)) + (SPADLET |dl'| + (PROG (G168291) + (SPADLET G168291 NIL) + (RETURN + (DO + ((G168298 |vl| + (CDR G168298)) + (|x| NIL) + (G168299 |dl| + (CDR G168299)) + (|d| NIL)) + ((OR (ATOM G168298) + (PROGN + (SETQ |x| + (CAR G168298)) + NIL) + (ATOM G168299) + (PROGN + (SETQ |d| + (CAR G168299)) + NIL)) + (NREVERSE0 G168291)) + (SEQ + (EXIT + (COND + ((|member| |x| |vl'|) + (SETQ G168291 + (CONS + (SETDIFFERENCE |d| + |newl|) + G168291)))))))))) + (SPADLET |vl| |vl'|) + (SPADLET |dl| |dl'|))))) + (REMDUP (NREVERSE |orderedVarList|))))))))) + +;compInternalFunction(df is ['DEF,form,signature,specialCases,body],m,e) == +; -- $insideExpressionIfTrue:=false +; [op,:argl]:=form +; not(IDENTP(op)) => +; stackAndThrow ["Bad name for internal function:",op] +; #argl=0 => +; stackAndThrow ["Argumentless internal functions unsupported:",op] +; --nf:=["where",["LET",[":",op,["Mapping",:signature]],nbody],_ +; -- :whereList1,:whereList2] +; nbody:=["+->",argl,body] +; nf:=["LET",[":",op,["Mapping",:signature]],nbody] +; ress:=comp(nf,m,e) +; ress + +(DEFUN |compInternalFunction| (|df| |m| |e|) + (PROG (|form| |signature| |specialCases| |body| |op| |argl| |nbody| + |nf| |ress|) + (RETURN + (PROGN + (SPADLET |form| (CADR |df|)) + (SPADLET |signature| (CADDR |df|)) + (SPADLET |specialCases| (CADDDR |df|)) + (SPADLET |body| (CAR (CDDDDR |df|))) + (SPADLET |op| (CAR |form|)) + (SPADLET |argl| (CDR |form|)) + (COND + ((NULL (IDENTP |op|)) + (|stackAndThrow| + (CONS '|Bad name for internal function:| + (CONS |op| NIL)))) + ((EQL (|#| |argl|) 0) + (|stackAndThrow| + (CONS '|Argumentless internal functions unsupported:| + (CONS |op| NIL)))) + ('T + (SPADLET |nbody| + (CONS '+-> (CONS |argl| (CONS |body| NIL)))) + (SPADLET |nf| + (CONS 'LET + (CONS (CONS '|:| + (CONS |op| + (CONS + (CONS '|Mapping| |signature|) + NIL))) + (CONS |nbody| NIL)))) + (SPADLET |ress| (|comp| |nf| |m| |e|)) |ress|)))))) + +;compDefineCapsuleFunction(df is ['DEF,form,signature,specialCases,body], +; m,oldE,$prefix,$formalArgList) == +; [lineNumber,:specialCases] := specialCases +; e := oldE +; --1. bind global variables +; $form: local := nil +; $op: local := nil +; $functionStats: local:= [0,0] +; $argumentConditionList: local := nil +; $finalEnv: local := nil +; --used by ReplaceExitEtc to get a common environment +; $initCapsuleErrorCount: local:= #$semanticErrorStack +; $insideCapsuleFunctionIfTrue: local:= true +; $CapsuleModemapFrame: local:= e +; $CapsuleDomainsInScope: local:= get("$DomainsInScope","special",e) +; $insideExpressionIfTrue: local:= true +; $returnMode:= m +; [$op,:argl]:= form +; $form:= [$op,:argl] +; argl:= stripOffArgumentConditions argl +; $formalArgList:= [:argl,:$formalArgList] +; +; --let target and local signatures help determine modes of arguments +; argModeList:= +; identSig:= hasSigInTargetCategory(argl,form,first signature,e) => +; (e:= checkAndDeclare(argl,form,identSig,e); rest identSig) +; [getArgumentModeOrMoan(a,form,e) for a in argl] +; argModeList:= stripOffSubdomainConditions(argModeList,argl) +; signature':= [first signature,:argModeList] +; if null identSig then --make $op a local function +; oldE := put($op,'mode,['Mapping,:signature'],oldE) +; +; --obtain target type if not given +; if null first signature' then signature':= +; identSig => identSig +; getSignature($op,rest signature',e) or return nil +; e:= giveFormalParametersValues(argl,e) +; +; $signatureOfForm:= signature' --this global is bound in compCapsuleItems +; $functionLocations := [[[$op,$signatureOfForm],:lineNumber], +; :$functionLocations] +; e:= addDomain(first signature',e) +; e:= compArgumentConditions e +; +; if $profileCompiler then +; for x in argl for t in rest signature' repeat profileRecord('arguments,x,t) +; --4. introduce needed domains into extendedEnv +; for domain in signature' repeat e:= addDomain(domain,e) +; +; --6. compile body in environment with extended environment +; rettype:= resolve(signature'.target,$returnMode) +; +; localOrExported := +; null MEMBER($op,$formalArgList) and +; getmode($op,e) is ['Mapping,:.] => 'local +; 'exported +; +; --6a skip if compiling only certain items but not this one +; -- could be moved closer to the top +; formattedSig := formatUnabbreviated ['Mapping,:signature'] +; $compileOnlyCertainItems and _ +; not MEMBER($op, $compileOnlyCertainItems) => +; sayBrightly ['" skipping ", localOrExported,:bright $op] +; [nil,['Mapping,:signature'],oldE] +; sayBrightly ['" compiling ",localOrExported, +; :bright $op,'": ",:formattedSig] +; +; if $newComp = true then +; wholeBody := ['DEF, form, signature', specialCases, body] +; T := CATCH('compCapsuleBody, newComp(wholeBody,$NoValueMode,e)) +; or [" ",rettype,e] +; T := [T.expr.2.2, rettype, T.env] +; if $newCompCompare=true then +; oldT := CATCH('compCapsuleBody, compOrCroak(body,rettype,e)) +; or [" ",rettype,e] +; SAY '"The old compiler generates:" +; prTriple oldT +; SAY '"The new compiler generates:" +; prTriple T +; else +; T := CATCH('compCapsuleBody, compOrCroak(body,rettype,e)) +; or [" ",rettype,e] +;--+ +; NRTassignCapsuleFunctionSlot($op,signature') +; if $newCompCompare=true then +; SAY '"The old compiler generates:" +; prTriple T +;-- A THROW to the above CATCH occurs if too many semantic errors occur +;-- see stackSemanticError +; catchTag:= MKQ GENSYM() +; fun:= +; body':= replaceExitEtc(T.expr,catchTag,"TAGGEDreturn",$returnMode) +; body':= addArgumentConditions(body',$op) +; finalBody:= ["CATCH",catchTag,body'] +; compileCases([$op,["LAM",[:argl,'_$],finalBody]],oldE) +; $functorStats:= addStats($functorStats,$functionStats) +; +; +;-- 7. give operator a 'value property +; val:= [fun,signature',e] +; [fun,['Mapping,:signature'],oldE] -- oldE:= put($op,'value,removeEnv val,e) + +(DEFUN |compDefineCapsuleFunction| + (|df| |m| |oldE| |$prefix| |$formalArgList|) + (DECLARE (SPECIAL |$prefix| |$formalArgList|)) + (PROG (|$form| |$op| |$functionStats| |$argumentConditionList| + |$finalEnv| |$initCapsuleErrorCount| + |$insideCapsuleFunctionIfTrue| |$CapsuleModemapFrame| + |$CapsuleDomainsInScope| |$insideExpressionIfTrue| + |form| |signature| |body| |LETTMP#1| |lineNumber| + |specialCases| |argl| |identSig| |argModeList| + |signature'| |e| |rettype| |ISTMP#1| |localOrExported| + |formattedSig| |wholeBody| |oldT| T$ |catchTag| + |body'| |finalBody| |fun| |val|) + (DECLARE (SPECIAL |$form| |$op| |$functionStats| + |$argumentConditionList| |$finalEnv| + |$initCapsuleErrorCount| + |$insideCapsuleFunctionIfTrue| + |$CapsuleModemapFrame| |$CapsuleDomainsInScope| + |$insideExpressionIfTrue|)) + (RETURN + (SEQ (PROGN + (SPADLET |form| (CADR |df|)) + (SPADLET |signature| (CADDR |df|)) + (SPADLET |specialCases| (CADDDR |df|)) + (SPADLET |body| (CAR (CDDDDR |df|))) + (SPADLET |LETTMP#1| |specialCases|) + (SPADLET |lineNumber| (CAR |LETTMP#1|)) + (SPADLET |specialCases| (CDR |LETTMP#1|)) + (SPADLET |e| |oldE|) + (SPADLET |$form| NIL) + (SPADLET |$op| NIL) + (SPADLET |$functionStats| (CONS 0 (CONS 0 NIL))) + (SPADLET |$argumentConditionList| NIL) + (SPADLET |$finalEnv| NIL) + (SPADLET |$initCapsuleErrorCount| + (|#| |$semanticErrorStack|)) + (SPADLET |$insideCapsuleFunctionIfTrue| 'T) + (SPADLET |$CapsuleModemapFrame| |e|) + (SPADLET |$CapsuleDomainsInScope| + (|get| '|$DomainsInScope| '|special| |e|)) + (SPADLET |$insideExpressionIfTrue| 'T) + (SPADLET |$returnMode| |m|) + (SPADLET |$op| (CAR |form|)) + (SPADLET |argl| (CDR |form|)) + (SPADLET |$form| (CONS |$op| |argl|)) + (SPADLET |argl| (|stripOffArgumentConditions| |argl|)) + (SPADLET |$formalArgList| + (APPEND |argl| |$formalArgList|)) + (SPADLET |argModeList| + (COND + ((SPADLET |identSig| + (|hasSigInTargetCategory| |argl| + |form| (CAR |signature|) |e|)) + (SPADLET |e| + (|checkAndDeclare| |argl| |form| + |identSig| |e|)) + (CDR |identSig|)) + ('T + (PROG (G168401) + (SPADLET G168401 NIL) + (RETURN + (DO ((G168406 |argl| (CDR G168406)) + (|a| NIL)) + ((OR (ATOM G168406) + (PROGN + (SETQ |a| (CAR G168406)) + NIL)) + (NREVERSE0 G168401)) + (SEQ (EXIT + (SETQ G168401 + (CONS + (|getArgumentModeOrMoan| |a| + |form| |e|) + G168401)))))))))) + (SPADLET |argModeList| + (|stripOffSubdomainConditions| |argModeList| + |argl|)) + (SPADLET |signature'| + (CONS (CAR |signature|) |argModeList|)) + (COND + ((NULL |identSig|) + (SPADLET |oldE| + (|put| |$op| '|mode| + (CONS '|Mapping| |signature'|) |oldE|)))) + (COND + ((NULL (CAR |signature'|)) + (SPADLET |signature'| + (COND + (|identSig| |identSig|) + ('T + (OR (|getSignature| |$op| + (CDR |signature'|) |e|) + (RETURN NIL))))))) + (SPADLET |e| (|giveFormalParametersValues| |argl| |e|)) + (SPADLET |$signatureOfForm| |signature'|) + (SPADLET |$functionLocations| + (CONS (CONS (CONS |$op| + (CONS |$signatureOfForm| NIL)) + |lineNumber|) + |$functionLocations|)) + (SPADLET |e| (|addDomain| (CAR |signature'|) |e|)) + (SPADLET |e| (|compArgumentConditions| |e|)) + (COND + (|$profileCompiler| + (DO ((G168416 |argl| (CDR G168416)) (|x| NIL) + (G168417 (CDR |signature'|) (CDR G168417)) + (|t| NIL)) + ((OR (ATOM G168416) + (PROGN (SETQ |x| (CAR G168416)) NIL) + (ATOM G168417) + (PROGN (SETQ |t| (CAR G168417)) NIL)) + NIL) + (SEQ (EXIT (|profileRecord| '|arguments| |x| |t|)))))) + (DO ((G168429 |signature'| (CDR G168429)) + (|domain| NIL)) + ((OR (ATOM G168429) + (PROGN (SETQ |domain| (CAR G168429)) NIL)) + NIL) + (SEQ (EXIT (SPADLET |e| (|addDomain| |domain| |e|))))) + (SPADLET |rettype| + (|resolve| (CAR |signature'|) |$returnMode|)) + (SPADLET |localOrExported| + (COND + ((AND (NULL (|member| |$op| |$formalArgList|)) + (PROGN + (SPADLET |ISTMP#1| + (|getmode| |$op| |e|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|Mapping|)))) + '|local|) + ('T '|exported|))) + (SPADLET |formattedSig| + (|formatUnabbreviated| + (CONS '|Mapping| |signature'|))) + (COND + ((AND |$compileOnlyCertainItems| + (NULL (|member| |$op| |$compileOnlyCertainItems|))) + (|sayBrightly| + (CONS (MAKESTRING " skipping ") + (CONS |localOrExported| (|bright| |$op|)))) + (CONS NIL + (CONS (CONS '|Mapping| |signature'|) + (CONS |oldE| NIL)))) + ('T + (|sayBrightly| + (CONS (MAKESTRING " compiling ") + (CONS |localOrExported| + (APPEND (|bright| |$op|) + (CONS (MAKESTRING ": ") + |formattedSig|))))) + (COND + ((BOOT-EQUAL |$newComp| 'T) + (SPADLET |wholeBody| + (CONS 'DEF + (CONS |form| + (CONS |signature'| + (CONS |specialCases| + (CONS |body| NIL)))))) + (SPADLET T$ + (OR (CATCH '|compCapsuleBody| + (|newComp| |wholeBody| |$NoValueMode| + |e|)) + (CONS (INTERN " " "BOOT") + (CONS |rettype| (CONS |e| NIL))))) + (SPADLET T$ + (CONS (ELT (ELT (CAR T$) 2) 2) + (CONS |rettype| + (CONS (CADDR T$) NIL)))) + (COND + ((BOOT-EQUAL |$newCompCompare| 'T) + (SPADLET |oldT| + (OR (CATCH '|compCapsuleBody| + (|compOrCroak| |body| |rettype| + |e|)) + (CONS (INTERN " " "BOOT") + (CONS |rettype| (CONS |e| NIL))))) + (SAY (MAKESTRING "The old compiler generates:")) + (|prTriple| |oldT|) + (SAY (MAKESTRING "The new compiler generates:")) + (|prTriple| T$)) + ('T NIL))) + ('T + (SPADLET T$ + (OR (CATCH '|compCapsuleBody| + (|compOrCroak| |body| |rettype| |e|)) + (CONS (INTERN " " "BOOT") + (CONS |rettype| (CONS |e| NIL))))) + (|NRTassignCapsuleFunctionSlot| |$op| |signature'|) + (COND + ((BOOT-EQUAL |$newCompCompare| 'T) + (SAY (MAKESTRING "The old compiler generates:")) + (|prTriple| T$)) + ('T NIL)))) + (SPADLET |catchTag| (MKQ (GENSYM))) + (SPADLET |fun| + (PROGN + (SPADLET |body'| + (|replaceExitEtc| (CAR T$) + |catchTag| '|TAGGEDreturn| + |$returnMode|)) + (SPADLET |body'| + (|addArgumentConditions| |body'| + |$op|)) + (SPADLET |finalBody| + (CONS 'CATCH + (CONS |catchTag| + (CONS |body'| NIL)))) + (|compileCases| + (CONS |$op| + (CONS + (CONS 'LAM + (CONS + (APPEND |argl| (CONS '$ NIL)) + (CONS |finalBody| NIL))) + NIL)) + |oldE|))) + (SPADLET |$functorStats| + (|addStats| |$functorStats| |$functionStats|)) + (SPADLET |val| + (CONS |fun| + (CONS |signature'| (CONS |e| NIL)))) + (CONS |fun| + (CONS (CONS '|Mapping| |signature'|) + (CONS |oldE| NIL)))))))))) + +;getSignatureFromMode(form,e) == +; getmode(opOf form,e) is ['Mapping,:signature] => +; #form^=#signature => stackAndThrow ["Wrong number of arguments: ",form] +; EQSUBSTLIST(rest form,take(#rest form,$FormalMapVariableList),signature) + +(DEFUN |getSignatureFromMode| (|form| |e|) + (PROG (|ISTMP#1| |signature|) + (RETURN + (SEQ (COND + ((PROGN + (SPADLET |ISTMP#1| (|getmode| (|opOf| |form|) |e|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) '|Mapping|) + (PROGN (SPADLET |signature| (QCDR |ISTMP#1|)) 'T))) + (EXIT (COND + ((NEQUAL (|#| |form|) (|#| |signature|)) + (|stackAndThrow| + (CONS '|Wrong number of arguments: | + (CONS |form| NIL)))) + ('T + (EQSUBSTLIST (CDR |form|) + (TAKE (|#| (CDR |form|)) + |$FormalMapVariableList|) + |signature|)))))))))) + +;hasSigInTargetCategory(argl,form,opsig,e) == +; mList:= [getArgumentMode(x,e) for x in argl] +; --each element is a declared mode for the variable or nil if none exists +; potentialSigList:= +; REMDUP +; [sig +; for [[opName,sig,:.],:.] in $domainShell.(1) | +; fn(opName,sig,opsig,mList,form)] where +; fn(opName,sig,opsig,mList,form) == +; opName=$op and #sig=#form and (null opsig or opsig=first sig) and +; (and/[compareMode2Arg(x,m) for x in mList for m in rest sig]) +; c:= #potentialSigList +; 1=c => first potentialSigList +; --accept only those signatures op right length which match declared modes +; 0=c => (#(sig:= getSignatureFromMode(form,e))=#form => sig; nil) +; 1 +; sig:= first potentialSigList +; stackWarning ["signature of lhs not unique:",:bright sig,"chosen"] +; sig +; nil --this branch will force all arguments to be declared + +(DEFUN |hasSigInTargetCategory,fn| + (|opName| |sig| |opsig| |mList| |form|) + (PROG () + (RETURN + (SEQ (AND (AND (AND (BOOT-EQUAL |opName| |$op|) + (BOOT-EQUAL (|#| |sig|) (|#| |form|))) + (OR (NULL |opsig|) + (BOOT-EQUAL |opsig| (CAR |sig|)))) + (PROG (G168523) + (SPADLET G168523 'T) + (RETURN + (DO ((G168530 NIL (NULL G168523)) + (G168531 |mList| (CDR G168531)) (|x| NIL) + (G168532 (CDR |sig|) (CDR G168532)) + (|m| NIL)) + ((OR G168530 (ATOM G168531) + (PROGN (SETQ |x| (CAR G168531)) NIL) + (ATOM G168532) + (PROGN (SETQ |m| (CAR G168532)) NIL)) + G168523) + (SEQ (EXIT (SETQ G168523 + (AND G168523 + (|compareMode2Arg| |x| |m|))))))))))))) + +(DEFUN |hasSigInTargetCategory| (|argl| |form| |opsig| |e|) + (PROG (|mList| |opName| |potentialSigList| |c| |sig|) + (RETURN + (SEQ (PROGN + (SPADLET |mList| + (PROG (G168561) + (SPADLET G168561 NIL) + (RETURN + (DO ((G168566 |argl| (CDR G168566)) + (|x| NIL)) + ((OR (ATOM G168566) + (PROGN + (SETQ |x| (CAR G168566)) + NIL)) + (NREVERSE0 G168561)) + (SEQ (EXIT (SETQ G168561 + (CONS + (|getArgumentMode| |x| |e|) + G168561)))))))) + (SPADLET |potentialSigList| + (REMDUP (PROG (G168578) + (SPADLET G168578 NIL) + (RETURN + (DO ((G168585 + (ELT |$domainShell| 1) + (CDR G168585)) + (G168546 NIL)) + ((OR (ATOM G168585) + (PROGN + (SETQ G168546 + (CAR G168585)) + NIL) + (PROGN + (PROGN + (SPADLET |opName| + (CAAR G168546)) + (SPADLET |sig| + (CADAR G168546)) + G168546) + NIL)) + (NREVERSE0 G168578)) + (SEQ + (EXIT + (COND + ((|hasSigInTargetCategory,fn| + |opName| |sig| |opsig| + |mList| |form|) + (SETQ G168578 + (CONS |sig| G168578))))))))))) + (SPADLET |c| (|#| |potentialSigList|)) + (COND + ((EQL 1 |c|) (CAR |potentialSigList|)) + ((EQL 0 |c|) + (COND + ((BOOT-EQUAL + (|#| (SPADLET |sig| + (|getSignatureFromMode| |form| + |e|))) + (|#| |form|)) + |sig|) + ('T NIL))) + ((> |c| 1) (SPADLET |sig| (CAR |potentialSigList|)) + (|stackWarning| + (CONS '|signature of lhs not unique:| + (APPEND (|bright| |sig|) + (CONS '|chosen| NIL)))) + |sig|) + ('T NIL))))))) + +;compareMode2Arg(x,m) == null x or modeEqual(x,m) + +(DEFUN |compareMode2Arg| (|x| |m|) + (OR (NULL |x|) (|modeEqual| |x| |m|))) + +;getArgumentModeOrMoan(x,form,e) == +; getArgumentMode(x,e) or +; stackSemanticError(["argument ",x," of ",form," is not declared"],nil) + +(DEFUN |getArgumentModeOrMoan| (|x| |form| |e|) + (OR (|getArgumentMode| |x| |e|) + (|stackSemanticError| + (CONS '|argument | + (CONS |x| + (CONS '| of | + (CONS |form| + (CONS '| is not declared| NIL))))) + NIL))) + +;getArgumentMode(x,e) == +; STRINGP x => x +; m:= get(x,'mode,e) => m + +(DEFUN |getArgumentMode| (|x| |e|) + (PROG (|m|) + (RETURN + (COND + ((STRINGP |x|) |x|) + ((SPADLET |m| (|get| |x| '|mode| |e|)) |m|))))) + +;checkAndDeclare(argl,form,sig,e) == +; +;-- arguments with declared types must agree with those in sig; +;-- those that don't get declarations put into e +; for a in argl for m in rest sig repeat +; m1:= getArgumentMode(a,e) => +; ^modeEqual(m1,m) => +; stack:= [" ",:bright a,'"must have type ",m, +; '" not ",m1,'%l,:stack] +; e:= put(a,'mode,m,e) +; if stack then +; sayBrightly ['" Parameters of ",:bright first form, +; '" are of wrong type:",'%l,:stack] +; e + +(DEFUN |checkAndDeclare| (|argl| |form| |sig| |e|) + (PROG (|m1| |stack|) + (RETURN + (SEQ (PROGN + (DO ((G168621 |argl| (CDR G168621)) (|a| NIL) + (G168622 (CDR |sig|) (CDR G168622)) (|m| NIL)) + ((OR (ATOM G168621) + (PROGN (SETQ |a| (CAR G168621)) NIL) + (ATOM G168622) + (PROGN (SETQ |m| (CAR G168622)) NIL)) + NIL) + (SEQ (COND + ((SPADLET |m1| (|getArgumentMode| |a| |e|)) + (COND + ((NULL (|modeEqual| |m1| |m|)) + (EXIT (SPADLET |stack| + (CONS '| | + (APPEND (|bright| |a|) + (CONS + (MAKESTRING + "must have type ") + (CONS |m| + (CONS (MAKESTRING " not ") + (CONS |m1| + (CONS '|%l| |stack|)))))))))))) + ('T (SPADLET |e| (|put| |a| '|mode| |m| |e|)))))) + (COND + (|stack| (|sayBrightly| + (CONS (MAKESTRING " Parameters of ") + (APPEND (|bright| (CAR |form|)) + (CONS + (MAKESTRING + " are of wrong type:") + (CONS '|%l| |stack|))))))) + |e|))))) + +;getSignature(op,argModeList,$e) == +; --tpd mmList:= get(op,'modemap,$e) +; --tpd for [[dc,:sig],:.] in mmList repeat printSignature(" ",op,sig) +; 1=# +; (sigl:= +; REMDUP +; [sig +; for [[dc,:sig],[pred,:.]] in (mmList:= get(op,'modemap,$e)) | dc='_$ +; and rest sig=argModeList and knownInfo pred]) => first sigl +; null sigl => +; (u:= getmode(op,$e)) is ['Mapping,:sig] => sig +; SAY '"************* USER ERROR **********" +; SAY("available signatures for ",op,": ") +; if null mmList +; then SAY " NONE" +; else for [[dc,:sig],:.] in mmList repeat printSignature(" ",op,sig) +; printSignature("NEED ",op,["?",:argModeList]) +; nil +; for u in sigl repeat +; for v in sigl | not (u=v) repeat +; if SourceLevelSubsume(u,v) then sigl:= DELETE(v,sigl) +; --before we complain about duplicate signatures, we should +; --check that we do not have for example, a partial - as +; --well as a total one. SourceLevelSubsume (from CATEGORY BOOT) +; --should do this +; 1=#sigl => first sigl +; stackSemanticError(["duplicate signatures for ",op,": ",argModeList],nil) + +(DEFUN |getSignature| (|op| |argModeList| |$e|) + (DECLARE (SPECIAL |$e|)) + (PROG (|mmList| |pred| |u| |ISTMP#1| |dc| |sig| |sigl|) + (RETURN + (SEQ (COND + ((EQL 1 + (|#| (SPADLET |sigl| + (REMDUP (PROG (G168658) + (SPADLET G168658 NIL) + (RETURN + (DO + ((G168665 + (SPADLET |mmList| + (|get| |op| '|modemap| + |$e|)) + (CDR G168665)) + (G168637 NIL)) + ((OR (ATOM G168665) + (PROGN + (SETQ G168637 + (CAR G168665)) + NIL) + (PROGN + (PROGN + (SPADLET |dc| + (CAAR G168637)) + (SPADLET |sig| + (CDAR G168637)) + (SPADLET |pred| + (CAADR G168637)) + G168637) + NIL)) + (NREVERSE0 G168658)) + (SEQ + (EXIT + (COND + ((AND + (BOOT-EQUAL |dc| + '$) + (BOOT-EQUAL + (CDR |sig|) + |argModeList|) + (|knownInfo| + |pred|)) + (SETQ G168658 + (CONS |sig| + G168658))))))))))))) + (CAR |sigl|)) + ((NULL |sigl|) + (COND + ((PROGN + (SPADLET |ISTMP#1| + (SPADLET |u| (|getmode| |op| |$e|))) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|Mapping|) + (PROGN (SPADLET |sig| (QCDR |ISTMP#1|)) 'T))) + |sig|) + ('T + (SAY (MAKESTRING + "************* USER ERROR **********")) + (SAY (MAKESTRING "available signatures for ") |op| + (MAKESTRING ": ")) + (COND + ((NULL |mmList|) (SAY (MAKESTRING " NONE"))) + ('T + (DO ((G168676 |mmList| (CDR G168676)) + (G168646 NIL)) + ((OR (ATOM G168676) + (PROGN + (SETQ G168646 (CAR G168676)) + NIL) + (PROGN + (PROGN + (SPADLET |dc| (CAAR G168646)) + (SPADLET |sig| (CDAR G168646)) + G168646) + NIL)) + NIL) + (SEQ (EXIT (|printSignature| '| | |op| |sig|)))))) + (|printSignature| '|NEED | |op| + (CONS '? |argModeList|)) + NIL))) + ('T + (DO ((G168686 |sigl| (CDR G168686)) (|u| NIL)) + ((OR (ATOM G168686) + (PROGN (SETQ |u| (CAR G168686)) NIL)) + NIL) + (SEQ (EXIT (DO ((G168696 |sigl| (CDR G168696)) + (|v| NIL)) + ((OR (ATOM G168696) + (PROGN + (SETQ |v| (CAR G168696)) + NIL)) + NIL) + (SEQ (EXIT (COND + ((NULL (BOOT-EQUAL |u| |v|)) + (COND + ((|SourceLevelSubsume| |u| + |v|) + (SPADLET |sigl| + (|delete| |v| |sigl|))) + ('T NIL)))))))))) + (COND + ((EQL 1 (|#| |sigl|)) (CAR |sigl|)) + ('T + (|stackSemanticError| + (CONS '|duplicate signatures for | + (CONS |op| + (CONS '|: | (CONS |argModeList| NIL)))) + NIL))))))))) + +;--% ARGUMENT CONDITION CODE +; +;stripOffArgumentConditions argl == +; [f for x in argl for i in 1..] where +; f() == +; x is ["|",arg,condition] => +; condition:= SUBST('_#1,arg,condition) +; -- in case conditions are given in terms of argument names, replace +; $argumentConditionList:= [[i,arg,condition],:$argumentConditionList] +; arg +; x + +(DEFUN |stripOffArgumentConditions| (|argl|) + (PROG (|ISTMP#1| |arg| |ISTMP#2| |condition|) + (RETURN + (SEQ (PROG (G168756) + (SPADLET G168756 NIL) + (RETURN + (DO ((G168769 |argl| (CDR G168769)) (|x| NIL) + (|i| 1 (QSADD1 |i|))) + ((OR (ATOM G168769) + (PROGN (SETQ |x| (CAR G168769)) NIL)) + (NREVERSE0 G168756)) + (SEQ (EXIT (SETQ G168756 + (CONS (COND + ((AND (PAIRP |x|) + (EQ (QCAR |x|) '|\||) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |arg| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) + NIL) + (PROGN + (SPADLET + |condition| + (QCAR |ISTMP#2|)) + 'T)))))) + (SPADLET |condition| + (MSUBST '|#1| |arg| + |condition|)) + (SPADLET + |$argumentConditionList| + (CONS + (CONS |i| + (CONS |arg| + (CONS |condition| NIL))) + |$argumentConditionList|)) + |arg|) + ('T |x|)) + G168756))))))))))) + +;stripOffSubdomainConditions(margl,argl) == +; [f for x in margl for arg in argl for i in 1..] where +; f == +; x is ['SubDomain,marg,condition] => +; pair:= ASSOC(i,$argumentConditionList) => +; (RPLAC(CADR pair,MKPF([condition,CADR pair],'AND)); marg) +; $argumentConditionList:= [[i,arg,condition],:$argumentConditionList] +; marg +; x + +(DEFUN |stripOffSubdomainConditions| (|margl| |argl|) + (PROG (|ISTMP#1| |marg| |ISTMP#2| |condition| |pair|) + (RETURN + (SEQ (PROG (G168825) + (SPADLET G168825 NIL) + (RETURN + (DO ((G168839 |margl| (CDR G168839)) (|x| NIL) + (G168840 |argl| (CDR G168840)) (|arg| NIL) + (|i| 1 (QSADD1 |i|))) + ((OR (ATOM G168839) + (PROGN (SETQ |x| (CAR G168839)) NIL) + (ATOM G168840) + (PROGN (SETQ |arg| (CAR G168840)) NIL)) + (NREVERSE0 G168825)) + (SEQ (EXIT (SETQ G168825 + (CONS (COND + ((AND (PAIRP |x|) + (EQ (QCAR |x|) + '|SubDomain|) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |marg| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) + NIL) + (PROGN + (SPADLET + |condition| + (QCAR |ISTMP#2|)) + 'T)))))) + (COND + ((SPADLET |pair| + (|assoc| |i| + |$argumentConditionList|)) + (RPLAC (CADR |pair|) + (MKPF + (CONS |condition| + (CONS (CADR |pair|) + NIL)) + 'AND)) + |marg|) + ('T + (SPADLET + |$argumentConditionList| + (CONS + (CONS |i| + (CONS |arg| + (CONS |condition| + NIL))) + |$argumentConditionList|)) + |marg|))) + ('T |x|)) + G168825))))))))))) + +;compArgumentConditions e == +; $argumentConditionList:= +; [f for [n,a,x] in $argumentConditionList] where +; f == +; y:= SUBST(a,'_#1,x) +; T := [.,.,e]:= compOrCroak(y,$Boolean,e) +; [n,x,T.expr] +; e + +(DEFUN |compArgumentConditions| (|e|) + (PROG (|n| |a| |x| |y| |LETTMP#1| T$) + (RETURN + (SEQ (PROGN + (SPADLET |$argumentConditionList| + (PROG (G168890) + (SPADLET G168890 NIL) + (RETURN + (DO ((G168902 |$argumentConditionList| + (CDR G168902)) + (G168865 NIL)) + ((OR (ATOM G168902) + (PROGN + (SETQ G168865 (CAR G168902)) + NIL) + (PROGN + (PROGN + (SPADLET |n| (CAR G168865)) + (SPADLET |a| (CADR G168865)) + (SPADLET |x| (CADDR G168865)) + G168865) + NIL)) + (NREVERSE0 G168890)) + (SEQ (EXIT (SETQ G168890 + (CONS + (PROGN + (SPADLET |y| + (MSUBST |a| '|#1| |x|)) + (SPADLET T$ + (PROGN + (SPADLET |LETTMP#1| + (|compOrCroak| |y| + |$Boolean| |e|)) + (SPADLET |e| + (CADDR |LETTMP#1|)) + |LETTMP#1|)) + (CONS |n| + (CONS |x| + (CONS (CAR T$) NIL)))) + G168890)))))))) + |e|))))) + +;addArgumentConditions($body,$functionName) == +; $argumentConditionList => +; --$body is only used in this function +; fn $argumentConditionList where +; fn clist == +; clist is [[n,untypedCondition,typedCondition],:.] => +; ['COND,[typedCondition,fn rest clist], +; [$true,["argumentDataError",n, +; MKQ untypedCondition,MKQ $functionName]]] +; null clist => $body +; systemErrorHere '"addArgumentConditions" +; $body + +(DEFUN |addArgumentConditions,fn| (|clist|) + (PROG (|ISTMP#1| |n| |ISTMP#2| |untypedCondition| |ISTMP#3| + |typedCondition|) + (RETURN + (SEQ (IF (AND (PAIRP |clist|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |clist|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |n| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |untypedCondition| + (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |typedCondition| + (QCAR |ISTMP#3|)) + 'T)))))))) + (EXIT (CONS 'COND + (CONS (CONS |typedCondition| + (CONS + (|addArgumentConditions,fn| + (CDR |clist|)) + NIL)) + (CONS (CONS |$true| + (CONS + (CONS '|argumentDataError| + (CONS |n| + (CONS + (MKQ |untypedCondition|) + (CONS (MKQ |$functionName|) + NIL)))) + NIL)) + NIL))))) + (IF (NULL |clist|) (EXIT |$body|)) + (EXIT (|systemErrorHere| + (MAKESTRING "addArgumentConditions"))))))) + +(DEFUN |addArgumentConditions| (|$body| |$functionName|) + (DECLARE (SPECIAL |$body| |$functionName|)) + (COND + (|$argumentConditionList| + (|addArgumentConditions,fn| |$argumentConditionList|)) + ('T |$body|))) + +;putInLocalDomainReferences (def := [opName,[lam,varl,body]]) == +; $elt: local := ($QuickCode => 'QREFELT; 'ELT) +;--+ +; NRTputInTail CDDADR def +; def + +(DEFUN |putInLocalDomainReferences| (|def|) + (PROG (|$elt| |opName| |lam| |varl| |body|) + (DECLARE (SPECIAL |$elt|)) + (RETURN + (PROGN + (SPADLET |opName| (CAR |def|)) + (SPADLET |lam| (CAADR |def|)) + (SPADLET |varl| (CADADR |def|)) + (SPADLET |body| (CAR (CDDADR |def|))) + (SPADLET |$elt| (COND (|$QuickCode| 'QREFELT) ('T 'ELT))) + (|NRTputInTail| (CDDADR |def|)) + |def|)))) + +;canCacheLocalDomain(dom,elt)== +; dom is [op,'_$,n] and MEMQ(op,'(ELT QREFELT)) => nil +; domargsglobal(dom) => +; $functorLocalParameters:= [:$functorLocalParameters,dom] +; PUSH([dom,GENVAR(),[elt,$selector,$funcLocLen]],$usedDomList) +; $selcount:= $selcount+1 +; $funcLocLen:= $funcLocLen+1 +; nil +; where +; domargsglobal(dom) == +; dom='_$ => true +; IDENTP dom => MEMQ(dom,$functorLocalParameters) +; ATOM dom => true +; and/[domargsglobal(arg) for arg in rest dom] + +(DEFUN |canCacheLocalDomain,domargsglobal| (|dom|) + (PROG () + (RETURN + (SEQ (IF (BOOT-EQUAL |dom| '$) (EXIT 'T)) + (IF (IDENTP |dom|) + (EXIT (MEMQ |dom| |$functorLocalParameters|))) + (IF (ATOM |dom|) (EXIT 'T)) + (EXIT (PROG (G168996) + (SPADLET G168996 'T) + (RETURN + (DO ((G169002 NIL (NULL G168996)) + (G169003 (CDR |dom|) (CDR G169003)) + (|arg| NIL)) + ((OR G169002 (ATOM G169003) + (PROGN (SETQ |arg| (CAR G169003)) NIL)) + G168996) + (SEQ (EXIT (SETQ G168996 + (AND G168996 + (|canCacheLocalDomain,domargsglobal| + |arg|))))))))))))) + +(DEFUN |canCacheLocalDomain| (|dom| |elt|) + (PROG (|op| |ISTMP#1| |ISTMP#2| |n|) + (RETURN + (COND + ((AND (PAIRP |dom|) + (PROGN + (SPADLET |op| (QCAR |dom|)) + (SPADLET |ISTMP#1| (QCDR |dom|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) '$) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |n| (QCAR |ISTMP#2|)) 'T))))) + (MEMQ |op| '(ELT QREFELT))) + NIL) + ((|canCacheLocalDomain,domargsglobal| |dom|) + (SPADLET |$functorLocalParameters| + (APPEND |$functorLocalParameters| (CONS |dom| NIL))) + (PUSH (CONS |dom| + (CONS (GENVAR) + (CONS (CONS |elt| + (CONS |$selector| + (CONS |$funcLocLen| NIL))) + NIL))) + |$usedDomList|) + (SPADLET |$selcount| (PLUS |$selcount| 1)) + (SPADLET |$funcLocLen| (PLUS |$funcLocLen| 1))) + ('T NIL))))) + +;compileCases(x,$e) == -- $e is referenced in compile +; $specialCaseKeyList: local := nil +; not ($insideFunctorIfTrue=true) => compile x +; specialCaseAssoc:= +; [y for y in getSpecialCaseAssoc() | not get(first y,"specialCase",$e) and +; ([R,R']:= y) and isEltArgumentIn(FindNamesFor(R,R'),x)] where +; FindNamesFor(R,R') == +; [R,: +; [v +; for ['LET,v,u,:.] in $getDomainCode | CADR u=R and +; eval substitute(R',R,u)]] +; isEltArgumentIn(Rlist,x) == +; atom x => nil +; x is ['ELT,R,.] => MEMQ(R,Rlist) or isEltArgumentIn(Rlist,rest x) +; x is ["QREFELT",R,.] => MEMQ(R,Rlist) or isEltArgumentIn(Rlist,rest x) +; isEltArgumentIn(Rlist,first x) or isEltArgumentIn(Rlist,rest x) +; null specialCaseAssoc => compile x +; listOfDomains:= ASSOCLEFT specialCaseAssoc +; listOfAllCases:= outerProduct ASSOCRIGHT specialCaseAssoc +; cl:= +; [u for l in listOfAllCases] where +; u() == +; $specialCaseKeyList:= [[D,:C] for D in listOfDomains for C in l] +; [MKPF([["EQUAL",D,C] for D in listOfDomains for C in l],"AND"), +; compile COPY x] +; $specialCaseKeyList:= nil +; ["COND",:cl,[$true,compile x]] + +(DEFUN |compileCases,isEltArgumentIn| (|Rlist| |x|) + (PROG (|ISTMP#1| R |ISTMP#2|) + (RETURN + (SEQ (IF (ATOM |x|) (EXIT NIL)) + (IF (AND (PAIRP |x|) (EQ (QCAR |x|) 'ELT) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET R (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL)))))) + (EXIT (OR (MEMQ R |Rlist|) + (|compileCases,isEltArgumentIn| |Rlist| + (CDR |x|))))) + (IF (AND (PAIRP |x|) (EQ (QCAR |x|) 'QREFELT) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET R (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL)))))) + (EXIT (OR (MEMQ R |Rlist|) + (|compileCases,isEltArgumentIn| |Rlist| + (CDR |x|))))) + (EXIT (OR (|compileCases,isEltArgumentIn| |Rlist| (CAR |x|)) + (|compileCases,isEltArgumentIn| |Rlist| (CDR |x|)))))))) + +(DEFUN |compileCases,FindNamesFor| (R |R'|) + (PROG (|v| |u|) + (RETURN + (SEQ (CONS R + (PROG (G169091) + (SPADLET G169091 NIL) + (RETURN + (DO ((G169098 |$getDomainCode| (CDR G169098)) + (G169051 NIL)) + ((OR (ATOM G169098) + (PROGN + (SETQ G169051 (CAR G169098)) + NIL) + (PROGN + (PROGN + (SPADLET |v| (CADR G169051)) + (SPADLET |u| (CADDR G169051)) + G169051) + NIL)) + (NREVERSE0 G169091)) + (SEQ (EXIT (COND + ((AND (BOOT-EQUAL (CADR |u|) R) + (|eval| (MSUBST |R'| R |u|))) + (SETQ G169091 + (CONS |v| G169091)))))))))))))) + +(DEFUN |compileCases| (|x| |$e|) + (DECLARE (SPECIAL |$e|)) + (PROG (|$specialCaseKeyList| R |R'| |specialCaseAssoc| + |listOfDomains| |listOfAllCases| |cl|) + (DECLARE (SPECIAL |$specialCaseKeyList|)) + (RETURN + (SEQ (PROGN + (SPADLET |$specialCaseKeyList| NIL) + (COND + ((NULL (BOOT-EQUAL |$insideFunctorIfTrue| 'T)) + (|compile| |x|)) + ('T + (SPADLET |specialCaseAssoc| + (PROG (G169126) + (SPADLET G169126 NIL) + (RETURN + (DO ((G169132 (|getSpecialCaseAssoc|) + (CDR G169132)) + (|y| NIL)) + ((OR (ATOM G169132) + (PROGN + (SETQ |y| (CAR G169132)) + NIL)) + (NREVERSE0 G169126)) + (SEQ (EXIT + (COND + ((AND + (NULL + (|get| (CAR |y|) + '|specialCase| |$e|)) + (PROGN + (SPADLET R (CAR |y|)) + (SPADLET |R'| (CADR |y|)) + |y|) + (|compileCases,isEltArgumentIn| + (|compileCases,FindNamesFor| + R |R'|) + |x|)) + (SETQ G169126 + (CONS |y| G169126)))))))))) + (COND + ((NULL |specialCaseAssoc|) (|compile| |x|)) + ('T + (SPADLET |listOfDomains| + (ASSOCLEFT |specialCaseAssoc|)) + (SPADLET |listOfAllCases| + (|outerProduct| + (ASSOCRIGHT |specialCaseAssoc|))) + (SPADLET |cl| + (PROG (G169144) + (SPADLET G169144 NIL) + (RETURN + (DO ((G169151 |listOfAllCases| + (CDR G169151)) + (|l| NIL)) + ((OR (ATOM G169151) + (PROGN + (SETQ |l| (CAR G169151)) + NIL)) + (NREVERSE0 G169144)) + (SEQ (EXIT + (SETQ G169144 + (CONS + (PROGN + (SPADLET + |$specialCaseKeyList| + (PROG (G169162) + (SPADLET G169162 NIL) + (RETURN + (DO + ((G169168 + |listOfDomains| + (CDR G169168)) + (D NIL) + (G169169 |l| + (CDR G169169)) + (C NIL)) + ((OR (ATOM G169168) + (PROGN + (SETQ D + (CAR G169168)) + NIL) + (ATOM G169169) + (PROGN + (SETQ C + (CAR G169169)) + NIL)) + (NREVERSE0 + G169162)) + (SEQ + (EXIT + (SETQ G169162 + (CONS (CONS D C) + G169162)))))))) + (CONS + (MKPF + (PROG (G169183) + (SPADLET G169183 NIL) + (RETURN + (DO + ((G169189 + |listOfDomains| + (CDR G169189)) + (D NIL) + (G169190 |l| + (CDR G169190)) + (C NIL)) + ((OR + (ATOM G169189) + (PROGN + (SETQ D + (CAR G169189)) + NIL) + (ATOM G169190) + (PROGN + (SETQ C + (CAR G169190)) + NIL)) + (NREVERSE0 + G169183)) + (SEQ + (EXIT + (SETQ G169183 + (CONS + (CONS 'EQUAL + (CONS D + (CONS C NIL))) + G169183))))))) + 'AND) + (CONS + (|compile| (COPY |x|)) + NIL))) + G169144)))))))) + (SPADLET |$specialCaseKeyList| NIL) + (CONS 'COND + (APPEND |cl| + (CONS (CONS |$true| + (CONS (|compile| |x|) NIL)) + NIL)))))))))))) + +;getSpecialCaseAssoc() == +; [[R,:l] for R in rest $functorForm +; for l in rest $functorSpecialCases | l] + +(DEFUN |getSpecialCaseAssoc| () + (PROG () + (RETURN + (SEQ (PROG (G169224) + (SPADLET G169224 NIL) + (RETURN + (DO ((G169231 (CDR |$functorForm|) (CDR G169231)) + (R NIL) + (G169232 (CDR |$functorSpecialCases|) + (CDR G169232)) + (|l| NIL)) + ((OR (ATOM G169231) + (PROGN (SETQ R (CAR G169231)) NIL) + (ATOM G169232) + (PROGN (SETQ |l| (CAR G169232)) NIL)) + (NREVERSE0 G169224)) + (SEQ (EXIT (COND + (|l| (SETQ G169224 + (CONS (CONS R |l|) G169224))))))))))))) + +;compile u == +; [op,lamExpr] := u +; if $suffix then +; $suffix:= $suffix+1 +; op':= +; opexport:=nil +; opmodes:= +; [sel +; for [[DC,:sig],[.,sel]] in get(op,'modemap,$e) | +; DC='_$ and (opexport:=true) and +; (and/[modeEqual(x,y) for x in sig for y in $signatureOfForm])] +; isLocalFunction op => +; if opexport then userError ['%b,op,'%d,'" is local and exported"] +; INTERN STRCONC(encodeItem $prefix,'";",encodeItem op) where +; isLocalFunction op == +; null MEMBER(op,$formalArgList) and +; getmode(op,$e) is ['Mapping,:.] +; isPackageFunction() and KAR $functorForm^="CategoryDefaults" => +; if null opmodes then userError ['"no modemap for ",op] +; opmodes is [['PAC,.,name]] => name +; encodeFunctionName(op,$functorForm,$signatureOfForm,";",$suffix) +; encodeFunctionName(op,$functorForm,$signatureOfForm,";",$suffix) +; u:= [op',lamExpr] +; -- If just updating certain functions, check for previous existence. +; -- Deduce old sequence number and use it (items have been skipped). +; if $LISPLIB and $compileOnlyCertainItems then +; parts := splitEncodedFunctionName(u.0, ";") +;-- Next line JHD/SMWATT 7/17/86 to deal with inner functions +; parts='inner => $savableItems:=[u.0,:$savableItems] +; unew := nil +; for [s,t] in $splitUpItemsAlreadyThere repeat +; if parts.0=s.0 and parts.1=s.1 and parts.2=s.2 then unew := t +; null unew => +; sayBrightly ['" Error: Item did not previously exist"] +; sayBrightly ['" Item not saved: ", :bright u.0] +; sayBrightly ['" What's there is: ", $lisplibItemsAlreadyThere] +; nil +; sayBrightly ['" Renaming ", u.0, '" as ", unew] +; u := [unew, :rest u] +; $savableItems := [unew, :$saveableItems] -- tested by embedded RWRITE +; optimizedBody:= optimizeFunctionDef u +; stuffToCompile:= +; if null $insideCapsuleFunctionIfTrue +; then optimizedBody +; else putInLocalDomainReferences optimizedBody +; $doNotCompileJustPrint=true => (PRETTYPRINT stuffToCompile; op') +; $macroIfTrue => constructMacro stuffToCompile +; result:= spadCompileOrSetq stuffToCompile +; functionStats:=[0,elapsedTime()] +; $functionStats:= addStats($functionStats,functionStats) +; printStats functionStats +; result + +(DEFUN |compile,isLocalFunction| (|op|) + (PROG (|ISTMP#1|) + (RETURN + (AND (NULL (|member| |op| |$formalArgList|)) + (PROGN + (SPADLET |ISTMP#1| (|getmode| |op| |$e|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) '|Mapping|))))))) + +(DEFUN |compile| (|u|) + (PROG (|op| |lamExpr| DC |sig| |sel| |opexport| |opmodes| |ISTMP#1| + |ISTMP#2| |ISTMP#3| |name| |op'| |parts| |s| |t| |unew| + |optimizedBody| |stuffToCompile| |result| + |functionStats|) + (RETURN + (SEQ (PROGN + (SPADLET |op| (CAR |u|)) + (SPADLET |lamExpr| (CADR |u|)) + (COND + (|$suffix| (SPADLET |$suffix| (PLUS |$suffix| 1)) + (SPADLET |op'| + (PROGN + (SPADLET |opexport| NIL) + (SPADLET |opmodes| + (PROG (G169296) + (SPADLET G169296 NIL) + (RETURN + (DO + ((G169303 + (|get| |op| '|modemap| + |$e|) + (CDR G169303)) + (G169248 NIL)) + ((OR (ATOM G169303) + (PROGN + (SETQ G169248 + (CAR G169303)) + NIL) + (PROGN + (PROGN + (SPADLET DC + (CAAR G169248)) + (SPADLET |sig| + (CDAR G169248)) + (SPADLET |sel| + (CADADR G169248)) + G169248) + NIL)) + (NREVERSE0 G169296)) + (SEQ + (EXIT + (COND + ((AND + (BOOT-EQUAL DC '$) + (SPADLET |opexport| + 'T) + (PROG (G169310) + (SPADLET G169310 + 'T) + (RETURN + (DO + ((G169317 NIL + (NULL + G169310)) + (G169318 + |sig| + (CDR + G169318)) + (|x| NIL) + (G169319 + |$signatureOfForm| + (CDR + G169319)) + (|y| NIL)) + ((OR G169317 + (ATOM + G169318) + (PROGN + (SETQ |x| + (CAR + G169318)) + NIL) + (ATOM + G169319) + (PROGN + (SETQ |y| + (CAR + G169319)) + NIL)) + G169310) + (SEQ + (EXIT + (SETQ + G169310 + (AND + G169310 + (|modeEqual| + |x| |y|))))))))) + (SETQ G169296 + (CONS |sel| + G169296)))))))))) + (COND + ((|compile,isLocalFunction| |op|) + (COND + (|opexport| + (|userError| + (CONS '|%b| + (CONS |op| + (CONS '|%d| + (CONS + (MAKESTRING + " is local and exported") + NIL))))))) + (INTERN (STRCONC + (|encodeItem| |$prefix|) + (MAKESTRING ";") + (|encodeItem| |op|)))) + ((AND (|isPackageFunction|) + (NEQUAL (KAR |$functorForm|) + '|CategoryDefaults|)) + (COND + ((NULL |opmodes|) + (|userError| + (CONS + (MAKESTRING "no modemap for ") + (CONS |op| NIL))))) + (COND + ((AND (PAIRP |opmodes|) + (EQ (QCDR |opmodes|) NIL) + (PROGN + (SPADLET |ISTMP#1| + (QCAR |opmodes|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) 'PAC) + (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 |name| + (QCAR |ISTMP#3|)) + 'T)))))))) + |name|) + ('T + (|encodeFunctionName| |op| + |$functorForm| |$signatureOfForm| + '|;| |$suffix|)))) + ('T + (|encodeFunctionName| |op| + |$functorForm| |$signatureOfForm| + '|;| |$suffix|))))) + (SPADLET |u| (CONS |op'| (CONS |lamExpr| NIL))))) + (COND + ((AND $LISPLIB |$compileOnlyCertainItems|) + (SPADLET |parts| + (|splitEncodedFunctionName| (ELT |u| 0) '|;|)) + (COND + ((BOOT-EQUAL |parts| '|inner|) + (SPADLET |$savableItems| + (CONS (ELT |u| 0) |$savableItems|))) + ('T (SPADLET |unew| NIL) + (DO ((G169333 |$splitUpItemsAlreadyThere| + (CDR G169333)) + (G169282 NIL)) + ((OR (ATOM G169333) + (PROGN + (SETQ G169282 (CAR G169333)) + NIL) + (PROGN + (PROGN + (SPADLET |s| (CAR G169282)) + (SPADLET |t| (CADR G169282)) + G169282) + NIL)) + NIL) + (SEQ (EXIT (COND + ((AND + (BOOT-EQUAL (ELT |parts| 0) + (ELT |s| 0)) + (BOOT-EQUAL (ELT |parts| 1) + (ELT |s| 1)) + (BOOT-EQUAL (ELT |parts| 2) + (ELT |s| 2))) + (SPADLET |unew| |t|)) + ('T NIL))))) + (COND + ((NULL |unew|) + (|sayBrightly| + (CONS (MAKESTRING + " Error: Item did not previously exist") + NIL)) + (|sayBrightly| + (CONS (MAKESTRING " Item not saved: ") + (|bright| (ELT |u| 0)))) + (|sayBrightly| + (CONS (MAKESTRING " What's there is: ") + (CONS |$lisplibItemsAlreadyThere| NIL))) + NIL) + ('T + (|sayBrightly| + (CONS (MAKESTRING " Renaming ") + (CONS (ELT |u| 0) + (CONS (MAKESTRING " as ") + (CONS |unew| NIL))))) + (SPADLET |u| (CONS |unew| (CDR |u|))) + (SPADLET |$savableItems| + (CONS |unew| |$saveableItems|)))))))) + (SPADLET |optimizedBody| (|optimizeFunctionDef| |u|)) + (SPADLET |stuffToCompile| + (COND + ((NULL |$insideCapsuleFunctionIfTrue|) + |optimizedBody|) + ('T + (|putInLocalDomainReferences| |optimizedBody|)))) + (COND + ((BOOT-EQUAL |$doNotCompileJustPrint| 'T) + (PRETTYPRINT |stuffToCompile|) |op'|) + (|$macroIfTrue| (|constructMacro| |stuffToCompile|)) + ('T + (SPADLET |result| + (|spadCompileOrSetq| |stuffToCompile|)) + (SPADLET |functionStats| + (CONS 0 (CONS (|elapsedTime|) NIL))) + (SPADLET |$functionStats| + (|addStats| |$functionStats| |functionStats|)) + (|printStats| |functionStats|) |result|))))))) + +;spadCompileOrSetq (form is [nam,[lam,vl,body]]) == +; --bizarre hack to take account of the existence of "known" functions +; --good for performance (LISPLLIB size, BPI size, NILSEC) +; CONTAINED(" ",body) => sayBrightly ['" ",:bright nam,'" not compiled"] +; if vl is [:vl',E] and body is [nam',: =vl'] then +; LAM_,EVALANDFILEACTQ ['PUT,MKQ nam,MKQ 'SPADreplace,MKQ nam'] +; sayBrightly ['" ",:bright nam,'"is replaced by",:bright nam'] +; else if (ATOM body or and/[ATOM x for x in body]) +; and vl is [:vl',E] and not CONTAINED(E,body) then +; macform := ['XLAM,vl',body] +; LAM_,EVALANDFILEACTQ ['PUT,MKQ nam,MKQ 'SPADreplace,MKQ macform] +; sayBrightly ['" ",:bright nam,'"is replaced by",:bright body] +; $insideCapsuleFunctionIfTrue => first COMP LIST form +; compileConstructor form + +(DEFUN |spadCompileOrSetq| (|form|) + (PROG (|nam| |lam| |vl| |body| |nam'| |ISTMP#1| E |vl'| |macform|) + (RETURN + (SEQ (PROGN + (SPADLET |nam| (CAR |form|)) + (SPADLET |lam| (CAADR |form|)) + (SPADLET |vl| (CADADR |form|)) + (SPADLET |body| (CAR (CDDADR |form|))) + (COND + ((CONTAINED (INTERN " " "BOOT") |body|) + (|sayBrightly| + (CONS (MAKESTRING " ") + (APPEND (|bright| |nam|) + (CONS (MAKESTRING " not compiled") + NIL))))) + ('T + (COND + ((AND (PAIRP |vl|) + (PROGN (SPADLET |ISTMP#1| (REVERSE |vl|)) 'T) + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET E (QCAR |ISTMP#1|)) + (SPADLET |vl'| (QCDR |ISTMP#1|)) + 'T) + (PROGN (SPADLET |vl'| (NREVERSE |vl'|)) 'T) + (PAIRP |body|) + (PROGN (SPADLET |nam'| (QCAR |body|)) 'T) + (EQUAL (QCDR |body|) |vl'|)) + (|LAM,EVALANDFILEACTQ| + (CONS 'PUT + (CONS (MKQ |nam|) + (CONS (MKQ '|SPADreplace|) + (CONS (MKQ |nam'|) NIL))))) + (|sayBrightly| + (CONS (MAKESTRING " ") + (APPEND (|bright| |nam|) + (CONS + (MAKESTRING "is replaced by") + (|bright| |nam'|)))))) + ((AND (OR (ATOM |body|) + (PROG (G169410) + (SPADLET G169410 'T) + (RETURN + (DO ((G169416 NIL (NULL G169410)) + (G169417 |body| (CDR G169417)) + (|x| NIL)) + ((OR G169416 (ATOM G169417) + (PROGN + (SETQ |x| (CAR G169417)) + NIL)) + G169410) + (SEQ (EXIT + (SETQ G169410 + (AND G169410 (ATOM |x|))))))))) + (PAIRP |vl|) + (PROGN (SPADLET |ISTMP#1| (REVERSE |vl|)) 'T) + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET E (QCAR |ISTMP#1|)) + (SPADLET |vl'| (QCDR |ISTMP#1|)) + 'T) + (PROGN (SPADLET |vl'| (NREVERSE |vl'|)) 'T) + (NULL (CONTAINED E |body|))) + (SPADLET |macform| + (CONS 'XLAM (CONS |vl'| (CONS |body| NIL)))) + (|LAM,EVALANDFILEACTQ| + (CONS 'PUT + (CONS (MKQ |nam|) + (CONS (MKQ '|SPADreplace|) + (CONS (MKQ |macform|) NIL))))) + (|sayBrightly| + (CONS (MAKESTRING " ") + (APPEND (|bright| |nam|) + (CONS + (MAKESTRING "is replaced by") + (|bright| |body|)))))) + ('T NIL)) + (COND + (|$insideCapsuleFunctionIfTrue| + (CAR (COMP (LIST |form|)))) + ('T (|compileConstructor| |form|)))))))))) + +;compileConstructor form == +; u:= compileConstructor1 form +; clearClams() --clear all CLAMmed functions +; u + +(DEFUN |compileConstructor| (|form|) + (PROG (|u|) + (RETURN + (PROGN + (SPADLET |u| (|compileConstructor1| |form|)) + (|clearClams|) + |u|)))) + +;compileConstructor1 (form:=[fn,[key,vl,:bodyl]]) == +;-- fn is the name of some category/domain/package constructor; +;-- we will cache all of its values on $ConstructorCache with reference +;-- counts +; $clamList: local := nil +; lambdaOrSlam := +; GETDATABASE(fn,'CONSTRUCTORKIND) = 'category => 'SPADSLAM +; $mutableDomain => 'LAMBDA +; $clamList:= +; [[fn,"$ConstructorCache",'domainEqualList,'count],:$clamList] +; 'LAMBDA +; compForm:= LIST [fn,[lambdaOrSlam,vl,:bodyl]] +; if GETDATABASE(fn,'CONSTRUCTORKIND) = 'category +; then u:= compAndDefine compForm +; else u:=COMP compForm +; clearConstructorCache fn --clear cache for constructor +; first u + +(DEFUN |compileConstructor1| (|form|) + (PROG (|$clamList| |fn| |key| |vl| |bodyl| |lambdaOrSlam| |compForm| + |u|) + (DECLARE (SPECIAL |$clamList|)) + (RETURN + (PROGN + (SPADLET |fn| (CAR |form|)) + (SPADLET |key| (CAADR |form|)) + (SPADLET |vl| (CADADR |form|)) + (SPADLET |bodyl| (CDDADR |form|)) + (SPADLET |$clamList| NIL) + (SPADLET |lambdaOrSlam| + (COND + ((BOOT-EQUAL (GETDATABASE |fn| 'CONSTRUCTORKIND) + '|category|) + 'SPADSLAM) + (|$mutableDomain| 'LAMBDA) + ('T + (SPADLET |$clamList| + (CONS (CONS |fn| + (CONS '|$ConstructorCache| + (CONS '|domainEqualList| + (CONS '|count| NIL)))) + |$clamList|)) + 'LAMBDA))) + (SPADLET |compForm| + (LIST (CONS |fn| + (CONS (CONS |lambdaOrSlam| + (CONS |vl| |bodyl|)) + NIL)))) + (COND + ((BOOT-EQUAL (GETDATABASE |fn| 'CONSTRUCTORKIND) '|category|) + (SPADLET |u| (|compAndDefine| |compForm|))) + ('T (SPADLET |u| (COMP |compForm|)))) + (|clearConstructorCache| |fn|) + (CAR |u|))))) + +;constructMacro (form is [nam,[lam,vl,body]]) == +; ^(and/[atom x for x in vl]) => +; stackSemanticError(["illegal parameters for macro: ",vl],nil) +; ["XLAM",vl':= [x for x in vl | IDENTP x],body] + +(DEFUN |constructMacro| (|form|) + (PROG (|nam| |lam| |vl| |body| |vl'|) + (RETURN + (SEQ (PROGN + (SPADLET |nam| (CAR |form|)) + (SPADLET |lam| (CAADR |form|)) + (SPADLET |vl| (CADADR |form|)) + (SPADLET |body| (CAR (CDDADR |form|))) + (COND + ((NULL (PROG (G169489) + (SPADLET G169489 'T) + (RETURN + (DO ((G169495 NIL (NULL G169489)) + (G169496 |vl| (CDR G169496)) + (|x| NIL)) + ((OR G169495 (ATOM G169496) + (PROGN + (SETQ |x| (CAR G169496)) + NIL)) + G169489) + (SEQ (EXIT (SETQ G169489 + (AND G169489 (ATOM |x|))))))))) + (|stackSemanticError| + (CONS '|illegal parameters for macro: | + (CONS |vl| NIL)) + NIL)) + ('T + (CONS 'XLAM + (CONS (SPADLET |vl'| + (PROG (G169508) + (SPADLET G169508 NIL) + (RETURN + (DO + ((G169514 |vl| + (CDR G169514)) + (|x| NIL)) + ((OR (ATOM G169514) + (PROGN + (SETQ |x| + (CAR G169514)) + NIL)) + (NREVERSE0 G169508)) + (SEQ + (EXIT + (COND + ((IDENTP |x|) + (SETQ G169508 + (CONS |x| G169508)))))))))) + (CONS |body| NIL)))))))))) + +;listInitialSegment(u,v) == +; null u => true +; null v => nil +; first u=first v and listInitialSegment(rest u,rest v) + +(DEFUN |listInitialSegment| (|u| |v|) + (COND + ((NULL |u|) 'T) + ((NULL |v|) NIL) + ('T + (AND (BOOT-EQUAL (CAR |u|) (CAR |v|)) + (|listInitialSegment| (CDR |u|) (CDR |v|)))))) + +; --returns true iff u.i=v.i for i in 1..(#u)-1 +; +;modemap2Signature [[.,:sig],:.] == sig + +(DEFUN |modemap2Signature| (G169534) + (PROG (|sig|) + (RETURN (PROGN (SPADLET |sig| (CDAR G169534)) |sig|)))) + +;uncons x == +; atom x => x +; x is ["CONS",a,b] => [a,:uncons b] + +(DEFUN |uncons| (|x|) + (PROG (|ISTMP#1| |a| |ISTMP#2| |b|) + (RETURN + (COND + ((ATOM |x|) |x|) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'CONS) + (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 |b| (QCAR |ISTMP#2|)) 'T)))))) + (CONS |a| (|uncons| |b|))))))) + +;--% CAPSULE +; +;bootStrapError(functorForm,sourceFile) == +; ['COND, _ +; ['$bootStrapMode, _ +; ['VECTOR,mkDomainConstructor functorForm,nil,nil,nil,nil,nil]], +; [''T, ['systemError,['LIST,''%b,MKQ CAR functorForm,''%d,'"from", _ +; ''%b,MKQ namestring sourceFile,''%d,'"needs to be compiled"]]]] + +(DEFUN |bootStrapError| (|functorForm| |sourceFile|) + (CONS 'COND + (CONS (CONS '|$bootStrapMode| + (CONS (CONS 'VECTOR + (CONS (|mkDomainConstructor| + |functorForm|) + (CONS NIL + (CONS NIL + (CONS NIL + (CONS NIL (CONS NIL NIL))))))) + NIL)) + (CONS (CONS ''T + (CONS (CONS '|systemError| + (CONS + (CONS 'LIST + (CONS ''|%b| + (CONS + (MKQ (CAR |functorForm|)) + (CONS ''|%d| + (CONS (MAKESTRING "from") + (CONS ''|%b| + (CONS + (MKQ + (|namestring| + |sourceFile|)) + (CONS ''|%d| + (CONS + (MAKESTRING + "needs to be compiled") + NIL))))))))) + NIL)) + NIL)) + NIL)))) + +;compAdd(['add,$addForm,capsule],m,e) == +; $bootStrapMode = true => +; if $addForm is ['Tuple,:.] then code := nil +; else [code,m,e]:= comp($addForm,m,e) +; [['COND, _ +; ['$bootStrapMode, _ +; code],_ +; [''T, ['systemError,['LIST,''%b,MKQ CAR $functorForm,''%d,'"from", _ +; ''%b,MKQ namestring _/EDITFILE,''%d,'"needs to be compiled"]]]],m,e] +; $addFormLhs: local:= $addForm +; if $addForm is ["SubDomain",domainForm,predicate] then +; $packagesUsed := [domainForm,:$packagesUsed] +;--+ +; $NRTaddForm := domainForm +; NRTgetLocalIndex domainForm +; --need to generate slot for add form since all $ go-get +; -- slots will need to access it +; [$addForm,.,e]:= compSubDomain1(domainForm,predicate,m,e) +; else +; $packagesUsed := +; $addForm is ['Tuple,:u] => [:u,:$packagesUsed] +; [$addForm,:$packagesUsed] +;--+ +; $NRTaddForm := $addForm +; [$addForm,.,e]:= +; $addForm is ['Tuple,:.] => +; $NRTaddForm := ['Tuple,:[NRTgetLocalIndex x for x in rest $addForm]] +; compOrCroak(compTuple2Record $addForm,$EmptyMode,e) +; compOrCroak($addForm,$EmptyMode,e) +; compCapsule(capsule,m,e) + +(DEFUN |compAdd| (G169618 |m| |e|) + (PROG (|$addForm| |$addFormLhs| |capsule| |code| |ISTMP#1| + |domainForm| |ISTMP#2| |predicate| |u| |LETTMP#1|) + (DECLARE (SPECIAL |$addForm| |$addFormLhs|)) + (RETURN + (SEQ (PROGN + (SPADLET |$addForm| (CADR G169618)) + (SPADLET |capsule| (CADDR G169618)) + (COND + ((BOOT-EQUAL |$bootStrapMode| 'T) + (COND + ((AND (PAIRP |$addForm|) + (EQ (QCAR |$addForm|) '|Tuple|)) + (SPADLET |code| NIL)) + ('T (SPADLET |LETTMP#1| (|comp| |$addForm| |m| |e|)) + (SPADLET |code| (CAR |LETTMP#1|)) + (SPADLET |m| (CADR |LETTMP#1|)) + (SPADLET |e| (CADDR |LETTMP#1|)) |LETTMP#1|)) + (CONS (CONS 'COND + (CONS (CONS '|$bootStrapMode| + (CONS |code| NIL)) + (CONS (CONS ''T + (CONS + (CONS '|systemError| + (CONS + (CONS 'LIST + (CONS ''|%b| + (CONS + (MKQ + (CAR |$functorForm|)) + (CONS ''|%d| + (CONS + (MAKESTRING "from") + (CONS ''|%b| + (CONS + (MKQ + (|namestring| + /EDITFILE)) + (CONS ''|%d| + (CONS + (MAKESTRING + "needs to be compiled") + NIL))))))))) + NIL)) + NIL)) + NIL))) + (CONS |m| (CONS |e| NIL)))) + ('T (SPADLET |$addFormLhs| |$addForm|) + (COND + ((AND (PAIRP |$addForm|) + (EQ (QCAR |$addForm|) '|SubDomain|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |$addForm|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |domainForm| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |predicate| + (QCAR |ISTMP#2|)) + 'T)))))) + (SPADLET |$packagesUsed| + (CONS |domainForm| |$packagesUsed|)) + (SPADLET |$NRTaddForm| |domainForm|) + (|NRTgetLocalIndex| |domainForm|) + (SPADLET |LETTMP#1| + (|compSubDomain1| |domainForm| |predicate| + |m| |e|)) + (SPADLET |$addForm| (CAR |LETTMP#1|)) + (SPADLET |e| (CADDR |LETTMP#1|)) |LETTMP#1|) + ('T + (SPADLET |$packagesUsed| + (COND + ((AND (PAIRP |$addForm|) + (EQ (QCAR |$addForm|) '|Tuple|) + (PROGN + (SPADLET |u| (QCDR |$addForm|)) + 'T)) + (APPEND |u| |$packagesUsed|)) + ('T (CONS |$addForm| |$packagesUsed|)))) + (SPADLET |$NRTaddForm| |$addForm|) + (SPADLET |LETTMP#1| + (COND + ((AND (PAIRP |$addForm|) + (EQ (QCAR |$addForm|) '|Tuple|)) + (SPADLET |$NRTaddForm| + (CONS '|Tuple| + (PROG (G169653) + (SPADLET G169653 NIL) + (RETURN + (DO + ((G169658 + (CDR |$addForm|) + (CDR G169658)) + (|x| NIL)) + ((OR (ATOM G169658) + (PROGN + (SETQ |x| + (CAR G169658)) + NIL)) + (NREVERSE0 G169653)) + (SEQ + (EXIT + (SETQ G169653 + (CONS + (|NRTgetLocalIndex| + |x|) + G169653))))))))) + (|compOrCroak| + (|compTuple2Record| |$addForm|) + |$EmptyMode| |e|)) + ('T + (|compOrCroak| |$addForm| |$EmptyMode| + |e|)))) + (SPADLET |$addForm| (CAR |LETTMP#1|)) + (SPADLET |e| (CADDR |LETTMP#1|)) |LETTMP#1|)) + (|compCapsule| |capsule| |m| |e|)))))))) + +;compTuple2Record u == ['Record,:[[":",i,x] for i in 1.. for x in rest u]] + +(DEFUN |compTuple2Record| (|u|) + (PROG () + (RETURN + (SEQ (CONS '|Record| + (PROG (G169701) + (SPADLET G169701 NIL) + (RETURN + (DO ((|i| 1 (QSADD1 |i|)) + (G169707 (CDR |u|) (CDR G169707)) + (|x| NIL)) + ((OR (ATOM G169707) + (PROGN (SETQ |x| (CAR G169707)) NIL)) + (NREVERSE0 G169701)) + (SEQ (EXIT (SETQ G169701 + (CONS + (CONS '|:| + (CONS |i| (CONS |x| NIL))) + G169701)))))))))))) + +;compCapsule(['CAPSULE,:itemList],m,e) == +; $bootStrapMode = true => +; [bootStrapError($functorForm, _/EDITFILE),m,e] +; $insideExpressionIfTrue: local:= false +; compCapsuleInner(itemList,m,addDomain('_$,e)) + +(DEFUN |compCapsule| (G169718 |m| |e|) + (PROG (|$insideExpressionIfTrue| |itemList|) + (DECLARE (SPECIAL |$insideExpressionIfTrue|)) + (RETURN + (PROGN + (SPADLET |itemList| (CDR G169718)) + (COND + ((BOOT-EQUAL |$bootStrapMode| 'T) + (CONS (|bootStrapError| |$functorForm| /EDITFILE) + (CONS |m| (CONS |e| NIL)))) + ('T (SPADLET |$insideExpressionIfTrue| NIL) + (|compCapsuleInner| |itemList| |m| (|addDomain| '$ |e|)))))))) + +;compSubDomain(["SubDomain",domainForm,predicate],m,e) == +; $addFormLhs: local:= domainForm +; $addForm: local := nil +; $NRTaddForm := domainForm +; [$addForm,.,e]:= compSubDomain1(domainForm,predicate,m,e) +;--+ +; compCapsule(['CAPSULE],m,e) + +(DEFUN |compSubDomain| (G169740 |m| |e|) + (PROG (|$addFormLhs| |$addForm| |domainForm| |predicate| |LETTMP#1|) + (DECLARE (SPECIAL |$addFormLhs| |$addForm|)) + (RETURN + (PROGN + (COND ((EQ (CAR G169740) '|SubDomain|) (CAR G169740))) + (SPADLET |domainForm| (CADR G169740)) + (SPADLET |predicate| (CADDR G169740)) + (SPADLET |$addFormLhs| |domainForm|) + (SPADLET |$addForm| NIL) + (SPADLET |$NRTaddForm| |domainForm|) + (SPADLET |LETTMP#1| + (|compSubDomain1| |domainForm| |predicate| |m| |e|)) + (SPADLET |$addForm| (CAR |LETTMP#1|)) + (SPADLET |e| (CADDR |LETTMP#1|)) + (|compCapsule| (CONS 'CAPSULE NIL) |m| |e|))))) + +;compSubDomain1(domainForm,predicate,m,e) == +; [.,.,e]:= +; compMakeDeclaration([":","#1",domainForm],$EmptyMode,addDomain(domainForm,e)) +; u:= +; compOrCroak(predicate,$Boolean,e) or +; stackSemanticError(["predicate: ",predicate, +; " cannot be interpreted with #1: ",domainForm],nil) +; prefixPredicate:= lispize u.expr +; $lisplibSuperDomain:= +; [domainForm,predicate] +; evalAndRwriteLispForm('evalOnLoad2, +; ['SETQ,'$CategoryFrame,['put,op':= ['QUOTE,$op],' +; (QUOTE SuperDomain),dF':= ['QUOTE,domainForm],['put,dF','(QUOTE SubDomain),[ +; 'CONS,['QUOTE,[$op,:prefixPredicate]],['DELASC,op',['get,dF',' +; (QUOTE SubDomain),'$CategoryFrame]]],'$CategoryFrame]]]) +; [domainForm,m,e] + +(DEFUN |compSubDomain1| (|domainForm| |predicate| |m| |e|) + (PROG (|LETTMP#1| |u| |prefixPredicate| |op'| |dF'|) + (RETURN + (PROGN + (SPADLET |LETTMP#1| + (|compMakeDeclaration| + (CONS '|:| (CONS '|#1| (CONS |domainForm| NIL))) + |$EmptyMode| (|addDomain| |domainForm| |e|))) + (SPADLET |e| (CADDR |LETTMP#1|)) + (SPADLET |u| + (OR (|compOrCroak| |predicate| |$Boolean| |e|) + (|stackSemanticError| + (CONS '|predicate: | + (CONS |predicate| + (CONS + '| cannot be interpreted with #1: | + (CONS |domainForm| NIL)))) + NIL))) + (SPADLET |prefixPredicate| (|lispize| (CAR |u|))) + (SPADLET |$lisplibSuperDomain| + (CONS |domainForm| (CONS |predicate| NIL))) + (|evalAndRwriteLispForm| '|evalOnLoad2| + (CONS 'SETQ + (CONS '|$CategoryFrame| + (CONS (CONS '|put| + (CONS + (SPADLET |op'| + (CONS 'QUOTE (CONS |$op| NIL))) + (CONS ''|SuperDomain| + (CONS + (SPADLET |dF'| + (CONS 'QUOTE + (CONS |domainForm| NIL))) + (CONS + (CONS '|put| + (CONS |dF'| + (CONS ''|SubDomain| + (CONS + (CONS 'CONS + (CONS + (CONS 'QUOTE + (CONS + (CONS |$op| + |prefixPredicate|) + NIL)) + (CONS + (CONS 'DELASC + (CONS |op'| + (CONS + (CONS '|get| + (CONS |dF'| + (CONS ''|SubDomain| + (CONS + '|$CategoryFrame| + NIL)))) + NIL))) + NIL))) + (CONS '|$CategoryFrame| + NIL))))) + NIL))))) + NIL)))) + (CONS |domainForm| (CONS |m| (CONS |e| NIL))))))) + +;compCapsuleInner(itemList,m,e) == +; e:= addInformation(m,e) +; --puts a new 'special' property of $Information +; data:= ["PROGN",:itemList] +; --RPLACd by compCapsuleItems and Friends +; e:= compCapsuleItems(itemList,nil,e) +; localParList:= $functorLocalParameters +; if $addForm then data:= ['add,$addForm,data] +; code:= +; $insideCategoryIfTrue and not $insideCategoryPackageIfTrue => data +; processFunctorOrPackage($form,$signature,data,localParList,m,e) +; [MKPF([:$getDomainCode,code],"PROGN"),m,e] + +(DEFUN |compCapsuleInner| (|itemList| |m| |e|) + (PROG (|localParList| |data| |code|) + (RETURN + (PROGN + (SPADLET |e| (|addInformation| |m| |e|)) + (SPADLET |data| (CONS 'PROGN |itemList|)) + (SPADLET |e| (|compCapsuleItems| |itemList| NIL |e|)) + (SPADLET |localParList| |$functorLocalParameters|) + (COND + (|$addForm| + (SPADLET |data| + (CONS '|add| + (CONS |$addForm| (CONS |data| NIL)))))) + (SPADLET |code| + (COND + ((AND |$insideCategoryIfTrue| + (NULL |$insideCategoryPackageIfTrue|)) + |data|) + ('T + (|processFunctorOrPackage| |$form| |$signature| + |data| |localParList| |m| |e|)))) + (CONS (MKPF (APPEND |$getDomainCode| (CONS |code| NIL)) 'PROGN) + (CONS |m| (CONS |e| NIL))))))) + +;--% PROCESS FUNCTOR CODE +; +;processFunctor(form,signature,data,localParList,e) == +; form is ["CategoryDefaults"] => +; error "CategoryDefaults is a reserved name" +; buildFunctor(form,signature,data,localParList,e) + +(DEFUN |processFunctor| (|form| |signature| |data| |localParList| |e|) + (COND + ((AND (PAIRP |form|) (EQ (QCDR |form|) NIL) + (EQ (QCAR |form|) '|CategoryDefaults|)) + (|error| '|CategoryDefaults is a reserved name|)) + ('T (|buildFunctor| |form| |signature| |data| |localParList| |e|)))) + +@ +\section{compCapsuleItems} +The variable [[data]] appears to be unbound at runtime. Optimized +code won't check for this but interpreted code fails. We should +PROVE that data is unbound at runtime but have not done so yet. +Rather than remove the code entirely (since there MIGHT be a +path where it is used) we check for the runtime bound case and +assign [[$myFunctorBody]] if data has a value. + +The [[compCapsuleInner]] function in this file LOOKS like it sets +data and expects code to manipulate the assigned data structure. +Since we can't be sure we take the least disruptive course of action. + +<<*>>= +;compCapsuleItems(itemlist,$predl,$e) == +; $TOP__LEVEL: local := nil +; $myFunctorBody :local -- := data ---needed for translator +; if (BOUNDP 'data) then $myFunctorBody:=data -- unbound at runtime? +; $signatureOfForm: local := nil +; $suffix: local:= 0 +; for item in itemlist repeat $e:= compSingleCapsuleItem(item,$predl,$e) +; $e + +(DEFUN |compCapsuleItems| (|itemlist| |$predl| |$e|) + (DECLARE (SPECIAL |$predl| |$e|)) + (PROG ($TOP_LEVEL |$myFunctorBody| |$signatureOfForm| |$suffix|) + (DECLARE (SPECIAL $TOP_LEVEL |$myFunctorBody| |$signatureOfForm| + |$suffix|)) + (RETURN + (SEQ (PROGN + (SPADLET $TOP_LEVEL NIL) + (SPADLET |$myFunctorBody| NIL) + (COND + ((BOUNDP '|data|) (SPADLET |$myFunctorBody| |data|))) + (SPADLET |$signatureOfForm| NIL) + (SPADLET |$suffix| 0) + (DO ((G169805 |itemlist| (CDR G169805)) (|item| NIL)) + ((OR (ATOM G169805) + (PROGN (SETQ |item| (CAR G169805)) NIL)) + NIL) + (SEQ (EXIT (SPADLET |$e| + (|compSingleCapsuleItem| |item| + |$predl| |$e|))))) + |$e|))))) + +;compSingleCapsuleItem(item,$predl,$e) == +; doIt(macroExpandInPlace(item,$e),$predl) +; $e + +(DEFUN |compSingleCapsuleItem| (|item| |$predl| |$e|) + (DECLARE (SPECIAL |$predl| |$e|)) + (PROGN (|doIt| (|macroExpandInPlace| |item| |$e|) |$predl|) |$e|)) + +;doIt(item,$predl) == +; $GENNO: local:= 0 +; item is ['SEQ,:l,['exit,1,x]] => +; RPLACA(item,"PROGN") +; RPLACA(LASTNODE item,x) +; for it1 in rest item repeat $e:= compSingleCapsuleItem(it1,$predl,$e) +; --This will RPLAC as appropriate +; isDomainForm(item,$e) => +; -- convert naked top level domains to import +; u:= ['import, [first item,:rest item]] +; stackWarning ["Use: import ", [first item,:rest item]] +; RPLACA(item,first u) +; RPLACD(item,rest u) +; doIt(item,$predl) +; item is ['LET,lhs,rhs,:.] => +; not (compOrCroak(item,$EmptyMode,$e) is [code,.,$e]) => +; stackSemanticError(["cannot compile assigned value to",:bright lhs],nil) +; not (code is ['LET,lhs',rhs',:.] and atom lhs') => +; code is ["PROGN",:.] => +; stackSemanticError(["multiple assignment ",item," not allowed"],nil) +; RPLACA(item,first code) +; RPLACD(item,rest code) +; lhs:= lhs' +; if not MEMBER(KAR rhs,$NonMentionableDomainNames) and +; not MEMQ(lhs, $functorLocalParameters) then +; $functorLocalParameters:= [:$functorLocalParameters,lhs] +; if code is ['LET,.,rhs',:.] and isDomainForm(rhs',$e) then +; if isFunctor rhs' then +; $functorsUsed:= insert(opOf rhs',$functorsUsed) +; $packagesUsed:= insert([opOf rhs'],$packagesUsed) +; if lhs="Rep" then +; $Representation:= (get("Rep",'value,$e)).(0) +; --$Representation bound by compDefineFunctor, used in compNoStacking +;--+ +; if $NRTopt = true +; then NRTgetLocalIndex $Representation +;--+ +; $LocalDomainAlist:= --see genDeltaEntry +; [[lhs,:SUBLIS($LocalDomainAlist,get(lhs,'value,$e).0)],:$LocalDomainAlist] +;--+ +; code is ['LET,:.] => +; RPLACA(item,($QuickCode => 'QSETREFV;'SETELT)) +; rhsCode:= +; rhs' +; RPLACD(item,['$,NRTgetLocalIndexClear lhs,rhsCode]) +; RPLACA(item,first code) +; RPLACD(item,rest code) +; item is [":",a,t] => [.,.,$e]:= compOrCroak(item,$EmptyMode,$e) +; item is ['import,:doms] => +; for dom in doms repeat +; sayBrightly ['" importing ",:formatUnabbreviated dom] +; [.,.,$e] := compOrCroak(item,$EmptyMode,$e) +; RPLACA(item,'PROGN) +; RPLACD(item,NIL) -- creates a no-op +; item is ["IF",:.] => doItIf(item,$predl,$e) +; item is ["where",b,:l] => compOrCroak(item,$EmptyMode,$e) +; item is ["MDEF",:.] => [.,.,$e]:= compOrCroak(item,$EmptyMode,$e) +; item is ['DEF,[op,:.],:.] => +; body:= isMacro(item,$e) => $e:= put(op,'macro,body,$e) +; [.,.,$e]:= t:= compOrCroak(item,$EmptyMode,$e) +; RPLACA(item,"CodeDefine") +; --Note that DescendCode, in CodeDefine, is looking for this +; RPLACD(CADR item,[$signatureOfForm]) +; --This is how the signature is updated for buildFunctor to recognise +;--+ +; functionPart:= ['dispatchFunction,t.expr] +; RPLACA(CDDR item,functionPart) +; RPLACD(CDDR item,nil) +; u:= compOrCroak(item,$EmptyMode,$e) => +; ([code,.,$e]:= u; RPLACA(item,first code); RPLACD(item,rest code)) +; true => cannotDo() + +(DEFUN |doIt| (|item| |$predl|) + (DECLARE (SPECIAL |$predl|)) + (PROG ($GENNO |ISTMP#4| |ISTMP#5| |x| |rhs| |ISTMP#3| |lhs'| |lhs| + |rhs'| |rhsCode| |a| |doms| |b| |l| |LETTMP#1| + |ISTMP#1| |ISTMP#2| |op| |body| |t| |functionPart| |u| + |code|) + (DECLARE (SPECIAL $GENNO)) + (RETURN + (SEQ (PROGN + (SPADLET $GENNO 0) + (COND + ((AND (PAIRP |item|) (EQ (QCAR |item|) 'SEQ) + (PROGN + (SPADLET |ISTMP#1| (QCDR |item|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (REVERSE |ISTMP#1|)) + 'T) + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |ISTMP#3| (QCAR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCAR |ISTMP#3|) '|exit|) + (PROGN + (SPADLET |ISTMP#4| + (QCDR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) + (EQUAL (QCAR |ISTMP#4|) 1) + (PROGN + (SPADLET |ISTMP#5| + (QCDR |ISTMP#4|)) + (AND (PAIRP |ISTMP#5|) + (EQ (QCDR |ISTMP#5|) NIL) + (PROGN + (SPADLET |x| + (QCAR |ISTMP#5|)) + 'T))))))) + (PROGN (SPADLET |l| (QCDR |ISTMP#2|)) 'T) + (PROGN (SPADLET |l| (NREVERSE |l|)) 'T)))) + (RPLACA |item| 'PROGN) (RPLACA (LASTNODE |item|) |x|) + (DO ((G170009 (CDR |item|) (CDR G170009)) + (|it1| NIL)) + ((OR (ATOM G170009) + (PROGN (SETQ |it1| (CAR G170009)) NIL)) + NIL) + (SEQ (EXIT (SPADLET |$e| + (|compSingleCapsuleItem| |it1| + |$predl| |$e|)))))) + ((|isDomainForm| |item| |$e|) + (SPADLET |u| + (CONS '|import| + (CONS (CONS (CAR |item|) (CDR |item|)) + NIL))) + (|stackWarning| + (CONS '|Use: import | + (CONS (CONS (CAR |item|) (CDR |item|)) NIL))) + (RPLACA |item| (CAR |u|)) (RPLACD |item| (CDR |u|)) + (|doIt| |item| |$predl|)) + ((AND (PAIRP |item|) (EQ (QCAR |item|) 'LET) + (PROGN + (SPADLET |ISTMP#1| (QCDR |item|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |lhs| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |rhs| (QCAR |ISTMP#2|)) + 'T)))))) + (COND + ((NULL (PROGN + (SPADLET |ISTMP#1| + (|compOrCroak| |item| |$EmptyMode| + |$e|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |code| (QCAR |ISTMP#1|)) + (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 |$e| + (QCAR |ISTMP#3|)) + 'T)))))))) + (|stackSemanticError| + (CONS '|cannot compile assigned value to| + (|bright| |lhs|)) + NIL)) + ((NULL (AND (PAIRP |code|) (EQ (QCAR |code|) 'LET) + (PROGN + (SPADLET |ISTMP#1| (QCDR |code|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |lhs'| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |rhs'| + (QCAR |ISTMP#2|)) + 'T))))) + (ATOM |lhs'|))) + (COND + ((AND (PAIRP |code|) (EQ (QCAR |code|) 'PROGN)) + (|stackSemanticError| + (CONS '|multiple assignment | + (CONS |item| + (CONS '| not allowed| NIL))) + NIL)) + ('T (RPLACA |item| (CAR |code|)) + (RPLACD |item| (CDR |code|))))) + ('T (SPADLET |lhs| |lhs'|) + (COND + ((AND (NULL (|member| (KAR |rhs|) + |$NonMentionableDomainNames|)) + (NULL (MEMQ |lhs| |$functorLocalParameters|))) + (SPADLET |$functorLocalParameters| + (APPEND |$functorLocalParameters| + (CONS |lhs| NIL))))) + (COND + ((AND (PAIRP |code|) (EQ (QCAR |code|) 'LET) + (PROGN + (SPADLET |ISTMP#1| (QCDR |code|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |rhs'| + (QCAR |ISTMP#2|)) + 'T))))) + (|isDomainForm| |rhs'| |$e|)) + (COND + ((|isFunctor| |rhs'|) + (SPADLET |$functorsUsed| + (|insert| (|opOf| |rhs'|) + |$functorsUsed|)) + (SPADLET |$packagesUsed| + (|insert| (CONS (|opOf| |rhs'|) NIL) + |$packagesUsed|)))) + (COND + ((BOOT-EQUAL |lhs| '|Rep|) + (SPADLET |$Representation| + (ELT (|get| '|Rep| '|value| |$e|) 0)) + (COND + ((BOOT-EQUAL |$NRTopt| 'T) + (|NRTgetLocalIndex| |$Representation|)) + ('T NIL)))) + (SPADLET |$LocalDomainAlist| + (CONS (CONS |lhs| + (SUBLIS |$LocalDomainAlist| + (ELT (|get| |lhs| '|value| |$e|) + 0))) + |$LocalDomainAlist|)))) + (COND + ((AND (PAIRP |code|) (EQ (QCAR |code|) 'LET)) + (RPLACA |item| + (COND + (|$QuickCode| 'QSETREFV) + ('T 'SETELT))) + (SPADLET |rhsCode| |rhs'|) + (RPLACD |item| + (CONS '$ + (CONS + (|NRTgetLocalIndexClear| |lhs|) + (CONS |rhsCode| NIL))))) + ('T (RPLACA |item| (CAR |code|)) + (RPLACD |item| (CDR |code|))))))) + ((AND (PAIRP |item|) (EQ (QCAR |item|) '|:|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |item|)) + (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 |t| (QCAR |ISTMP#2|)) + 'T)))))) + (SPADLET |LETTMP#1| + (|compOrCroak| |item| |$EmptyMode| |$e|)) + (SPADLET |$e| (CADDR |LETTMP#1|)) |LETTMP#1|) + ((AND (PAIRP |item|) (EQ (QCAR |item|) '|import|) + (PROGN (SPADLET |doms| (QCDR |item|)) 'T)) + (DO ((G170018 |doms| (CDR G170018)) (|dom| NIL)) + ((OR (ATOM G170018) + (PROGN (SETQ |dom| (CAR G170018)) NIL)) + NIL) + (SEQ (EXIT (|sayBrightly| + (CONS (MAKESTRING " importing ") + (|formatUnabbreviated| |dom|)))))) + (SPADLET |LETTMP#1| + (|compOrCroak| |item| |$EmptyMode| |$e|)) + (SPADLET |$e| (CADDR |LETTMP#1|)) + (RPLACA |item| 'PROGN) (RPLACD |item| NIL)) + ((AND (PAIRP |item|) (EQ (QCAR |item|) 'IF)) + (|doItIf| |item| |$predl| |$e|)) + ((AND (PAIRP |item|) (EQ (QCAR |item|) '|where|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |item|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |b| (QCAR |ISTMP#1|)) + (SPADLET |l| (QCDR |ISTMP#1|)) + 'T)))) + (|compOrCroak| |item| |$EmptyMode| |$e|)) + ((AND (PAIRP |item|) (EQ (QCAR |item|) 'MDEF)) + (SPADLET |LETTMP#1| + (|compOrCroak| |item| |$EmptyMode| |$e|)) + (SPADLET |$e| (CADDR |LETTMP#1|)) |LETTMP#1|) + ((AND (PAIRP |item|) (EQ (QCAR |item|) 'DEF) + (PROGN + (SPADLET |ISTMP#1| (QCDR |item|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |op| (QCAR |ISTMP#2|)) + 'T)))))) + (COND + ((SPADLET |body| (|isMacro| |item| |$e|)) + (SPADLET |$e| (|put| |op| '|macro| |body| |$e|))) + ('T + (SPADLET |t| + (|compOrCroak| |item| |$EmptyMode| |$e|)) + (SPADLET |$e| (CADDR |t|)) + (RPLACA |item| '|CodeDefine|) + (RPLACD (CADR |item|) (CONS |$signatureOfForm| NIL)) + (SPADLET |functionPart| + (CONS '|dispatchFunction| + (CONS (CAR |t|) NIL))) + (RPLACA (CDDR |item|) |functionPart|) + (RPLACD (CDDR |item|) NIL)))) + ((SPADLET |u| (|compOrCroak| |item| |$EmptyMode| |$e|)) + (SPADLET |code| (CAR |u|)) (SPADLET |$e| (CADDR |u|)) + (RPLACA |item| (CAR |code|)) + (RPLACD |item| (CDR |code|))) + ('T (|cannotDo|)))))))) + +;isMacro(x,e) == +; x is ['DEF,[op,:args],signature,specialCases,body] and +; null get(op,'modemap,e) and null args and null get(op,'mode,e) +; and signature is [nil] => body + +(DEFUN |isMacro| (|x| |e|) + (PROG (|ISTMP#1| |ISTMP#2| |op| |args| |ISTMP#3| |signature| + |ISTMP#4| |specialCases| |ISTMP#5| |body|) + (RETURN + (SEQ (COND + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'DEF) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |op| (QCAR |ISTMP#2|)) + (SPADLET |args| (QCDR |ISTMP#2|)) + 'T))) + (PROGN + (SPADLET |ISTMP#3| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |signature| + (QCAR |ISTMP#3|)) + (SPADLET |ISTMP#4| (QCDR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) + (PROGN + (SPADLET |specialCases| + (QCAR |ISTMP#4|)) + (SPADLET |ISTMP#5| + (QCDR |ISTMP#4|)) + (AND (PAIRP |ISTMP#5|) + (EQ (QCDR |ISTMP#5|) NIL) + (PROGN + (SPADLET |body| + (QCAR |ISTMP#5|)) + 'T))))))))) + (NULL (|get| |op| '|modemap| |e|)) (NULL |args|) + (NULL (|get| |op| '|mode| |e|)) (PAIRP |signature|) + (EQ (QCDR |signature|) NIL) + (NULL (QCAR |signature|))) + (EXIT |body|))))))) + +;doItIf(item is [.,p,x,y],$predl,$e) == +; olde:= $e +; [p',.,$e]:= comp(p,$Boolean,$e) or userError ['"not a Boolean:",p] +; oldFLP:=$functorLocalParameters +; if x^="noBranch" then +; compSingleCapsuleItem(x,$predl,getSuccessEnvironment(p,$e)) +; x':=localExtras(oldFLP) +; where localExtras(oldFLP) == +; EQ(oldFLP,$functorLocalParameters) => NIL +; flp1:=$functorLocalParameters +; oldFLP':=oldFLP +; n:=0 +; while oldFLP' repeat +; oldFLP':=CDR oldFLP' +; flp1:=CDR flp1 +; n:=n+1 +; -- Now we have to add code to compile all the elements +; -- of functorLocalParameters that were added during the +; -- conditional compilation +; nils:=ans:=[] +; for u in flp1 repeat -- is =u form always an ATOM? +; if ATOM u or (or/[v is [.,=u,:.] for v in $getDomainCode]) +; then +; nils:=[u,:nils] +; else +; gv := GENSYM() +; ans:=[['LET,gv,u],:ans] +; nils:=[gv,:nils] +; n:=n+1 +; $functorLocalParameters:=[:oldFLP,:NREVERSE nils] +; NREVERSE ans +; oldFLP:=$functorLocalParameters +; if y^="noBranch" then +; compSingleCapsuleItem(y,$predl,getInverseEnvironment(p,olde)) +; y':=localExtras(oldFLP) +; RPLACA(item,"COND") +; RPLACD(item,[[p',x,:x'],['(QUOTE T),y,:y']]) + +(DEFUN |doItIf,localExtras| (|oldFLP|) + (PROG (|oldFLP'| |flp1| |ISTMP#1| |gv| |ans| |nils| |n|) + (RETURN + (SEQ (IF (EQ |oldFLP| |$functorLocalParameters|) (EXIT NIL)) + (SPADLET |flp1| |$functorLocalParameters|) + (SPADLET |oldFLP'| |oldFLP|) (SPADLET |n| 0) + (DO () ((NULL |oldFLP'|) NIL) + (SEQ (SPADLET |oldFLP'| (CDR |oldFLP'|)) + (SPADLET |flp1| (CDR |flp1|)) + (EXIT (SPADLET |n| (PLUS |n| 1))))) + (SPADLET |nils| (SPADLET |ans| NIL)) + (DO ((G170185 |flp1| (CDR G170185)) (|u| NIL)) + ((OR (ATOM G170185) + (PROGN (SETQ |u| (CAR G170185)) NIL)) + NIL) + (SEQ (IF (OR (ATOM |u|) + (PROG (G170191) + (SPADLET G170191 NIL) + (RETURN + (DO ((G170199 NIL G170191) + (G170200 |$getDomainCode| + (CDR G170200)) + (|v| NIL)) + ((OR G170199 (ATOM G170200) + (PROGN + (SETQ |v| (CAR G170200)) + NIL)) + G170191) + (SEQ (EXIT + (SETQ G170191 + (OR G170191 + (AND (PAIRP |v|) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |v|)) + (AND (PAIRP |ISTMP#1|) + (EQUAL (QCAR |ISTMP#1|) + |u|)))))))))))) + (SPADLET |nils| (CONS |u| |nils|)) + (SEQ (SPADLET |gv| (GENSYM)) + (SPADLET |ans| + (CONS + (CONS 'LET + (CONS |gv| (CONS |u| NIL))) + |ans|)) + (EXIT (SPADLET |nils| (CONS |gv| |nils|))))) + (EXIT (SPADLET |n| (PLUS |n| 1))))) + (SPADLET |$functorLocalParameters| + (APPEND |oldFLP| (NREVERSE |nils|))) + (EXIT (NREVERSE |ans|)))))) + +(DEFUN |doItIf| (|item| |$predl| |$e|) + (DECLARE (SPECIAL |$predl| |$e|)) + (PROG (|p| |x| |y| |olde| |LETTMP#1| |p'| |x'| |oldFLP| |y'|) + (RETURN + (PROGN + (SPADLET |p| (CADR |item|)) + (SPADLET |x| (CADDR |item|)) + (SPADLET |y| (CADDDR |item|)) + (SPADLET |olde| |$e|) + (SPADLET |LETTMP#1| + (OR (|comp| |p| |$Boolean| |$e|) + (|userError| + (CONS (MAKESTRING "not a Boolean:") + (CONS |p| NIL))))) + (SPADLET |p'| (CAR |LETTMP#1|)) + (SPADLET |$e| (CADDR |LETTMP#1|)) + (SPADLET |oldFLP| |$functorLocalParameters|) + (COND + ((NEQUAL |x| '|noBranch|) + (|compSingleCapsuleItem| |x| |$predl| + (|getSuccessEnvironment| |p| |$e|)) + (SPADLET |x'| (|doItIf,localExtras| |oldFLP|)))) + (SPADLET |oldFLP| |$functorLocalParameters|) + (COND + ((NEQUAL |y| '|noBranch|) + (|compSingleCapsuleItem| |y| |$predl| + (|getInverseEnvironment| |p| |olde|)) + (SPADLET |y'| (|doItIf,localExtras| |oldFLP|)))) + (RPLACA |item| 'COND) + (RPLACD |item| + (CONS (CONS |p'| (CONS |x| |x'|)) + (CONS (CONS ''T (CONS |y| |y'|)) NIL))))))) + +;--compSingleCapsuleIf(x,predl,e,$functorLocalParameters) == +;-- compSingleCapsuleItem(x,predl,e) +; +;--% CATEGORY AND DOMAIN FUNCTIONS +;compContained(["CONTAINED",a,b],m,e) == +; [a,ma,e]:= comp(a,$EmptyMode,e) or return nil +; [b,mb,e]:= comp(b,$EmptyMode,e) or return nil +; isCategoryForm(ma,e) and isCategoryForm(mb,e) => +; (T:= [["CONTAINED",a,b],$Boolean,e]; convert(T,m)) +; nil + +(DEFUN |compContained| (G170279 |m| |e|) + (PROG (|a| |ma| |LETTMP#1| |b| |mb| T$) + (RETURN + (PROGN + (COND ((EQ (CAR G170279) 'CONTAINED) (CAR G170279))) + (SPADLET |a| (CADR G170279)) + (SPADLET |b| (CADDR G170279)) + (SPADLET |LETTMP#1| + (OR (|comp| |a| |$EmptyMode| |e|) (RETURN NIL))) + (SPADLET |a| (CAR |LETTMP#1|)) + (SPADLET |ma| (CADR |LETTMP#1|)) + (SPADLET |e| (CADDR |LETTMP#1|)) + (SPADLET |LETTMP#1| + (OR (|comp| |b| |$EmptyMode| |e|) (RETURN NIL))) + (SPADLET |b| (CAR |LETTMP#1|)) + (SPADLET |mb| (CADR |LETTMP#1|)) + (SPADLET |e| (CADDR |LETTMP#1|)) + (COND + ((AND (|isCategoryForm| |ma| |e|) + (|isCategoryForm| |mb| |e|)) + (SPADLET T$ + (CONS (CONS 'CONTAINED (CONS |a| (CONS |b| NIL))) + (CONS |$Boolean| (CONS |e| NIL)))) + (|convert| T$ |m|)) + ('T NIL)))))) + +;compJoin(["Join",:argl],m,e) == +; catList:= [(compForMode(x,$Category,e) or return 'failed).expr for x in argl] +; catList='failed => stackSemanticError(["cannot form Join of: ",argl],nil) +; catList':= +; [extract for x in catList] where +; extract() == +; isCategoryForm(x,e) => +; parameters:= +; UNION("append"/[getParms(y,e) for y in rest x],parameters) +; where getParms(y,e) == +; atom y => +; isDomainForm(y,e) => LIST y +; nil +; y is ['LENGTH,y'] => [y,y'] +; LIST y +; x +; x is ["DomainSubstitutionMacro",pl,body] => +; (parameters:= UNION(pl,parameters); body) +; x is ["mkCategory",:.] => x +; atom x and getmode(x,e)=$Category => x +; stackSemanticError(["invalid argument to Join: ",x],nil) +; x +; T:= [wrapDomainSub(parameters,["Join",:catList']),$Category,e] +; convert(T,m) + +(DEFUN |compJoin,getParms| (|y| |e|) + (PROG (|ISTMP#1| |y'|) + (RETURN + (SEQ (IF (ATOM |y|) + (EXIT (SEQ (IF (|isDomainForm| |y| |e|) + (EXIT (LIST |y|))) + (EXIT NIL)))) + (IF (AND (PAIRP |y|) (EQ (QCAR |y|) 'LENGTH) + (PROGN + (SPADLET |ISTMP#1| (QCDR |y|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |y'| (QCAR |ISTMP#1|)) 'T)))) + (EXIT (CONS |y| (CONS |y'| NIL)))) + (EXIT (LIST |y|)))))) + +(DEFUN |compJoin| (G170354 |m| |e|) + (PROG (|argl| |catList| |ISTMP#1| |pl| |ISTMP#2| |body| |parameters| + |catList'| T$) + (RETURN + (SEQ (PROGN + (COND ((EQ (CAR G170354) '|Join|) (CAR G170354))) + (SPADLET |argl| (CDR G170354)) + (SPADLET |catList| + (PROG (G170374) + (SPADLET G170374 NIL) + (RETURN + (DO ((G170379 |argl| (CDR G170379)) + (|x| NIL)) + ((OR (ATOM G170379) + (PROGN + (SETQ |x| (CAR G170379)) + NIL)) + (NREVERSE0 G170374)) + (SEQ (EXIT (SETQ G170374 + (CONS + (CAR + (OR + (|compForMode| |x| + |$Category| |e|) + (RETURN '|failed|))) + G170374)))))))) + (COND + ((BOOT-EQUAL |catList| '|failed|) + (|stackSemanticError| + (CONS '|cannot form Join of: | (CONS |argl| NIL)) + NIL)) + ('T + (SPADLET |catList'| + (PROG (G170396) + (SPADLET G170396 NIL) + (RETURN + (DO ((G170408 |catList| (CDR G170408)) + (|x| NIL)) + ((OR (ATOM G170408) + (PROGN + (SETQ |x| (CAR G170408)) + NIL)) + (NREVERSE0 G170396)) + (SEQ (EXIT + (SETQ G170396 + (CONS + (COND + ((|isCategoryForm| |x| |e|) + (SPADLET |parameters| + (|union| + (PROG (G170414) + (SPADLET G170414 NIL) + (RETURN + (DO + ((G170419 (CDR |x|) + (CDR G170419)) + (|y| NIL)) + ((OR (ATOM G170419) + (PROGN + (SETQ |y| + (CAR G170419)) + NIL)) + G170414) + (SEQ + (EXIT + (SETQ G170414 + (APPEND G170414 + (|compJoin,getParms| + |y| |e|)))))))) + |parameters|)) + |x|) + ((AND (PAIRP |x|) + (EQ (QCAR |x|) + '|DomainSubstitutionMacro|) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |pl| + (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 |parameters| + (|union| |pl| |parameters|)) + |body|) + ((AND (PAIRP |x|) + (EQ (QCAR |x|) + '|mkCategory|)) + |x|) + ((AND (ATOM |x|) + (BOOT-EQUAL + (|getmode| |x| |e|) + |$Category|)) + |x|) + ('T + (|stackSemanticError| + (CONS + '|invalid argument to Join: | + (CONS |x| NIL)) + NIL) + |x|)) + G170396)))))))) + (SPADLET T$ + (CONS (|wrapDomainSub| |parameters| + (CONS '|Join| |catList'|)) + (CONS |$Category| (CONS |e| NIL)))) + (|convert| T$ |m|)))))))) + +;compForMode(x,m,e) == +; $compForModeIfTrue: local:= true +; comp(x,m,e) + +(DEFUN |compForMode| (|x| |m| |e|) + (PROG (|$compForModeIfTrue|) + (DECLARE (SPECIAL |$compForModeIfTrue|)) + (RETURN + (PROGN (SPADLET |$compForModeIfTrue| 'T) (|comp| |x| |m| |e|))))) + +;compMakeCategoryObject(c,$e) == +; not isCategoryForm(c,$e) => nil +; u:= mkEvalableCategoryForm c => [eval u,$Category,$e] +; nil + +(DEFUN |compMakeCategoryObject| (|c| |$e|) + (DECLARE (SPECIAL |$e|)) + (PROG (|u|) + (RETURN + (COND + ((NULL (|isCategoryForm| |c| |$e|)) NIL) + ((SPADLET |u| (|mkEvalableCategoryForm| |c|)) + (CONS (|eval| |u|) (CONS |$Category| (CONS |$e| NIL)))) + ('T NIL))))) + +;quotifyCategoryArgument x == MKQ x + +(DEFUN |quotifyCategoryArgument| (|x|) (MKQ |x|)) + +;makeCategoryForm(c,e) == +; not isCategoryForm(c,e) => nil +; [x,m,e]:= compOrCroak(c,$EmptyMode,e) +; [x,e] + +(DEFUN |makeCategoryForm| (|c| |e|) + (PROG (|LETTMP#1| |x| |m|) + (RETURN + (COND + ((NULL (|isCategoryForm| |c| |e|)) NIL) + ('T (SPADLET |LETTMP#1| (|compOrCroak| |c| |$EmptyMode| |e|)) + (SPADLET |x| (CAR |LETTMP#1|)) (SPADLET |m| (CADR |LETTMP#1|)) + (SPADLET |e| (CADDR |LETTMP#1|)) (CONS |x| (CONS |e| NIL))))))) + +;compCategory(x,m,e) == +; $TOP__LEVEL: local:= true +; (m:= resolve(m,["Category"]))=["Category"] and x is ['CATEGORY, +; domainOrPackage,:l] => +; $sigList: local := nil +; $atList: local := nil +; $sigList:= $atList:= nil +; for x in l repeat compCategoryItem(x,nil) +; rep:= mkExplicitCategoryFunction(domainOrPackage,$sigList,$atList) +; --if inside compDefineCategory, provide for category argument substitution +; [rep,m,e] +; systemErrorHere '"compCategory" + +(DEFUN |compCategory| (|x| |m| |e|) + (PROG ($TOP_LEVEL |$sigList| |$atList| |ISTMP#1| |domainOrPackage| + |l| |rep|) + (DECLARE (SPECIAL $TOP_LEVEL |$sigList| |$atList|)) + (RETURN + (SEQ (PROGN + (SPADLET $TOP_LEVEL 'T) + (COND + ((AND (BOOT-EQUAL + (SPADLET |m| + (|resolve| |m| + (CONS '|Category| NIL))) + (CONS '|Category| NIL)) + (PAIRP |x|) (EQ (QCAR |x|) 'CATEGORY) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |domainOrPackage| + (QCAR |ISTMP#1|)) + (SPADLET |l| (QCDR |ISTMP#1|)) + 'T)))) + (SPADLET |$sigList| NIL) (SPADLET |$atList| NIL) + (SPADLET |$sigList| (SPADLET |$atList| NIL)) + (DO ((G170487 |l| (CDR G170487)) (|x| NIL)) + ((OR (ATOM G170487) + (PROGN (SETQ |x| (CAR G170487)) NIL)) + NIL) + (SEQ (EXIT (|compCategoryItem| |x| NIL)))) + (SPADLET |rep| + (|mkExplicitCategoryFunction| + |domainOrPackage| |$sigList| |$atList|)) + (CONS |rep| (CONS |m| (CONS |e| NIL)))) + ('T (|systemErrorHere| (MAKESTRING "compCategory"))))))))) + +;mkExplicitCategoryFunction(domainOrPackage,sigList,atList) == +; body:= +; ["mkCategory",MKQ domainOrPackage,['LIST,:REVERSE sigList],['LIST,: +; REVERSE atList],MKQ domList,nil] where +; domList() == +; ("UNION"/[fn sig for ["QUOTE",[[.,sig,:.],:.]] in sigList]) where +; fn sig == [D for D in sig | mustInstantiate D] +; parameters:= +; REMDUP +; ("append"/ +; [[x for x in sig | IDENTP x and x^='_$] +; for ["QUOTE",[[.,sig,:.],:.]] in sigList]) +; wrapDomainSub(parameters,body) + +(DEFUN |mkExplicitCategoryFunction,fn| (|sig|) + (PROG () + (RETURN + (SEQ (PROG (G170517) + (SPADLET G170517 NIL) + (RETURN + (DO ((G170523 |sig| (CDR G170523)) (D NIL)) + ((OR (ATOM G170523) + (PROGN (SETQ D (CAR G170523)) NIL)) + (NREVERSE0 G170517)) + (SEQ (EXIT (COND + ((|mustInstantiate| D) + (SETQ G170517 (CONS D G170517))))))))))))) + +(DEFUN |mkExplicitCategoryFunction| + (|domainOrPackage| |sigList| |atList|) + (PROG (|body| |sig| |parameters|) + (RETURN + (SEQ (PROGN + (SPADLET |body| + (CONS '|mkCategory| + (CONS (MKQ |domainOrPackage|) + (CONS (CONS 'LIST + (REVERSE |sigList|)) + (CONS + (CONS 'LIST + (REVERSE |atList|)) + (CONS + (MKQ + (PROG (G170546) + (SPADLET G170546 NIL) + (RETURN + (DO + ((G170552 |sigList| + (CDR G170552)) + (G170533 NIL)) + ((OR (ATOM G170552) + (PROGN + (SETQ G170533 + (CAR G170552)) + NIL) + (PROGN + (PROGN + (SPADLET |sig| + (CAR + (CDAADR + G170533))) + G170533) + NIL)) + G170546) + (SEQ + (EXIT + (SETQ G170546 + (|union| G170546 + (|mkExplicitCategoryFunction,fn| + |sig|))))))))) + (CONS NIL NIL))))))) + (SPADLET |parameters| + (REMDUP (PROG (G170559) + (SPADLET G170559 NIL) + (RETURN + (DO ((G170565 |sigList| + (CDR G170565)) + (G170542 NIL)) + ((OR (ATOM G170565) + (PROGN + (SETQ G170542 + (CAR G170565)) + NIL) + (PROGN + (PROGN + (SPADLET |sig| + (CAR (CDAADR G170542))) + G170542) + NIL)) + G170559) + (SEQ + (EXIT + (SETQ G170559 + (APPEND G170559 + (PROG (G170577) + (SPADLET G170577 NIL) + (RETURN + (DO + ((G170583 |sig| + (CDR G170583)) + (|x| NIL)) + ((OR (ATOM G170583) + (PROGN + (SETQ |x| + (CAR G170583)) + NIL)) + (NREVERSE0 G170577)) + (SEQ + (EXIT + (COND + ((AND (IDENTP |x|) + (NEQUAL |x| '$)) + (SETQ G170577 + (CONS |x| + G170577)))))))))))))))))) + (|wrapDomainSub| |parameters| |body|)))))) + +;wrapDomainSub(parameters,x) == +; ["DomainSubstitutionMacro",parameters,x] + +(DEFUN |wrapDomainSub| (|parameters| |x|) + (CONS '|DomainSubstitutionMacro| (CONS |parameters| (CONS |x| NIL)))) + +;mustInstantiate D == +; D is [fn,:.] and ^(MEMQ(fn,$DummyFunctorNames) or GET(fn,"makeFunctionList")) + +(DEFUN |mustInstantiate| (D) + (PROG (|fn|) + (RETURN + (AND (PAIRP D) (PROGN (SPADLET |fn| (QCAR D)) 'T) + (NULL (OR (MEMQ |fn| |$DummyFunctorNames|) + (GETL |fn| '|makeFunctionList|))))))) + +;DomainSubstitutionFunction(parameters,body) == +; --see definition of DomainSubstitutionMacro in SPAD LISP +; if parameters then +; (body:= Subst(parameters,body)) where +; Subst(parameters,body) == +; ATOM body => +; MEMQ(body,parameters) => MKQ body +; body +; MEMBER(body,parameters) => +; g:=GENSYM() +; $extraParms:=PUSH([g,:body],$extraParms) +; --Used in SetVector12 to generate a substitution list +; --bound in buildFunctor +; --For categories, bound and used in compDefineCategory +; MKQ g +; first body="QUOTE" => body +; PAIRP $definition and +; isFunctor first body and +; first body ^= first $definition +; => ['QUOTE,optimize body] +; [Subst(parameters,u) for u in body] +; not (body is ["Join",:.]) => body +; atom $definition => body +; null rest $definition => body +; --should not bother if it will only be called once +; name:= INTERN STRCONC(KAR $definition,";CAT") +; SETANDFILE(name,nil) +; body:= ["COND",[name],['(QUOTE T),['SETQ,name,body]]] +; body + +(DEFUN |DomainSubstitutionFunction,Subst| (|parameters| |body|) + (PROG (|g|) + (RETURN + (SEQ (IF (ATOM |body|) + (EXIT (SEQ (IF (MEMQ |body| |parameters|) + (EXIT (MKQ |body|))) + (EXIT |body|)))) + (IF (|member| |body| |parameters|) + (EXIT (SEQ (SPADLET |g| (GENSYM)) + (SPADLET |$extraParms| + (PUSH (CONS |g| |body|) + |$extraParms|)) + (EXIT (MKQ |g|))))) + (IF (BOOT-EQUAL (CAR |body|) 'QUOTE) (EXIT |body|)) + (IF (AND (AND (PAIRP |$definition|) + (|isFunctor| (CAR |body|))) + (NEQUAL (CAR |body|) (CAR |$definition|))) + (EXIT (CONS 'QUOTE (CONS (|optimize| |body|) NIL)))) + (EXIT (PROG (G170613) + (SPADLET G170613 NIL) + (RETURN + (DO ((G170618 |body| (CDR G170618)) (|u| NIL)) + ((OR (ATOM G170618) + (PROGN (SETQ |u| (CAR G170618)) NIL)) + (NREVERSE0 G170613)) + (SEQ (EXIT (SETQ G170613 + (CONS + (|DomainSubstitutionFunction,Subst| + |parameters| |u|) + G170613)))))))))))) + +(DEFUN |DomainSubstitutionFunction| (|parameters| |body|) + (PROG (|name|) + (RETURN + (PROGN + (COND + (|parameters| + (SPADLET |body| + (|DomainSubstitutionFunction,Subst| |parameters| + |body|)))) + (COND + ((NULL (AND (PAIRP |body|) (EQ (QCAR |body|) '|Join|))) + |body|) + ((ATOM |$definition|) |body|) + ((NULL (CDR |$definition|)) |body|) + ('T + (SPADLET |name| + (INTERN (STRCONC (KAR |$definition|) '|;CAT|))) + (SETANDFILE |name| NIL) + (SPADLET |body| + (CONS 'COND + (CONS (CONS |name| NIL) + (CONS (CONS ''T + (CONS + (CONS 'SETQ + (CONS |name| + (CONS |body| NIL))) + NIL)) + NIL)))) + |body|)))))) + +;compCategoryItem(x,predl) == +; x is nil => nil +; --1. if x is a conditional expression, recurse; otherwise, form the predicate +; x is ["COND",[p,e]] => +; predl':= [p,:predl] +; e is ["PROGN",:l] => for y in l repeat compCategoryItem(y,predl') +; compCategoryItem(e,predl') +; x is ["IF",a,b,c] => +; predl':= [a,:predl] +; if b^="noBranch" then +; b is ["PROGN",:l] => for y in l repeat compCategoryItem(y,predl') +; compCategoryItem(b,predl') +; c="noBranch" => nil +; predl':= [["not",a],:predl] +; c is ["PROGN",:l] => for y in l repeat compCategoryItem(y,predl') +; compCategoryItem(c,predl') +; pred:= (predl => MKPF(predl,"AND"); true) +; +; --2. if attribute, push it and return +; x is ["ATTRIBUTE",y] => PUSH(MKQ [y,pred],$atList) +; +; --3. it may be a list, with PROGN as the CAR, and some information as the CDR +; x is ["PROGN",:l] => for u in l repeat compCategoryItem(u,predl) +; +;-- 4. otherwise, x gives a signature for a +;-- single operator name or a list of names; if a list of names, +;-- recurse +; ["SIGNATURE",op,:sig]:= x +; null atom op => +; for y in op repeat compCategoryItem(["SIGNATURE",y,:sig],predl) +; +; --4. branch on a single type or a signature %with source and target +; PUSH(MKQ [rest x,pred],$sigList) +; + +(DEFUN |compCategoryItem| (|x| |predl|) + (PROG (|p| |e| |a| |ISTMP#2| |b| |ISTMP#3| |c| |predl'| |pred| + |ISTMP#1| |y| |l| |op| |sig|) + (RETURN + (SEQ (COND + ((NULL |x|) NIL) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'COND) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |p| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |e| (QCAR |ISTMP#3|)) + 'T)))))))) + (SPADLET |predl'| (CONS |p| |predl|)) + (COND + ((AND (PAIRP |e|) (EQ (QCAR |e|) 'PROGN) + (PROGN (SPADLET |l| (QCDR |e|)) 'T)) + (DO ((G170713 |l| (CDR G170713)) (|y| NIL)) + ((OR (ATOM G170713) + (PROGN (SETQ |y| (CAR G170713)) NIL)) + NIL) + (SEQ (EXIT (|compCategoryItem| |y| |predl'|))))) + ('T (|compCategoryItem| |e| |predl'|)))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'IF) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |b| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |c| (QCAR |ISTMP#3|)) + 'T)))))))) + (SPADLET |predl'| (CONS |a| |predl|)) + (COND + ((NEQUAL |b| '|noBranch|) + (COND + ((AND (PAIRP |b|) (EQ (QCAR |b|) 'PROGN) + (PROGN (SPADLET |l| (QCDR |b|)) 'T)) + (DO ((G170722 |l| (CDR G170722)) (|y| NIL)) + ((OR (ATOM G170722) + (PROGN (SETQ |y| (CAR G170722)) NIL)) + NIL) + (SEQ (EXIT (|compCategoryItem| |y| |predl'|))))) + ('T (|compCategoryItem| |b| |predl'|))))) + (COND + ((BOOT-EQUAL |c| '|noBranch|) NIL) + ('T + (SPADLET |predl'| + (CONS (CONS '|not| (CONS |a| NIL)) |predl|)) + (COND + ((AND (PAIRP |c|) (EQ (QCAR |c|) 'PROGN) + (PROGN (SPADLET |l| (QCDR |c|)) 'T)) + (DO ((G170731 |l| (CDR G170731)) (|y| NIL)) + ((OR (ATOM G170731) + (PROGN (SETQ |y| (CAR G170731)) NIL)) + NIL) + (SEQ (EXIT (|compCategoryItem| |y| |predl'|))))) + ('T (|compCategoryItem| |c| |predl'|)))))) + ('T + (SPADLET |pred| + (COND (|predl| (MKPF |predl| 'AND)) ('T 'T))) + (COND + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'ATTRIBUTE) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |y| (QCAR |ISTMP#1|)) 'T)))) + (PUSH (MKQ (CONS |y| (CONS |pred| NIL))) |$atList|)) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'PROGN) + (PROGN (SPADLET |l| (QCDR |x|)) 'T)) + (DO ((G170740 |l| (CDR G170740)) (|u| NIL)) + ((OR (ATOM G170740) + (PROGN (SETQ |u| (CAR G170740)) NIL)) + NIL) + (SEQ (EXIT (|compCategoryItem| |u| |predl|))))) + ('T (COND ((EQ (CAR |x|) 'SIGNATURE) (CAR |x|))) + (SPADLET |op| (CADR |x|)) (SPADLET |sig| (CDDR |x|)) + (COND + ((NULL (ATOM |op|)) + (DO ((G170749 |op| (CDR G170749)) (|y| NIL)) + ((OR (ATOM G170749) + (PROGN (SETQ |y| (CAR G170749)) NIL)) + NIL) + (SEQ (EXIT (|compCategoryItem| + (CONS 'SIGNATURE (CONS |y| |sig|)) + |predl|))))) + ('T + (PUSH (MKQ (CONS (CDR |x|) (CONS |pred| NIL))) + |$sigList|))))))))))) + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document}