diff --git a/changelog b/changelog index 7cfd12c..73a33c3 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +20090905 tpd src/axiom-website/patches.html 20090905.01.tpd.patch +20090905 tpd src/interp/Makefile move wi2.boot to wi2.lisp +20090905 tpd src/interp/wi2.lisp added, rewritten from wi2.boot +20090905 tpd src/interp/wi2.boot removed, rewritten to wi2.lisp 20090904 tpd src/axiom-website/patches.html 20090904.02.tpd.patch 20090904 tpd src/interp/Makefile move wi1.boot to wi1.lisp 20090904 tpd src/interp/wi1.lisp added, rewritten from wi1.boot diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index e7006a6..5574e85 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -1988,5 +1988,7 @@ src/interp/pspad1.lisp rewrite from boot to lisp
src/interp/pspad2.lisp rewrite from boot to lisp
20090904.02.tpd.patch src/interp/wi1.lisp rewrite from boot to lisp
+20090905.01.tpd.patch +src/interp/wi2.lisp rewrite from boot to lisp
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index c58c3c2..0408445 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -4069,32 +4069,23 @@ ${MID}/wi1.lisp: ${IN}/wi1.lisp.pamphlet \subsection{wi2.boot} <>= -${AUTO}/wi2.${O}: ${MID}/wi2.clisp - @ echo 595 making ${AUTO}/wi2.${O} from ${MID}/wi2.clisp +${AUTO}/wi2.${O}: ${MID}/wi2.lisp + @ echo 598 making ${AUTO}/wi2.${O} from ${MID}/wi2.lisp @ (cd ${MID} ; \ if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/wi2.clisp"' \ + echo '(progn (compile-file "${MID}/wi2.lisp"' \ ':output-file "${AUTO}/wi2.${O}") (${BYE}))' | ${DEPSYS} ; \ else \ - echo '(progn (compile-file "${MID}/wi2.clisp"' \ + echo '(progn (compile-file "${MID}/wi2.lisp"' \ ':output-file "${AUTO}/wi2.${O}") (${BYE}))' | ${DEPSYS} \ >${TMP}/trace ; \ fi ) @ -<>= -${MID}/wi2.clisp: ${IN}/wi2.boot.pamphlet - @ echo 596 making ${MID}/wi2.clisp from ${IN}/wi2.boot.pamphlet - @ (cd ${MID} ; \ - ${TANGLE} ${IN}/wi2.boot.pamphlet >wi2.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "wi2.boot") (${BYE}))' \ - | ${DEPSYS} ; \ - else \ - echo '(progn (boottran::boottocl "wi2.boot") (${BYE}))' \ - | ${DEPSYS} >${TMP}/trace ; \ - fi ; \ - rm wi2.boot ) +<>= +${MID}/wi2.lisp: ${IN}/wi2.lisp.pamphlet + @ echo 599 making ${MID}/wi2.lisp from ${IN}/wi2.lisp.pamphlet + @ ${TANGLE} ${IN}/wi2.lisp.pamphlet >${MID}/wi2.lisp @ @@ -4739,7 +4730,7 @@ clean: <> <> -<> +<> @ pp diff --git a/src/interp/wi2.boot.pamphlet b/src/interp/wi2.boot.pamphlet deleted file mode 100644 index ecafdd8..0000000 --- a/src/interp/wi2.boot.pamphlet +++ /dev/null @@ -1,1250 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp wi2.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{License} -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - -compDefineFunctor1(df, m,$e,$prefix,$formalArgList) == - ['DEF,form,signature,$functorSpecialCases,body] := df - signature := markKillAll signature - if NRTPARSE = true then - [lineNumber,:$functorSpecialCases] := $functorSpecialCases --- 1. bind global variables - $addForm: local - $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] - $DEFdepth : local := 0 --for conversion to new compiler 3/93 - $capsuleStack : local := nil --for conversion to new compiler 3/93 - $predicateStack:local := nil --for conversion to new compiler 3/93 - $signatureStack:local := nil --for conversion to new compiler 3/93 - $importStack : local := nil --for conversion to new compiler 3/93 - $globalImportStack : local := nil --for conversion to new compiler 3/93 - $globalDeclareStack : local := nil - $globalImportDefAlist: local:= nil - $localMacroStack : local := nil --for conversion to new compiler 3/93 - $freeStack : local := nil --for conversion to new compiler 3/93 - $domainLevelVariableList: local := nil--for conversion to new compiler 3/93 - $localLoopVariables: local := nil - $pathStack : local := nil - $form: local - $op: local - $signature: local - $functorTarget: local - $Representation: local - --Set in doIt, accessed in the compiler - compNoStacking - $LocalDomainAlist: local --set in doIt, accessed in genDeltaEntry - $LocalDomainAlist:= nil - $functorForm: local - $functorLocalParameters: local - $CheckVectorList: local - --prevents CheckVector from printing out same message twice - $getDomainCode: local -- code for getting views - $insideFunctorIfTrue: local:= true - $functorsUsed: local --not currently used, finds dependent functors - $setelt: local := - $QuickCode = true => 'QSETREFV - 'SETELT - $TOP__LEVEL: local - $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] - $globalImportStack := - [markKillAll x for x in rest $functorForm for typ in rest signature' - | GETDATABASE(opOf typ,'CONSTRUCTORKIND) = 'category] - 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 := 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 - SETQ($myFunctorBody, body) --------> new <-------- - T:= compFunctorBody(body,rettype,$e,parForm) ----------------> new <--------------------- - BOUNDP '$convert2NewCompiler and $convert2NewCompiler => - return markFinish($originalBody,[$form,['Mapping,:signature'],T.env]) ----------------> new <--------------------- - -- 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) - $insideFunctorIfTrue:= false - if $LISPLIB then - $lisplibKind:= - $functorTarget is ["CATEGORY",key,:.] and key^="domain" => 'package - 'domain - $lisplibForm:= form - modemap:= [[parForm,:parSignature],[true,op']] - $lisplibModemap:= modemap - 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 := getConstructorAbbreviation op' - $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", - ['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] - -makeFunctorArgumentParameters(argl,sigl,target) == - $alternateViewList: local:= nil - $forceAdd: local:= true - $ConditionalOperators: local - target := markKillAll target - ("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] - -compDefineCapsuleFunction(df,m,oldE,$prefix,$formalArgList) == - ['DEF,form,originalSignature,specialCases,body] := df - signature := markKillAll originalSignature - $markFreeStack: local := nil --holds "free variables" - $localImportStack : local := nil --local import stack for function - $localDeclareStack: local := nil - $localLoopVariables: local := nil - originalDef := COPY df - [lineNumber,:specialCases] := specialCases - e := oldE - --1. bind global variables - $form: local - $op: local - $functionStats: local:= [0,0] - $argumentConditionList: local - $finalEnv: local - --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] ----------------------> new <--------------------------------- - returnType := signature'.target --- trialT := returnType = "$" and get("Rep",'value,e) and comp(body,'Rep,e) - trialT := returnType = "$" and comp(body,$EmptyMode,e) - ------------------------------------------------------ 11/1/94 - -- try comp-ing in $EmptyMode; if succeed - -- if we succeed then trialT.mode = "$" or "Rep" - -- do a coerce to get the correct result - T := (trialT and coerce(trialT,returnType)) - -------------------------------------- 11/1/94 - or CATCH('compCapsuleBody, compOrCroak(body,returnType,e)) - markChanges(originalDef,T,$signatureOfForm) - [nil,['Mapping,:signature'],oldE] - --------------------------------- - -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) - BOUNDP '$convert2NewCompiler and $convert2NewCompiler => - [nil,m,e] --nonsense but that's fine - 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] - -compSingleCapsuleItem(item,$predl,$e) == - $localImportStack : local := nil - $localDeclareStack: local := nil - $markFreeStack: local := nil - newItem := macroExpandInPlace(item,qe(25,$e)) - qe(26,$e) - doIt(newItem, $predl) - qe(27,$e) - $e - -compImport(["import",:doms],m,e) == - for dom in doms repeat - dom := markKillAll dom - markImport dom - e:=addDomain(dom,e) - ["/throwAway",$NoValueMode,e] - -mkUnion(a,b) == - b="$" and $Rep is ["Union",:l] => b - a is ["Union",:l] => - b is ["Union",:l'] => ["Union",:setUnion(l,l')] - MEMBER(b, l) => a - ["Union",:setUnion([b],l)] - b is ["Union",:l] => - MEMBER(a, l) => b - ["Union",:setUnion([a],l)] - STRINGP a => ["Union",b,a] - ["Union",a,b] - -compForMode(x,m,e) == - $compForModeIfTrue: local:= true - $convert2NewCompiler: local := nil - comp(x,m,e) - -compMakeCategoryObject(c,$e) == - not isCategoryForm(c,$e) => nil - c := markKillAll c - u:= mkEvalableCategoryForm c => [eval markKillAll u,$Category,$e] - nil - -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)] - x is ['MI,a,b] => - ['MI,a,macroExpand(b,e)] - macroExpandList(x,e) - -getSuccessEnvironment(a,e) == - -- the next four lines try to ensure that explicit special-case tests - -- prevent implicit ones from being generated - a is ["has",x,m] => - x := unLet x - IDENTP x and isDomainForm(m,$EmptyEnvironment) => put(x,"specialCase",m,e) - e - a is ["is",id,m] => - id := unLet id - IDENTP id and isDomainForm(m,$EmptyEnvironment) => - e:=put(id,"specialCase",m,e) - currentProplist:= getProplist(id,e) - [.,.,e] := T := comp(m,$EmptyMode,e) or return nil -- duplicates compIs - newProplist:= consProplistOf(id,currentProplist,"value",removeEnv T) - addBinding(id,newProplist,e) - e - a is ["case",x,m] and (x := unLet x) and IDENTP x => - put(x,"condition",[a,:get(x,"condition",e)],e) - e - -getInverseEnvironment(a,E) == - atom a => E - [op,:argl]:= a --- the next five lines try to ensure that explicit special-case tests --- prevent implicit ones from being generated - op="has" => - [x,m]:= argl - x := unLet x - IDENTP x and isDomainForm(m,$EmptyEnvironment) => put(x,"specialCase",m,E) - E - a is ["case",x,m] and (x := unLet x) and IDENTP x => - --the next two lines are necessary to get 3-branched Unions to work - -- old-style unions, that is - if corrupted? get(x,"condition",E) then systemError 'condition - (get(x,"condition",E) is [["OR",:oldpred]]) and MEMBER(a,oldpred) => - put(x,"condition",LIST MKPF(DELETE(a,oldpred),"OR"),E) - getUnionMode(x,E) is ["Union",:l] or systemError 'Union - if corrupted? l then systemError 'list - l':= DELETE(m,l) - for u in l' repeat - if u is ['_:,=m,:.] then l':=DELETE(u,l') - newpred:= MKPF([["case",x,m'] for m' in l'],"OR") - put(x,"condition",[newpred,:get(x,"condition",E)],E) - E - -unLet x == - x is ['LET,u,:.] => unLet u - x - -corrupted? u == - u is [op,:r] => - MEMQ(op,'(WI MI PART)) => true - or/[corrupted? x for x in r] - false - ---====================================================================== --- From apply.boot ---====================================================================== -applyMapping([op,:argl],m,e,ml) == - #argl^=#ml-1 => nil - isCategoryForm(first ml,e) => - --is op a functor? - pairlis:= [[v,:a] for a in argl for v in $FormalMapVariableList] - ml' := SUBLIS(pairlis, ml) - argl':= - [T.expr for x in argl for m' in rest ml'] where - T() == [.,.,e]:= comp(x,m',e) or return "failed" - if argl'="failed" then return nil - form:= [op,:argl'] ----------------------> new <---------------------------- - if constructor? op then form := markKillAll form ----------------------> new <---------------------------- - convert([form,first ml',e],m) - argl':= - [T.expr for x in argl for m' in rest ml] where - T() == [.,.,e]:= comp(x,m',e) or return "failed" - if argl'="failed" then return nil - form:= - not MEMBER(op,$formalArgList) and ATOM op and not get(op,'value,e) => - nprefix := $prefix or - -- following needed for referencing local funs at capsule level - getAbbreviation($op,#rest $form) - [op',:argl',"$"] where - op':= INTERN STRCONC(encodeItem nprefix,";",encodeItem op) - ['call,['applyFun,op],:argl'] - pairlis:= [[v,:a] for a in argl' for v in $FormalMapVariableList] - convert([form,SUBLIS(pairlis,first ml),e],m) - -compFormWithModemap(form,m,e,modemap) == - compFormWithModemap1(form,m,e,modemap,true) or compFormWithModemap1(form,m,e,modemap,false) - -compFormWithModemap1(form,m,e,modemap,Rep2Dollar?) == - [op,:argl] := form := markKillExpr form - [[dc,:.],:.] := modemap -----------> new: <----------- - if Rep2Dollar? then - if dc = 'Rep then - modemap := SUBST('Rep,'_$,modemap) - m := SUBST('Rep,'_$,m) - else return nil -----------> new: <----------- - [map:= [.,target,:.],[pred,impl]]:= modemap - -- this fails if the subsuming modemap is conditional - --impl is ['Subsumed,:.] => nil - if isCategoryForm(target,e) and isFunctor op then - [modemap,e]:= substituteIntoFunctorModemap(argl,modemap,e) or return nil - [map:= [.,target,:.],:cexpr]:= modemap - sv:=listOfSharpVars map - if sv then - -- SAY [ "compiling ", op, " in compFormWithModemap, - -- mode= ",map," sharp vars=",sv] - for x in argl for ss in $FormalMapVariableList repeat - if ss in sv then - [map:= [.,target,:.],:cexpr]:= modemap :=SUBST(x,ss,modemap) - -- SAY ["new map is",map] - not (target':= coerceable(target,m,e)) => nil - markMap := map - map:= [target',:rest map] - [f,Tl,sl]:= compApplyModemap(form,modemap,e,nil) or return nil - - --generate code; return - T:= - e':= - Tl => (LAST Tl).env - e - [x',m',e'] where - m':= SUBLIS(sl,map.(1)) - x':= - form':= [f,:[t.expr for t in Tl]] - m'=$Category or isCategoryForm(m',e) => form' - -- try to deal with new-style Unions where we know the conditions - op = "elt" and f is ['XLAM,:.] and IDENTP(z:=CAR argl) and - (c:=get(z,'condition,e)) and - c is [['case,=z,c1]] and - (c1 is ['_:,=(CADR argl),=m] or EQ(c1,CADR argl) ) => --- first is a full tag, as placed by getInverseEnvironment --- second is what getSuccessEnvironment will place there - ["CDR",z] - markTran(form,form',markMap,e') - qt(18,T) - convert(T,m) - -convert(T,m) == - tcheck T - qe(23,T.env) - coerce(T,resolve(T.mode,m) or return nil) - -compElt(origForm,m,E) == - form := markKillAll origForm - form isnt ["elt",aDomain,anOp] => compForm(origForm,m,E) - aDomain="Lisp" => - markLisp([anOp',m,E],E)where anOp'() == (anOp=$Zero => 0; anOp=$One => 1; anOp) - isDomainForm(aDomain,E) => - markImport opOf aDomain - E:= addDomain(aDomain,E) - mmList:= getModemapListFromDomain(anOp,0,aDomain,E) - modemap:= - n:=#mmList - 1=n => mmList.(0) - 0=n => - return - stackMessage ['"Operation ","%b",anOp,"%d", - '"missing from domain: ", aDomain] - stackWarning ['"more than 1 modemap for: ",anOp, - '" with dc=",aDomain,'" ===>" - ,mmList] - mmList.(0) -----------> new: <----------- - if aDomain = 'Rep then - modemap := SUBST('Rep,'_$,modemap) - m := SUBST('Rep,'_$,m) -----------> new: <----------- - [sig,[pred,val]]:= modemap - #sig^=2 and ^val is ["elt",:.] => nil --what does the second clause do ???? ---+ - val := genDeltaEntry [opOf anOp,:modemap] - x := markTran(origForm,[val],sig,[E]) - [x,first rest sig,E] --implies fn calls used to access constants - compForm(origForm,m,E) - -pause op == op -compApplyModemap(form,modemap,$e,sl) == - [op,:argl] := form --form to be compiled - [[mc,mr,:margl],:fnsel] := modemap --modemap we are testing - - -- $e is the current environment - -- sl substitution list, nil means bottom-up, otherwise top-down - - -- 0. fail immediately if #argl=#margl - - if #argl^=#margl then return nil - - -- 1. use modemap to evaluate arguments, returning failed if - -- not possible - - lt:= - [[.,m',$e]:= - comp(y,g,$e) or return "failed" where - g:= SUBLIS(sl,m) where - sl:= pmatchWithSl(m',m,sl) for y in argl for m in margl] - lt="failed" => return nil - - -- 2. coerce each argument to final domain, returning failed - -- if not possible - - lt':= [coerce(y,d) or return "failed" - for y in lt for d in SUBLIS(sl,margl)] - lt'="failed" => return nil - - -- 3. obtain domain-specific function, if possible, and return - - --$bindings is bound by compMapCond - [f,$bindings]:= compMapCond(op,mc,sl,fnsel) or return nil - ---+ can no longer trust what the modemap says for a reference into ---+ an exterior domain (it is calculating the displacement based on view ---+ information which is no longer valid; thus ignore this index and ---+ store the signature instead. - ---$NRTflag=true and f is [op1,d,.] and NE(d,'$) and MEMBER(op1,'(ELT CONST)) => - f is [op1,d,.] and MEMBER(op1,'(ELT CONST Subsumed)) => - [genDeltaEntry [op,:modemap],lt',$bindings] - markImport mc - [f,lt',$bindings] - -compMapCond''(cexpr,dc) == - cexpr=true => true - --cexpr = "true" => true ----------------> new <---------------------- - cexpr is [op,:l] and MEMQ(op,'(_and AND)) => and/[compMapCond''(u,dc) for u in l] - cexpr is [op,:l] and MEMQ(op,'(_or OR)) => or/[compMapCond''(u,dc) for u in l] ----------------> new <---------------------- - cexpr is ["not",u] => not compMapCond''(u,dc) - cexpr is ["has",name,cat] => (knownInfo cexpr => true; false) - --for the time being we'll stop here - shouldn't happen so far - --$disregardConditionIfTrue => true - --stackSemanticError(("not known that",'%b,name, - -- '%d,"has",'%b,cat,'%d),nil) - --now it must be an attribute - MEMBER(["ATTRIBUTE",dc,cexpr],get("$Information","special",$e)) => true - --for the time being we'll stop here - shouldn't happen so far - stackMessage ["not known that",'%b,dc,'%d,"has",'%b,cexpr,'%d] - false - ---====================================================================== --- From nruncomp.boot ---====================================================================== -NRTgetLocalIndex1(item,killBindingIfTrue) == - k := NRTassocIndex item => k - item = $NRTaddForm => 5 - item = '$ => 0 - item = '_$_$ => 2 - value:= - MEMQ(item,$formalArgList) => item - nil - atom item and null MEMQ(item,'($ _$_$)) - and null value => --give slots to atoms - $NRTdeltaList:= [['domain,NRTaddInner item,:value],:$NRTdeltaList] - $NRTdeltaListComp:=[item,:$NRTdeltaListComp] - $NRTdeltaLength := $NRTdeltaLength+1 - $NRTbase + $NRTdeltaLength - 1 - $NRTdeltaList:= [['domain,NRTaddInner item,:value],:$NRTdeltaList] - saveNRTdeltaListComp:= $NRTdeltaListComp:=[nil,:$NRTdeltaListComp] - saveIndex := $NRTbase + $NRTdeltaLength - $NRTdeltaLength := $NRTdeltaLength+1 - compEntry:= item - ----94/11/07 - -- WAS: compOrCroak(item,$EmptyMode,$e).expr - RPLACA(saveNRTdeltaListComp,compEntry) - saveIndex - -optDeltaEntry(op,sig,dc,eltOrConst) == - return nil --------> kill it - $killOptimizeIfTrue = true => nil - ndc := - dc = '$ => $functorForm - atom dc and (dcval := get(dc,'value,$e)) => dcval.expr - dc ---if (atom dc) and (dcval := get(dc,'value,$e)) --- then ndc := dcval.expr --- else ndc := dc - sig := SUBST(ndc,dc,sig) - not MEMQ(KAR ndc,$optimizableConstructorNames) => nil - dcval := optCallEval ndc - -- MSUBST guarantees to use EQUAL testing - sig := MSUBST(devaluate dcval, ndc, sig) - if rest ndc then - for new in rest devaluate dcval for old in rest ndc repeat - sig := MSUBST(new,old,sig) - -- optCallEval sends (List X) to (LIst (Integer)) etc, - -- so we should make the same transformation - fn := compiledLookup(op,sig,dcval) - if null fn then - -- following code is to handle selectors like first, rest - nsig := [quoteSelector tt for tt in sig] where - quoteSelector(x) == - not(IDENTP x) => x - get(x,'value,$e) => x - x='$ => x - MKQ x - fn := compiledLookup(op,nsig,dcval) - if null fn then return nil - eltOrConst="CONST" => - hehe fn - [op] -----------> return just the op here --- ['XLAM,'ignore,MKQ SPADCALL fn] - GET(compileTimeBindingOf first fn,'SPADreplace) - -genDeltaEntry opMmPair == ---called from compApplyModemap ---$NRTdeltaLength=0.. always equals length of $NRTdeltaList - [.,[odc,:.],.] := opMmPair - --opModemapPair := SUBLIS($LocalDomainAlist,opMmPair) - [op,[dc,:sig],[.,cform:=[eltOrConst,:.]]] := opMmPair - if $profileCompiler = true then - profileRecord(dc,op,sig) --- markImport dc - eltOrConst = 'XLAM => cform - if eltOrConst = 'Subsumed then eltOrConst := 'ELT - -- following hack needed to invert Rep to $ substitution - if odc = 'Rep and cform is [.,.,osig] then sig:=osig - newimp := optDeltaEntry(op,sig,dc,eltOrConst) => newimp - setDifference(listOfBoundVars dc,$functorLocalParameters) ^= [] => - ['applyFun,['compiledLookupCheck,MKQ op, - mkList consSig(sig,dc),consDomainForm(dc,nil)]] - --if null atom dc then - -- sig := substitute('$,dc,sig) - -- cform := substitute('$,dc,cform) - opModemapPair := - [op,[dc,:[genDeltaSig x for x in sig]],['T,cform]] -- force pred to T - if null NRTassocIndex dc and dc ^= $NRTaddForm and - (MEMBER(dc,$functorLocalParameters) or null atom dc) then - --create "domain" entry to $NRTdeltaList - $NRTdeltaList:= [['domain,NRTaddInner dc,:dc],:$NRTdeltaList] - saveNRTdeltaListComp:= $NRTdeltaListComp:=[nil,:$NRTdeltaListComp] - $NRTdeltaLength := $NRTdeltaLength+1 - compEntry:= - dc - RPLACA(saveNRTdeltaListComp,compEntry) - chk(saveNRTdeltaListComp,102) - u := - [eltOrConst,'$,$NRTbase+$NRTdeltaLength-index] where index == - (n:= POSN1(opModemapPair,$NRTdeltaList)) => n + 1 - --n + 1 since $NRTdeltaLength is 1 too large - $NRTdeltaList:= [opModemapPair,:$NRTdeltaList] - $NRTdeltaListComp:=[nil,:$NRTdeltaListComp] - $NRTdeltaLength := $NRTdeltaLength+1 - 0 - u - ---====================================================================== --- From nruncomp.boot ---====================================================================== -parseIf t == - t isnt [p,a,b] => t - ifTran(parseTran p,parseTran a,parseTran b) where - ifTran(p,a,b) == - null($InteractiveMode) and p='true => a - null($InteractiveMode) and p='false => b - p is ['not,p'] => ifTran(p',b,a) - p is ['IF,p',a',b'] => ifTran(p',ifTran(a',COPY a,COPY b),ifTran(b',a,b)) - p is ['SEQ,:l,['exit,1,p']] => - ['SEQ,:l,['exit,1,ifTran(p',incExitLevel a,incExitLevel b)]] - --this assumes that l has no exits - a is ['IF, =p,a',.] => ['IF,p,a',b] - b is ['IF, =p,.,b'] => ['IF,p,a,b'] --- makeSimplePredicateOrNil p is ['SEQ,:s,['exit,1,val]] => --- parseTran ['SEQ,:s,['exit,1,incExitLevel ['IF,val,a,b]]] - ['IF,p,a,b] - ---====================================================================== --- From parse.boot ---====================================================================== -parseNot u == ['not,parseTran first u] - -makeSimplePredicateOrNil p == nil - ---====================================================================== --- From g-cndata.boot ---====================================================================== -mkUserConstructorAbbreviation(c,a,type) == - if $AnalyzeOnly or $convert2NewCompiler then - $abbreviationStack := [[type,a,:c],:$abbreviationStack] - if not atom c then c:= CAR c -- Existing constructors will be wrapped - constructorAbbreviationErrorCheck(c,a,type,'abbreviationError) - clearClams() - clearConstructorCache(c) - installConstructor(c,type) - setAutoLoadProperty(c) - ---====================================================================== --- From iterator.boot ---====================================================================== - -compreduce(form is [.,op,x],m,e) == - T := compForm(form,m,e) or return nil - y := T.expr - RPLACA(y,"REDUCE") - ------------------<== distinquish this as the special reduce form - (y is ["REDUCE",:.]) and (id:= getIdentity(op,e)) and (u := comp0(id,m,e)) and - # getNumberTypesInScope() > 1 => markSimpleReduce([:y, ["@",u.expr,m]], T) - T - -compReduce1(form is ["REDUCE",op,.,collectForm],m,e,$formalArgList) == --------------------------------> 11/28 all new to preserve collect forms - markImport m - [collectOp,:itl,body]:= collectForm - $e:= e - itl:= [([.,$e]:= compIterator(x,$e) or return "failed").(0) for x in itl] - itl="failed" => return nil - e:= $e - T0 := comp0(body,m,e) or return nil - md := T0.mode - T1 := compOrCroak(collectForm,["List",md],e) - T := [["REDUCE",op,nil,T1.expr],md,T1.env] - markReduce(form,T) - -compIterator(it,e) == - it is ["IN",x,y] => - --these two lines must be in this order, to get "for f in list f" - --to give an error message if f is undefined - ---------------> new <--------------------- - [y',m,e] := markInValue(y, e) - x := markKillAll x - ------------------ - $formalArgList:= [x,:$formalArgList] - [.,mUnder]:= - modeIsAggregateOf("List",m,e) or modeIsAggregateOf("Vector",m,e) or return - stackMessage ["mode: ",m," must be a list or vector of some mode"] - if null get(x,"mode",e) then [.,.,e]:= - compMakeDeclaration([":",x,mUnder],$EmptyMode,e) or return nil - e:= put(x,"value",[genSomeVariable(),mUnder,e],e) - markReduceIn(it, [["IN",x,y'],e]) - it is ["ON",x,y] => ----------------> new <--------------------- - x := markKillAll x - ------------------ - $formalArgList:= [x,:$formalArgList] - y := markKillAll y - markImport m ----------------> new <--------------------- - [y',m,e]:= comp(y,$EmptyMode,e) or return nil - [.,mUnder]:= - modeIsAggregateOf("List",m,e) or return - stackMessage ["mode: ",m," must be a list of other modes"] - if null get(x,"mode",e) then [.,.,e]:= - compMakeDeclaration([":",x,m],$EmptyMode,e) or return nil - e:= put(x,"value",[genSomeVariable(),m,e],e) - [["ON",x,y'],e] - it is ["STEP",oindex,start,inc,:optFinal] => - index := markKillAll oindex - $formalArgList:= [index,:$formalArgList] - --if all start/inc/end compile as small integers, then loop - --is compiled as a small integer loop - final':= nil ----------------> new <--------------------- - u := smallIntegerStep(it,index,start,inc,optFinal,e) => u ----------------> new <--------------------- - [start,.,e]:= - comp(markKillAll start,$Integer,e) or return - stackMessage ["start value of index: ",start," must be an integer"] - [inc,.,e]:= - comp(markKillAll inc,$Integer,e) or return - stackMessage ["index increment:",inc," must be an integer"] - if optFinal is [final] then - [final,.,e]:= - comp(markKillAll final,$Integer,e) or return - stackMessage ["final value of index: ",final," must be an integer"] - optFinal:= [final] - indexmode:= - comp(CADDR it,$NonNegativeInteger,e) => $NonNegativeInteger - $Integer --- markImport ['Segment,indexmode] - if null get(index,"mode",e) then [.,.,e]:= - compMakeDeclaration([":",index,indexmode],$EmptyMode,e) or return nil - e:= put(index,"value",[genSomeVariable(),indexmode,e],e) - markReduceStep(it, [["STEP",markStep(index),start,inc,:optFinal],e]) - it is ["WHILE",p] => - [p',m,e]:= - comp(p,$Boolean,e) or return - stackMessage ["WHILE operand: ",p," is not Boolean valued"] - markReduceWhile(it, [["WHILE",p'],e]) - it is ["UNTIL",p] => markReduceUntil(it, ($until:= p; ['$until,e])) - it is ["|",x] => - u:= - comp(x,$Boolean,e) or return - stackMessage ["SUCHTHAT operand: ",x," is not Boolean value"] - markReduceSuchthat(it, [["|",u.expr],u.env]) - nil - -smallIntegerStep(it,index,start,inc,optFinal,e) == - start := markKillAll start - inc := markKillAll inc - optFinal := markKillAll optFinal - startNum := source2Number start - incNum := source2Number inc - mode := get(index,"mode",e) ---fail if -----> a) index has a mode that is not $SmallInteger -----> b) one of start,inc, final won't comp as a $SmallInteger - mode and mode ^= $SmallInteger => nil - null (start':= comp(start,$SmallInteger,e)) => nil - null (inc':= comp(inc,$SmallInteger,start'.env)) => nil - if optFinal is [final] and not (final':= comp(final,$SmallInteger,inc'.env)) then --- not (FIXP startNum and FIXP incNum) => return nil --- null FIXP startNum or ABSVAL startNum > 100 => return nil - -----> assume that optFinal is $SmallInteger - T := comp(final,$EmptyMode,inc'.env) or return nil - final' := T - maxSuperType(T.mode,e) ^= $Integer => return nil - givenRange := T.mode - indexmode:= $SmallInteger - [.,.,e]:= compMakeDeclaration([":",index,indexmode],$EmptyMode, - (final' => final'.env; inc'.env)) or return nil - range := - FIXP startNum and FIXP incNum => - startNum > 0 and incNum > 0 => $PositiveInteger - startNum < 0 and incNum < 0 => $NegativeInteger - incNum > 0 => $NonNegativeInteger --startNum = 0 - $NonPositiveInteger - givenRange => givenRange - nil - e:= put(index,"range",range,e) - e:= put(index,"value",[genSomeVariable(),indexmode,e],e) - noptFinal := - final' => - [final'.expr] - nil - [markStepSI(it,["ISTEP",index,start'.expr,inc'.expr,:noptFinal]),e] - -source2Number n == - n := markKillAll n - n = $Zero => 0 - n = $One => 1 - n - -compRepeatOrCollect(form,m,e) == - fn(form,[m,:$exitModeStack],[#$exitModeStack,:$leaveLevelStack],$formalArgList - ,e) where - fn(form,$exitModeStack,$leaveLevelStack,$formalArgList,e) == - $until: local - [repeatOrCollect,:itl,body]:= form - itl':= - [([x',e]:= compIterator(x,e) or return "failed"; x') for x in itl] - itl'="failed" => nil - targetMode:= first $exitModeStack --- pp '"---------" --- pp targetMode - bodyMode:= - repeatOrCollect="COLLECT" => - targetMode = '$EmptyMode => '$EmptyMode - (u:=modeIsAggregateOf('List,targetMode,e)) => - CADR u - (u:=modeIsAggregateOf('Vector,targetMode,e)) => - repeatOrCollect:='COLLECTV - CADR u - stackMessage('"Invalid collect bodytype") - return nil - -- If we're doing a collect, and the type isn't conformable - -- then we've boobed. JHD 26.July.1990 - $NoValueMode - [body',m',e']:= T := - -- (m1:= listOrVectorElementMode targetMode) and comp(body,m1,e) or - compOrCroak(body,bodyMode,e) or return nil - markRepeatBody(body, T) - if $until then - [untilCode,.,e']:= comp($until,$Boolean,e') - itl':= substitute(["UNTIL",untilCode],'$until,itl') - form':= [repeatOrCollect,:itl',body'] - m'':= - repeatOrCollect="COLLECT" => - (u:=modeIsAggregateOf('List,targetMode,e)) => CAR u - ["List",m'] - repeatOrCollect="COLLECTV" => - (u:=modeIsAggregateOf('Vector,targetMode,e)) => CAR u - ["Vector",m'] - m' ---------> new <-------------- - markImport m'' ---------> new <-------------- - markRepeat(form,coerceExit([form',m'',e'],targetMode)) - -chaseInferences(origPred,$e) == - pred := markKillAll origPred - ----------------------------12/4/94 do this immediately - foo hasToInfo pred where - foo pred == - knownInfo pred => nil - $e:= actOnInfo(pred,$e) - pred:= infoToHas pred - for u in get("$Information","special",$e) repeat - u is ["COND",:l] => - for [ante,:conseq] in l repeat - ante=pred => [foo w for w in conseq] - ante is ["and",:ante'] and MEMBER(pred,ante') => - ante':= DELETE(pred,ante') - v':= - LENGTH ante'=1 => first ante' - ["and",:ante'] - v':= ["COND",[v',:conseq]] - MEMBER(v',get("$Information","special",$e)) => nil - $e:= - put("$Information","special",[v',: - get("$Information","special",$e)],$e) - nil - $e - ---====================================================================== --- doit Code ---====================================================================== -doIt(item,$predl) == - $GENNO: local:= 0 - $coerceList: local := nil - ---> - if item is ['PART,.,a] then item := a - ------------------------------------- - item is ['SEQ,:.] => doItSeq item - isDomainForm(item,$e) => doItDomain item - item is ['LET,:.] => doItLet item - item is [":",a,t] => [.,.,$e]:= - markDeclaredImport markKillAll t - compOrCroak(item,$EmptyMode,$e) - item is ['import,:doms] => - item := ['import,:(doms := markKillAll doms)] - for dom in doms repeat - sayBrightly ['" importing ",:formatUnabbreviated dom] - [.,.,$e] := compOrCroak(item,$EmptyMode,$e) - wiReplaceNode(item,'(PROGN),10) - 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,:.] => doItDef item - T:= compOrCroak(item,$EmptyMode,$e) => doItExpression(item,T) - true => cannotDo() - -holdIt item == item - -doItIf(item is [.,p,x,y],$predl,$e) == - olde:= $e - [p',.,$e]:= qt(19,comp(p,$Boolean,$e)) or userError ['"not a Boolean:",p] - oldFLP:=$functorLocalParameters - if x^="noBranch" then ---> new <----------------------- - qe(20,compSingleCapsuleItem(x,[p,:$predl],getSuccessEnvironment(markKillAll p,$e))) ----> new ----------- - 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,:REVERSE nils] - REVERSE ans - oldFLP:=$functorLocalParameters - if y^="noBranch" then ---> new <----------------------- - qe(21,compSingleCapsuleItem(y,[['not, p],:$predl],getInverseEnvironment(markKillAll p,olde))) ---> ----------- - y':=localExtras(oldFLP) - wiReplaceNode(item,["COND",[p',x,:x'],['(QUOTE T),y,:y']],12) - -doItSeq item == - ['SEQ,:l,['exit,1,x]] := item - RPLACA(item,"PROGN") - RPLACA(LASTNODE item,x) - for it1 in rest item repeat $e:= compSingleCapsuleItem(it1,$predl,$e) - -doItDomain item == - -- convert naked top level domains to import - u:= ['import, [first item,:rest item]] - markImport CADR u - stackWarning ["Use: import ", [first item,:rest item]] ---wiReplaceNode(item, u, 14) - RPLACA(item, first u) - RPLACD(item, rest u) - doIt(item,$predl) - -doItLet item == - qe(3,$e) - res := doItLet1 item - qe(4,$e) - res - -doItLet1 item == - ['LET,lhs,rhs,:.] := item - not (compOrCroak(item,$EmptyMode,$e) is [code,.,$e]) => - stackSemanticError(["cannot compile assigned value to",:bright lhs],nil) - qe(5,$e) - code := markKillAll code - not (code is ['LET,lhs',rhs',:.] and atom lhs') => - code is ["PROGN",:.] => - stackSemanticError(["multiple assignment ",item," not allowed"],nil) - wiReplaceNode(item, code, 24) - lhs:= lhs' - if not MEMBER(KAR rhs,$NonMentionableDomainNames) and - not MEMQ(lhs, $functorLocalParameters) then - $functorLocalParameters:= [:$functorLocalParameters,lhs] - if (rhs' := rhsOfLetIsDomainForm code) then - if isFunctor rhs' then - $functorsUsed:= insert(opOf rhs',$functorsUsed) - $packagesUsed:= insert([opOf rhs'],$packagesUsed) - $globalImportDefAlist := pp [[lhs, :rhs'],:$globalImportDefAlist] - 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] ---+ - qe(6,$e) - code is ['LET,:.] => - rhsCode:= rhs' - op := ($QuickCode => 'QSETREFV;'SETELT) - wiReplaceNode(item,[op,'$,NRTgetLocalIndexClear lhs,rhsCode], 16) - wiReplaceNode(item, code, 18) - -rhsOfLetIsDomainForm code == - code is ['LET,.,rhs',:.] => - isDomainForm(rhs',$e) => rhs' - isDomainForm(rhs' := markKillAll rhs',$e) => rhs' - false - false - -doItDef item == - ['DEF,[op,:.],:.] := item - body:= isMacro(item,$e) => $e:= put(op,'macro,body,$e) - [.,.,$e]:= t:= compOrCroak(item,$EmptyMode,$e) - chk(item,3) - RPLACA(item,"CodeDefine") - --Note that DescendCode, in CodeDefine, is looking for this - RPLACD(CADR item,[$signatureOfForm]) - chk(item,4) - --This is how the signature is updated for buildFunctor to recognise ---+ - functionPart:= ['dispatchFunction,t.expr] - wiReplaceNode(CDDR item,[functionPart], 20) - chk(item, 30) - -doItExpression(item,T) == - SETQ($ITEM,COPY item) - SETQ($T1,COPY T.expr) - chk(T.expr, 304) - u := markCapsuleExpression(item, T) - [code,.,$e]:= u - wiReplaceNode(item,code, 22) - -wiReplaceNode(node,ocode,key) == - ncode := CONS(first ocode, rest ocode) - code := replaceNodeInStructureBy(node,ncode) - SETQ($NODE,COPY node) - SETQ($NODE1, COPY first code) - SETQ($NODE2, COPY rest code) - RPLACA(node,first code) - RPLACD(node,rest code) - chk(code, key) - chk(node, key + 1) - -replaceNodeInStructureBy(node, x) == - $nodeCopy: local := [CAR node,:CDR node] - replaceNodeBy(node, x) - node - -replaceNodeBy(node, x) == - atom x => nil - for y in tails x | EQCAR(x,node) repeat RPLAC(CAR x, $nodeCopy) - nil - -chk(x,key) == fn(x,0,key) where fn(x,cnt,key) == - cnt > 10000 => - sayBrightly ["--> ", key, " <---"] - hahaha(key) - atom x => cnt - VECP x => systemError nil - for y in x repeat cnt := fn(y, cnt + 1, key) - cnt - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/wi2.lisp.pamphlet b/src/interp/wi2.lisp.pamphlet new file mode 100644 index 0000000..9881c23 --- /dev/null +++ b/src/interp/wi2.lisp.pamphlet @@ -0,0 +1,4593 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp wi2.lisp} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +<<*>>= +(IN-PACKAGE "BOOT" ) + +;compDefineFunctor1(df, m,$e,$prefix,$formalArgList) == +; ['DEF,form,signature,$functorSpecialCases,body] := df +; signature := markKillAll signature +; if NRTPARSE = true then +; [lineNumber,:$functorSpecialCases] := $functorSpecialCases +;-- 1. bind global variables +; $addForm: local +; $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] +; $DEFdepth : local := 0 --for conversion to new compiler 3/93 +; $capsuleStack : local := nil --for conversion to new compiler 3/93 +; $predicateStack:local := nil --for conversion to new compiler 3/93 +; $signatureStack:local := nil --for conversion to new compiler 3/93 +; $importStack : local := nil --for conversion to new compiler 3/93 +; $globalImportStack : local := nil --for conversion to new compiler 3/93 +; $globalDeclareStack : local := nil +; $globalImportDefAlist: local:= nil +; $localMacroStack : local := nil --for conversion to new compiler 3/93 +; $freeStack : local := nil --for conversion to new compiler 3/93 +; $domainLevelVariableList: local := nil--for conversion to new compiler 3/93 +; $localLoopVariables: local := nil +; $pathStack : local := nil +; $form: local +; $op: local +; $signature: local +; $functorTarget: local +; $Representation: local +; --Set in doIt, accessed in the compiler - compNoStacking +; $LocalDomainAlist: local --set in doIt, accessed in genDeltaEntry +; $LocalDomainAlist:= nil +; $functorForm: local +; $functorLocalParameters: local +; $CheckVectorList: local +; --prevents CheckVector from printing out same message twice +; $getDomainCode: local -- code for getting views +; $insideFunctorIfTrue: local:= true +; $functorsUsed: local --not currently used, finds dependent functors +; $setelt: local := +; $QuickCode = true => 'QSETREFV +; 'SETELT +; $TOP__LEVEL: local +; $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] +; $globalImportStack := +; [markKillAll x for x in rest $functorForm for typ in rest signature' +; | GETDATABASE(opOf typ,'CONSTRUCTORKIND) = 'category] +; 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 := 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 +; SETQ($myFunctorBody, body) --------> new <-------- +; T:= compFunctorBody(body,rettype,$e,parForm) +;---------------> new <--------------------- +; BOUNDP '$convert2NewCompiler and $convert2NewCompiler => +; return markFinish($originalBody,[$form,['Mapping,:signature'],T.env]) +;---------------> new <--------------------- +; -- 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) +; $insideFunctorIfTrue:= false +; if $LISPLIB then +; $lisplibKind:= +; $functorTarget is ["CATEGORY",key,:.] and key^="domain" => 'package +; 'domain +; $lisplibForm:= form +; modemap:= [[parForm,:parSignature],[true,op']] +; $lisplibModemap:= modemap +; 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 := getConstructorAbbreviation op' +; $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", +; ['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| + |$DEFdepth| |$capsuleStack| |$predicateStack| + |$signatureStack| |$importStack| |$globalImportStack| + |$globalDeclareStack| |$globalImportDefAlist| + |$localMacroStack| |$freeStack| |$domainLevelVariableList| + |$localLoopVariables| |$pathStack| |$form| |$op| + |$signature| |$functorTarget| |$Representation| + |$LocalDomainAlist| |$functorForm| |$CategoryFrame| + |$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| |body| |signature| |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| |ISTMP#1| |key| |modemap| |libFn|) + (DECLARE (SPECIAL + $LISPLIB $TOP_LEVEL |$CheckVectorList| |$DEFdepth| |$LocalDomainAlist| + |$NRTaddForm| |$NRTaddList| |$NRTattributeAlist| |$NRTbase| + |$NRTdeltaLength| |$NRTdeltaListComp| |$NRTdeltaList| + |$NRTdomainFormList| |$NRTloadTimeAlist| |$NRTslot1Info| + |$NRTslot1PredicateList| |$Representation| |$addForm| + |$attributesName| |$bootStrapMode| |$byteAddress| |$byteVec| + |$capsuleStack| |$compileOnlyCertainItems| |$condAlist| + |$convert2NewCompiler| |$domainLevelVariableList| |$domainShell| + |$form| |$freeStack| |$functionLocations| |$functionStats| + |$functorForm| |$functorLocalParameters| |$functorSpecialCases| + |$functorStats| |$functorTarget| |$functorsUsed| |$genFVar| + |$genSDVar| |$getDomainCode| |$globalDeclareStack| + |$globalImportDefAlist| |$globalImportStack| |$goGetList| + |$importStack| |$insideCategoryPackageIfTrue| |$insideFunctorIfTrue| + |$isOpPackageName| |$libFile| |$lisplibCategoriesExtended| + |$lisplibForm| |$lisplibFunctionLocations| |$lisplibKind| + |$lisplibMissingFunctions| |$lisplibModemap| |$lisplibOperationAlist| + |$lisplibSlot1| |$localLoopVariables| |$localMacroStack| + |$lookupFunction| |$mutableDomains| |$mutableDomain| |$myFunctorBody| + |$op| |$originalBody| |$pairlis| |$pathStack| |$predicateStack| + |$setelt| |$signatureStack| |$signature| |$template| |$uncondAlist| + |$viewNames|)) + + (RETURN + (SEQ (PROGN + (SPADLET |form| (CADR |df|)) + (SPADLET |signature| (CADDR |df|)) + (SPADLET |$functorSpecialCases| (CADDDR |df|)) + (SPADLET |body| (CAR (CDDDDR |df|))) + (SPADLET |signature| (|markKillAll| |signature|)) + (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 |$DEFdepth| 0) + (SPADLET |$capsuleStack| NIL) + (SPADLET |$predicateStack| NIL) + (SPADLET |$signatureStack| NIL) + (SPADLET |$importStack| NIL) + (SPADLET |$globalImportStack| NIL) + (SPADLET |$globalDeclareStack| NIL) + (SPADLET |$globalImportDefAlist| NIL) + (SPADLET |$localMacroStack| NIL) + (SPADLET |$freeStack| NIL) + (SPADLET |$domainLevelVariableList| NIL) + (SPADLET |$localLoopVariables| NIL) + (SPADLET |$pathStack| 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) + (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 (G166232) + (SPADLET G166232 NIL) + (RETURN + (DO ((G166238 |argl| (CDR G166238)) + (|a| NIL) + (G166239 |$FormalMapVariableList| + (CDR G166239)) + (|v| NIL)) + ((OR (ATOM G166238) + (PROGN + (SETQ |a| (CAR G166238)) + NIL) + (ATOM G166239) + (PROGN + (SETQ |v| (CAR G166239)) + NIL)) + (NREVERSE0 G166232)) + (SEQ (EXIT (SETQ G166232 + (CONS (CONS |a| |v|) G166232)))))))) + (SPADLET |$mutableDomain| + (OR (|isCategoryPackageName| |$op|) + (COND + ((BOUNDP '|$mutableDomains|) + (MEMQ |$op| |$mutableDomains|)) + ('T NIL)))) + (SPADLET |signature'| + (CONS (CAR |signature|) + (PROG (G166252) + (SPADLET G166252 NIL) + (RETURN + (DO ((G166257 |argl| (CDR G166257)) + (|a| NIL)) + ((OR (ATOM G166257) + (PROGN + (SETQ |a| (CAR G166257)) + NIL)) + (NREVERSE0 G166252)) + (SEQ (EXIT + (SETQ G166252 + (CONS + (|getArgumentModeOrMoan| |a| + |form| |$e|) + G166252))))))))) + (SPADLET |$functorForm| + (SPADLET |$form| (CONS |$op| |argl|))) + (SPADLET |$globalImportStack| + (PROG (G166269) + (SPADLET G166269 NIL) + (RETURN + (DO ((G166276 (CDR |$functorForm|) + (CDR G166276)) + (|x| NIL) + (G166277 (CDR |signature'|) + (CDR G166277)) + (|typ| NIL)) + ((OR (ATOM G166276) + (PROGN + (SETQ |x| (CAR G166276)) + NIL) + (ATOM G166277) + (PROGN + (SETQ |typ| (CAR G166277)) + NIL)) + (NREVERSE0 G166269)) + (SEQ (EXIT (COND + ((BOOT-EQUAL + (GETDATABASE (|opOf| |typ|) + 'CONSTRUCTORKIND) + '|category|) + (SETQ G166269 + (CONS (|markKillAll| |x|) + G166269)))))))))) + (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| (ELT |ds| 2)) + (SPADLET |$goGetList| NIL) + (SPADLET |$condAlist| NIL) + (SPADLET |$uncondAlist| NIL) + (SPADLET |$NRTslot1PredicateList| + (REMDUP (PROG (G166290) + (SPADLET G166290 NIL) + (RETURN + (DO ((G166295 |attributeList| + (CDR G166295)) + (|x| NIL)) + ((OR (ATOM G166295) + (PROGN + (SETQ |x| (CAR G166295)) + NIL)) + (NREVERSE0 G166290)) + (SEQ + (EXIT + (SETQ G166290 + (CONS (CADR |x|) G166290))))))))) + (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 ((G166304 |argl| (CDR G166304)) (|x| NIL)) + ((OR (ATOM G166304) + (PROGN (SETQ |x| (CAR G166304)) 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 (G166315) + (SPADLET G166315 NIL) + (RETURN + (DO + ((G166321 + (MAXINDEX |$domainShell|)) + (|i| 6 (+ |i| 1))) + ((> |i| G166321) + (NREVERSE0 G166315)) + (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 G166315 + (CONS NIL G166315))))))))))))) + (SPADLET |$functorLocalParameters| + (PROGN + (SPADLET |argPars| + (|makeFunctorArgumentParameters| + |argl| (CDR |signature'|) + (CAR |signature'|))) + |argl|)) + (SPADLET |op'| |$op|) + (SPADLET |rettype| (CAR |signature'|)) + (SETQ |$myFunctorBody| |body|) + (SPADLET T$ + (|compFunctorBody| |body| |rettype| |$e| + |parForm|)) + (COND + ((AND (BOUNDP '|$convert2NewCompiler|) + |$convert2NewCompiler|) + (RETURN + (|markFinish| |$originalBody| + (CONS |$form| + (CONS (CONS '|Mapping| |signature'|) + (CONS (CADDR T$) NIL)))))) + (|$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|) + (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|) + (SPADLET |modemap| + (CONS (CONS |parForm| |parSignature|) + (CONS (CONS 'T (CONS |op'| NIL)) + NIL))) + (SPADLET |$lisplibModemap| |modemap|) + (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| + (|getConstructorAbbreviation| |op'|)) + (SPADLET |$lookupFunction| + (|NRTgetLookupFunction| + |$functorForm| + (CADAR |$lisplibModemap|) + |$NRTaddForm|)) + (SPADLET |$byteAddress| 0) + (SPADLET |$byteVec| NIL) + (SPADLET |$NRTslot1PredicateList| + (PROG (G166329) + (SPADLET G166329 NIL) + (RETURN + (DO + ((G166334 + |$NRTslot1PredicateList| + (CDR G166334)) + (|x| NIL)) + ((OR (ATOM G166334) + (PROGN + (SETQ |x| (CAR G166334)) + NIL)) + (NREVERSE0 G166329)) + (SEQ + (EXIT + (SETQ G166329 + (CONS (|simpBool| |x|) + G166329)))))))) + (|rwriteLispForm| '|loadTimeStuff| + (CONS 'MAKEPROP + (CONS (MKQ |$op|) + (CONS ''|infovec| + (CONS (|getInfovecCode|) NIL))))))) + (SPADLET |$lisplibSlot1| |$NRTslot1Info|) + (SPADLET |$lisplibOperationAlist| + |operationAlist|) + (SPADLET |$lisplibMissingFunctions| + |$CheckVectorList|))) + (|lisplibWrite| (MAKESTRING "compilerInfo") + (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)))))))))) + +;makeFunctorArgumentParameters(argl,sigl,target) == +; $alternateViewList: local:= nil +; $forceAdd: local:= true +; $ConditionalOperators: local +; target := markKillAll target +; ("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 (G166637) + (SPADLET G166637 NIL) + (RETURN + (DO ((G166642 |l| (CDR G166642)) + (|y| NIL)) + ((OR (ATOM G166642) + (PROGN + (SETQ |y| (CAR G166642)) + NIL)) + G166637) + (SEQ (EXIT (SETQ G166637 + (|union| G166637 + (|makeFunctorArgumentParameters,findExtrasP| + |a| |y|)))))))))) + (IF (AND (PAIRP |x|) (EQ (QCAR |x|) 'OR) + (PROGN (SPADLET |l| (QCDR |x|)) 'T)) + (EXIT (PROG (G166648) + (SPADLET G166648 NIL) + (RETURN + (DO ((G166653 |l| (CDR G166653)) + (|y| NIL)) + ((OR (ATOM G166653) + (PROGN + (SETQ |y| (CAR G166653)) + NIL)) + G166648) + (SEQ (EXIT (SETQ G166648 + (|union| G166648 + (|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 (G166671) + (SPADLET G166671 NIL) + (RETURN + (DO ((G166676 |l| (CDR G166676)) + (|y| NIL)) + ((OR (ATOM G166676) + (PROGN + (SETQ |y| (CAR G166676)) + NIL)) + G166671) + (SEQ (EXIT (SETQ G166671 + (|union| G166671 + (|makeFunctorArgumentParameters,findExtras1| + |a| |y|)))))))))) + (IF (AND (PAIRP |x|) (EQ (QCAR |x|) 'OR) + (PROGN (SPADLET |l| (QCDR |x|)) 'T)) + (EXIT (PROG (G166682) + (SPADLET G166682 NIL) + (RETURN + (DO ((G166687 |l| (CDR G166687)) + (|y| NIL)) + ((OR (ATOM G166687) + (PROGN + (SETQ |y| (CAR G166687)) + NIL)) + G166682) + (SEQ (EXIT (SETQ G166682 + (|union| G166682 + (|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|) + (declare (special |$CategoryFrame|)) + (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|) + (declare (special |$ConditionalOperators|)) + (RETURN + (SEQ (IF (NULL |ss|) (EXIT |s|)) + (DO ((G166720 |ss| (CDR G166720)) (|u| NIL)) + ((OR (ATOM G166720) + (PROGN (SETQ |u| (CAR G166720)) 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 (G166732) + (SPADLET G166732 NIL) + (RETURN + (DO ((G166737 |l| (CDR G166737)) + (|x| NIL)) + ((OR (ATOM G166737) + (PROGN + (SETQ |x| (CAR G166737)) + NIL)) + G166732) + (SEQ (EXIT (SETQ G166732 + (|union| G166732 + (|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 (G166743) + (SPADLET G166743 NIL) + (RETURN + (DO ((G166748 |l| (CDR G166748)) + (|x| NIL)) + ((OR (ATOM G166748) + (PROGN + (SETQ |x| (CAR G166748)) + NIL)) + G166743) + (SEQ (EXIT + (SETQ G166743 + (|union| G166743 + (|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) + (SPADLET |target| (|markKillAll| |target|)) + (PROG (G166764) + (SPADLET G166764 NIL) + (RETURN + (DO ((G166770 |argl| (CDR G166770)) (|a| NIL) + (G166771 |sigl| (CDR G166771)) (|s| NIL)) + ((OR (ATOM G166770) + (PROGN (SETQ |a| (CAR G166770)) NIL) + (ATOM G166771) + (PROGN (SETQ |s| (CAR G166771)) NIL)) + G166764) + (SEQ (EXIT (SETQ G166764 + (APPEND G166764 + (|makeFunctorArgumentParameters,fn| + |a| + (|makeFunctorArgumentParameters,augmentSig| + |s| + (|makeFunctorArgumentParameters,findExtras| + |a| |target|))))))))))))))) + +;compDefineCapsuleFunction(df,m,oldE,$prefix,$formalArgList) == +; ['DEF,form,originalSignature,specialCases,body] := df +; signature := markKillAll originalSignature +; $markFreeStack: local := nil --holds "free variables" +; $localImportStack : local := nil --local import stack for function +; $localDeclareStack: local := nil +; $localLoopVariables: local := nil +; originalDef := COPY df +; [lineNumber,:specialCases] := specialCases +; e := oldE +; --1. bind global variables +; $form: local +; $op: local +; $functionStats: local:= [0,0] +; $argumentConditionList: local +; $finalEnv: local +; --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] +;---------------------> new <--------------------------------- +; returnType := signature'.target +;-- trialT := returnType = "$" and get("Rep",'value,e) and comp(body,'Rep,e) +; trialT := returnType = "$" and comp(body,$EmptyMode,e) +; ------------------------------------------------------ 11/1/94 +; -- try comp-ing in $EmptyMode; if succeed +; -- if we succeed then trialT.mode = "$" or "Rep" +; -- do a coerce to get the correct result +; T := (trialT and coerce(trialT,returnType)) +; -------------------------------------- 11/1/94 +; or CATCH('compCapsuleBody, compOrCroak(body,returnType,e)) +; markChanges(originalDef,T,$signatureOfForm) +; [nil,['Mapping,:signature'],oldE] + +(DEFUN |compDefineCapsuleFunction| (|df| |m| |oldE| |$prefix| |$formalArgList|) + (DECLARE (SPECIAL |$prefix| |$formalArgList|)) + (PROG (|$markFreeStack| |$localImportStack| |$localDeclareStack| + |$localLoopVariables| |$form| |$op| |$functionStats| + |$argumentConditionList| |$finalEnv| + |$initCapsuleErrorCount| |$insideCapsuleFunctionIfTrue| + |$CapsuleModemapFrame| |$CapsuleDomainsInScope| + |$insideExpressionIfTrue| |form| |originalSignature| |body| + |signature| |originalDef| |LETTMP#1| |lineNumber| + |specialCases| |argl| |identSig| |argModeList| |signature'| + |e| |rettype| |ISTMP#1| |localOrExported| |formattedSig| + |returnType| |trialT| T$) + (DECLARE (SPECIAL |$markFreeStack| |$localImportStack| |$functionLocations| + |$localDeclareStack| |$localLoopVariables| + |$form| |$op| |$functionStats| |$profileCompiler| + |$argumentConditionList| |$finalEnv| |$returnMode| + |$initCapsuleErrorCount| |$compileOnlyCertainItems| + |$insideCapsuleFunctionIfTrue| |$EmptyMode| + |$CapsuleModemapFrame| |$CapsuleDomainsInScope| + |$insideExpressionIfTrue| |$signatureOfForm| + |$DomainsInScope| |$semanticErrorStack|)) + (RETURN + (SEQ (PROGN + (SPADLET |form| (CADR |df|)) + (SPADLET |originalSignature| (CADDR |df|)) + (SPADLET |specialCases| (CADDDR |df|)) + (SPADLET |body| (CAR (CDDDDR |df|))) + (SPADLET |signature| (|markKillAll| |originalSignature|)) + (SPADLET |$markFreeStack| NIL) + (SPADLET |$localImportStack| NIL) + (SPADLET |$localDeclareStack| NIL) + (SPADLET |$localLoopVariables| NIL) + (SPADLET |originalDef| (COPY |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 (G166821) + (SPADLET G166821 NIL) + (RETURN + (DO ((G166826 |argl| (CDR G166826)) + (|a| NIL)) + ((OR (ATOM G166826) + (PROGN + (SETQ |a| (CAR G166826)) + NIL)) + (NREVERSE0 G166821)) + (SEQ (EXIT + (SETQ G166821 + (CONS + (|getArgumentModeOrMoan| |a| + |form| |e|) + G166821)))))))))) + (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 ((G166836 |argl| (CDR G166836)) (|x| NIL) + (G166837 (CDR |signature'|) (CDR G166837)) + (|t| NIL)) + ((OR (ATOM G166836) + (PROGN (SETQ |x| (CAR G166836)) NIL) + (ATOM G166837) + (PROGN (SETQ |t| (CAR G166837)) NIL)) + NIL) + (SEQ (EXIT (|profileRecord| '|arguments| |x| |t|)))))) + (DO ((G166849 |signature'| (CDR G166849)) + (|domain| NIL)) + ((OR (ATOM G166849) + (PROGN (SETQ |domain| (CAR G166849)) 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|))))) + (SPADLET |returnType| (CAR |signature'|)) + (SPADLET |trialT| + (AND (BOOT-EQUAL |returnType| '$) + (|comp| |body| |$EmptyMode| |e|))) + (SPADLET T$ + (OR (AND |trialT| + (|coerce| |trialT| |returnType|)) + (CATCH '|compCapsuleBody| + (|compOrCroak| |body| |returnType| |e|)))) + (|markChanges| |originalDef| T$ |$signatureOfForm|) + (CONS NIL + (CONS (CONS '|Mapping| |signature'|) + (CONS |oldE| 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) +; BOUNDP '$convert2NewCompiler and $convert2NewCompiler => +; [nil,m,e] --nonsense but that's fine +; 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|) + (declare (special |$getDomainCode| |$signature| |$form| |$addForm| + |$insideCategoryPackageIfTrue| |$insideCategoryIfTrue| + |$functorLocalParameters| |$convert2NewCompiler|)) + (RETURN + (PROGN + (SPADLET |e| (|addInformation| |m| |e|)) + (SPADLET |data| (CONS 'PROGN |itemList|)) + (SPADLET |e| (|compCapsuleItems| |itemList| NIL |e|)) + (COND + ((AND (BOUNDP '|$convert2NewCompiler|) + |$convert2NewCompiler|) + (CONS NIL (CONS |m| (CONS |e| NIL)))) + ('T (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))))))))) + +;compSingleCapsuleItem(item,$predl,$e) == +; $localImportStack : local := nil +; $localDeclareStack: local := nil +; $markFreeStack: local := nil +; newItem := macroExpandInPlace(item,qe(25,$e)) +; qe(26,$e) +; doIt(newItem, $predl) +; qe(27,$e) +; $e + +(DEFUN |compSingleCapsuleItem| (|item| |$predl| |$e|) + (DECLARE (SPECIAL |$predl| |$e|)) + (PROG (|$localImportStack| |$localDeclareStack| |$markFreeStack| + |newItem|) + (DECLARE (SPECIAL |$localImportStack| |$localDeclareStack| + |$markFreeStack|)) + (RETURN + (PROGN + (SPADLET |$localImportStack| NIL) + (SPADLET |$localDeclareStack| NIL) + (SPADLET |$markFreeStack| NIL) + (SPADLET |newItem| + (|macroExpandInPlace| |item| (|qe| 25 |$e|))) + (|qe| 26 |$e|) + (|doIt| |newItem| |$predl|) + (|qe| 27 |$e|) + |$e|)))) + +;compImport(["import",:doms],m,e) == +; for dom in doms repeat +; dom := markKillAll dom +; markImport dom +; e:=addDomain(dom,e) +; ["/throwAway",$NoValueMode,e] + +(DEFUN |compImport| (G166966 |m| |e|) + (declare (ignore |m|)) + (PROG (|doms|) + (declare (special |$NoValueMode|)) + (RETURN + (SEQ (PROGN + (COND ((EQ (CAR G166966) '|import|) (CAR G166966))) + (SPADLET |doms| (CDR G166966)) + (DO ((G166981 |doms| (CDR G166981)) (|dom| NIL)) + ((OR (ATOM G166981) + (PROGN (SETQ |dom| (CAR G166981)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |dom| (|markKillAll| |dom|)) + (|markImport| |dom|) + (SPADLET |e| (|addDomain| |dom| |e|)))))) + (CONS '|/throwAway| (CONS |$NoValueMode| (CONS |e| NIL)))))))) + +;mkUnion(a,b) == +; b="$" and $Rep is ["Union",:l] => b +; a is ["Union",:l] => +; b is ["Union",:l'] => ["Union",:setUnion(l,l')] +; MEMBER(b, l) => a +; ["Union",:setUnion([b],l)] +; b is ["Union",:l] => +; MEMBER(a, l) => b +; ["Union",:setUnion([a],l)] +; STRINGP a => ["Union",b,a] +; ["Union",a,b] + +(DEFUN |mkUnion| (|a| |b|) + (PROG (|l'| |l|) + (declare (special |$Rep|)) + (RETURN + (COND + ((AND (BOOT-EQUAL |b| '$) (PAIRP |$Rep|) + (EQ (QCAR |$Rep|) '|Union|) + (PROGN (SPADLET |l| (QCDR |$Rep|)) 'T)) + |b|) + ((AND (PAIRP |a|) (EQ (QCAR |a|) '|Union|) + (PROGN (SPADLET |l| (QCDR |a|)) 'T)) + (COND + ((AND (PAIRP |b|) (EQ (QCAR |b|) '|Union|) + (PROGN (SPADLET |l'| (QCDR |b|)) 'T)) + (CONS '|Union| (|union| |l| |l'|))) + ((|member| |b| |l|) |a|) + ('T (CONS '|Union| (|union| (CONS |b| NIL) |l|))))) + ((AND (PAIRP |b|) (EQ (QCAR |b|) '|Union|) + (PROGN (SPADLET |l| (QCDR |b|)) 'T)) + (COND + ((|member| |a| |l|) |b|) + ('T (CONS '|Union| (|union| (CONS |a| NIL) |l|))))) + ((STRINGP |a|) (CONS '|Union| (CONS |b| (CONS |a| NIL)))) + ('T (CONS '|Union| (CONS |a| (CONS |b| NIL)))))))) + +;compForMode(x,m,e) == +; $compForModeIfTrue: local:= true +; $convert2NewCompiler: local := nil +; comp(x,m,e) + +(DEFUN |compForMode| (|x| |m| |e|) + (PROG (|$compForModeIfTrue| |$convert2NewCompiler|) + (DECLARE (SPECIAL |$compForModeIfTrue| |$convert2NewCompiler|)) + (RETURN + (PROGN + (SPADLET |$compForModeIfTrue| 'T) + (SPADLET |$convert2NewCompiler| NIL) + (|comp| |x| |m| |e|))))) + +;compMakeCategoryObject(c,$e) == +; not isCategoryForm(c,$e) => nil +; c := markKillAll c +; u:= mkEvalableCategoryForm c => [eval markKillAll u,$Category,$e] +; nil + +(DEFUN |compMakeCategoryObject| (|c| |$e|) + (DECLARE (SPECIAL |$e|)) + (PROG (|u|) + (declare (special |$Category|)) + (RETURN + (COND + ((NULL (|isCategoryForm| |c| |$e|)) NIL) + ('T (SPADLET |c| (|markKillAll| |c|)) + (COND + ((SPADLET |u| (|mkEvalableCategoryForm| |c|)) + (CONS (|eval| (|markKillAll| |u|)) + (CONS |$Category| (CONS |$e| NIL)))) + ('T NIL))))))) + +;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)] +; x is ['MI,a,b] => +; ['MI,a,macroExpand(b,e)] +; macroExpandList(x,e) + +(DEFUN |macroExpand| (|x| |e|) + (PROG (|u| |lhs| |sig| |ISTMP#3| |spCases| |ISTMP#4| |rhs| |ISTMP#1| + |a| |ISTMP#2| |b|) + (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)))))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'MI) + (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 'MI (CONS |a| (CONS (|macroExpand| |b| |e|) NIL)))) + ('T (|macroExpandList| |x| |e|)))))) + +;getSuccessEnvironment(a,e) == +; -- the next four lines try to ensure that explicit special-case tests +; -- prevent implicit ones from being generated +; a is ["has",x,m] => +; x := unLet x +; IDENTP x and isDomainForm(m,$EmptyEnvironment) => put(x,"specialCase",m,e) +; e +; a is ["is",id,m] => +; id := unLet id +; IDENTP id and isDomainForm(m,$EmptyEnvironment) => +; e:=put(id,"specialCase",m,e) +; currentProplist:= getProplist(id,e) +; [.,.,e] := T := comp(m,$EmptyMode,e) or return nil -- duplicates compIs +; newProplist:= consProplistOf(id,currentProplist,"value",removeEnv T) +; addBinding(id,newProplist,e) +; e +; a is ["case",x,m] and (x := unLet x) and IDENTP x => +; put(x,"condition",[a,:get(x,"condition",e)],e) +; e + +(DEFUN |getSuccessEnvironment| (|a| |e|) + (PROG (|id| |currentProplist| T$ |newProplist| |ISTMP#1| |ISTMP#2| |m| |x|) + (declare (special |$EmptyMode| |$EmptyEnvironment|)) + (RETURN + (COND + ((AND (PAIRP |a|) (EQ (QCAR |a|) '|has|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |x| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |m| (QCAR |ISTMP#2|)) 'T)))))) + (SPADLET |x| (|unLet| |x|)) + (COND + ((AND (IDENTP |x|) (|isDomainForm| |m| |$EmptyEnvironment|)) + (|put| |x| '|specialCase| |m| |e|)) + ('T |e|))) + ((AND (PAIRP |a|) (EQ (QCAR |a|) '|is|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |id| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |m| (QCAR |ISTMP#2|)) 'T)))))) + (SPADLET |id| (|unLet| |id|)) + (COND + ((AND (IDENTP |id|) + (|isDomainForm| |m| |$EmptyEnvironment|)) + (SPADLET |e| (|put| |id| '|specialCase| |m| |e|)) + (SPADLET |currentProplist| (|getProplist| |id| |e|)) + (SPADLET T$ + (OR (|comp| |m| |$EmptyMode| |e|) (RETURN NIL))) + (SPADLET |e| (CADDR T$)) + (SPADLET |newProplist| + (|consProplistOf| |id| |currentProplist| '|value| + (|removeEnv| T$))) + (|addBinding| |id| |newProplist| |e|)) + ('T |e|))) + ((AND (PAIRP |a|) (EQ (QCAR |a|) '|case|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |x| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |m| (QCAR |ISTMP#2|)) 'T))))) + (SPADLET |x| (|unLet| |x|)) (IDENTP |x|)) + (|put| |x| '|condition| + (CONS |a| (|get| |x| '|condition| |e|)) |e|)) + ('T |e|))))) + +;getInverseEnvironment(a,E) == +; atom a => E +; [op,:argl]:= a +;-- the next five lines try to ensure that explicit special-case tests +;-- prevent implicit ones from being generated +; op="has" => +; [x,m]:= argl +; x := unLet x +; IDENTP x and isDomainForm(m,$EmptyEnvironment) => put(x,"specialCase",m,E) +; E +; a is ["case",x,m] and (x := unLet x) and IDENTP x => +; --the next two lines are necessary to get 3-branched Unions to work +; -- old-style unions, that is +; if corrupted? get(x,"condition",E) then systemError 'condition +; (get(x,"condition",E) is [["OR",:oldpred]]) and MEMBER(a,oldpred) => +; put(x,"condition",LIST MKPF(DELETE(a,oldpred),"OR"),E) +; getUnionMode(x,E) is ["Union",:l] or systemError 'Union +; if corrupted? l then systemError 'list +; l':= DELETE(m,l) +; for u in l' repeat +; if u is ['_:,=m,:.] then l':=DELETE(u,l') +; newpred:= MKPF([["case",x,m'] for m' in l'],"OR") +; put(x,"condition",[newpred,:get(x,"condition",E)],E) +; E + +(DEFUN |getInverseEnvironment| (|a| E) + (PROG (|op| |argl| |m| |x| |ISTMP#2| |oldpred| |l| |ISTMP#1| |l'| + |newpred|) + (declare (special |$EmptyEnvironment|)) + (RETURN + (SEQ (COND + ((ATOM |a|) E) + ('T (SPADLET |op| (CAR |a|)) (SPADLET |argl| (CDR |a|)) + (COND + ((BOOT-EQUAL |op| '|has|) (SPADLET |x| (CAR |argl|)) + (SPADLET |m| (CADR |argl|)) + (SPADLET |x| (|unLet| |x|)) + (COND + ((AND (IDENTP |x|) + (|isDomainForm| |m| |$EmptyEnvironment|)) + (|put| |x| '|specialCase| |m| E)) + ('T E))) + ((AND (PAIRP |a|) (EQ (QCAR |a|) '|case|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |x| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |m| (QCAR |ISTMP#2|)) + 'T))))) + (SPADLET |x| (|unLet| |x|)) (IDENTP |x|)) + (COND + ((|corrupted?| (|get| |x| '|condition| E)) + (|systemError| '|condition|))) + (COND + ((AND (PROGN + (SPADLET |ISTMP#1| + (|get| |x| '|condition| E)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCAR |ISTMP#2|) 'OR) + (PROGN + (SPADLET |oldpred| + (QCDR |ISTMP#2|)) + 'T))))) + (|member| |a| |oldpred|)) + (|put| |x| '|condition| + (LIST (MKPF (|delete| |a| |oldpred|) 'OR)) + E)) + ('T + (OR (PROGN + (SPADLET |ISTMP#1| (|getUnionMode| |x| E)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|Union|) + (PROGN + (SPADLET |l| (QCDR |ISTMP#1|)) + 'T))) + (|systemError| '|Union|)) + (COND + ((|corrupted?| |l|) (|systemError| '|list|))) + (SPADLET |l'| (|delete| |m| |l|)) + (DO ((G167238 |l'| (CDR G167238)) (|u| NIL)) + ((OR (ATOM G167238) + (PROGN (SETQ |u| (CAR G167238)) NIL)) + NIL) + (SEQ (EXIT (COND + ((AND (PAIRP |u|) + (EQ (QCAR |u|) '|:|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |u|)) + (AND (PAIRP |ISTMP#1|) + (EQUAL (QCAR |ISTMP#1|) |m|)))) + (SPADLET |l'| (|delete| |u| |l'|))) + ('T NIL))))) + (SPADLET |newpred| + (MKPF (PROG (G167248) + (SPADLET G167248 NIL) + (RETURN + (DO + ((G167253 |l'| + (CDR G167253)) + (|m'| NIL)) + ((OR (ATOM G167253) + (PROGN + (SETQ |m'| (CAR G167253)) + NIL)) + (NREVERSE0 G167248)) + (SEQ + (EXIT + (SETQ G167248 + (CONS + (CONS '|case| + (CONS |x| + (CONS |m'| NIL))) + G167248))))))) + 'OR)) + (|put| |x| '|condition| + (CONS |newpred| (|get| |x| '|condition| E)) + E)))) + ('T E)))))))) + +;unLet x == +; x is ['LET,u,:.] => unLet u +; x + +(DEFUN |unLet| (|x|) + (PROG (|ISTMP#1| |u|) + (RETURN + (COND + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'LET) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN (SPADLET |u| (QCAR |ISTMP#1|)) 'T)))) + (|unLet| |u|)) + ('T |x|))))) + +;corrupted? u == +; u is [op,:r] => +; MEMQ(op,'(WI MI PART)) => true +; or/[corrupted? x for x in r] +; false + +(DEFUN |corrupted?| (|u|) + (PROG (|op| |r|) + (RETURN + (SEQ (COND + ((AND (PAIRP |u|) + (PROGN + (SPADLET |op| (QCAR |u|)) + (SPADLET |r| (QCDR |u|)) + 'T)) + (COND + ((MEMQ |op| '(WI MI PART)) 'T) + ('T + (PROG (G167297) + (SPADLET G167297 NIL) + (RETURN + (DO ((G167303 NIL G167297) + (G167304 |r| (CDR G167304)) (|x| NIL)) + ((OR G167303 (ATOM G167304) + (PROGN (SETQ |x| (CAR G167304)) NIL)) + G167297) + (SEQ (EXIT (SETQ G167297 + (OR G167297 + (|corrupted?| |x|))))))))))) + ('T NIL)))))) + +;--====================================================================== +;-- From apply.boot +;--====================================================================== +;applyMapping([op,:argl],m,e,ml) == +; #argl^=#ml-1 => nil +; isCategoryForm(first ml,e) => +; --is op a functor? +; pairlis:= [[v,:a] for a in argl for v in $FormalMapVariableList] +; ml' := SUBLIS(pairlis, ml) +; argl':= +; [T.expr for x in argl for m' in rest ml'] where +; T() == [.,.,e]:= comp(x,m',e) or return "failed" +; if argl'="failed" then return nil +; form:= [op,:argl'] +;---------------------> new <---------------------------- +; if constructor? op then form := markKillAll form +;---------------------> new <---------------------------- +; convert([form,first ml',e],m) +; argl':= +; [T.expr for x in argl for m' in rest ml] where +; T() == [.,.,e]:= comp(x,m',e) or return "failed" +; if argl'="failed" then return nil +; form:= +; not MEMBER(op,$formalArgList) and ATOM op and not get(op,'value,e) => +; nprefix := $prefix or +; -- following needed for referencing local funs at capsule level +; getAbbreviation($op,#rest $form) +; [op',:argl',"$"] where +; op':= INTERN STRCONC(encodeItem nprefix,";",encodeItem op) +; ['call,['applyFun,op],:argl'] +; pairlis:= [[v,:a] for a in argl' for v in $FormalMapVariableList] +; convert([form,SUBLIS(pairlis,first ml),e],m) + +(DEFUN |applyMapping| (G167341 |m| |e| |ml|) + (PROG (|op| |argl| |ml'| |LETTMP#1| |argl'| |nprefix| |op'| |form| + |pairlis|) + (declare (special |$FormalMapVariableList| |$form| |$op| |$prefix| + |$formalArgList|)) + (RETURN + (SEQ (PROGN + (SPADLET |op| (CAR G167341)) + (SPADLET |argl| (CDR G167341)) + (COND + ((NEQUAL (|#| |argl|) (SPADDIFFERENCE (|#| |ml|) 1)) + NIL) + ((|isCategoryForm| (CAR |ml|) |e|) + (SPADLET |pairlis| + (PROG (G167363) + (SPADLET G167363 NIL) + (RETURN + (DO ((G167369 |argl| (CDR G167369)) + (|a| NIL) + (G167370 |$FormalMapVariableList| + (CDR G167370)) + (|v| NIL)) + ((OR (ATOM G167369) + (PROGN + (SETQ |a| (CAR G167369)) + NIL) + (ATOM G167370) + (PROGN + (SETQ |v| (CAR G167370)) + NIL)) + (NREVERSE0 G167363)) + (SEQ (EXIT + (SETQ G167363 + (CONS (CONS |v| |a|) G167363)))))))) + (SPADLET |ml'| (SUBLIS |pairlis| |ml|)) + (SPADLET |argl'| + (PROG (G167387) + (SPADLET G167387 NIL) + (RETURN + (DO ((G167396 |argl| (CDR G167396)) + (|x| NIL) + (G167397 (CDR |ml'|) + (CDR G167397)) + (|m'| NIL)) + ((OR (ATOM G167396) + (PROGN + (SETQ |x| (CAR G167396)) + NIL) + (ATOM G167397) + (PROGN + (SETQ |m'| (CAR G167397)) + NIL)) + (NREVERSE0 G167387)) + (SEQ (EXIT + (SETQ G167387 + (CONS + (CAR + (PROGN + (SPADLET |LETTMP#1| + (OR (|comp| |x| |m'| |e|) + (RETURN '|failed|))) + (SPADLET |e| + (CADDR |LETTMP#1|)) + |LETTMP#1|)) + G167387)))))))) + (COND ((BOOT-EQUAL |argl'| '|failed|) (RETURN NIL))) + (SPADLET |form| (CONS |op| |argl'|)) + (COND + ((|constructor?| |op|) + (SPADLET |form| (|markKillAll| |form|)))) + (|convert| + (CONS |form| (CONS (CAR |ml'|) (CONS |e| NIL))) + |m|)) + ('T + (SPADLET |argl'| + (PROG (G167414) + (SPADLET G167414 NIL) + (RETURN + (DO ((G167423 |argl| (CDR G167423)) + (|x| NIL) + (G167424 (CDR |ml|) + (CDR G167424)) + (|m'| NIL)) + ((OR (ATOM G167423) + (PROGN + (SETQ |x| (CAR G167423)) + NIL) + (ATOM G167424) + (PROGN + (SETQ |m'| (CAR G167424)) + NIL)) + (NREVERSE0 G167414)) + (SEQ (EXIT + (SETQ G167414 + (CONS + (CAR + (PROGN + (SPADLET |LETTMP#1| + (OR (|comp| |x| |m'| |e|) + (RETURN '|failed|))) + (SPADLET |e| + (CADDR |LETTMP#1|)) + |LETTMP#1|)) + G167414)))))))) + (COND ((BOOT-EQUAL |argl'| '|failed|) (RETURN NIL))) + (SPADLET |form| + (COND + ((AND (NULL (|member| |op| |$formalArgList|)) + (ATOM |op|) + (NULL (|get| |op| '|value| |e|))) + (SPADLET |nprefix| + (OR |$prefix| + (|getAbbreviation| |$op| + (|#| (CDR |$form|))))) + (SPADLET |op'| + (INTERN + (STRCONC (|encodeItem| |nprefix|) + '|;| (|encodeItem| |op|)))) + (CONS |op'| (APPEND |argl'| (CONS '$ NIL)))) + ('T + (CONS '|call| + (CONS (CONS '|applyFun| + (CONS |op| NIL)) + |argl'|))))) + (SPADLET |pairlis| + (PROG (G167438) + (SPADLET G167438 NIL) + (RETURN + (DO ((G167444 |argl'| (CDR G167444)) + (|a| NIL) + (G167445 |$FormalMapVariableList| + (CDR G167445)) + (|v| NIL)) + ((OR (ATOM G167444) + (PROGN + (SETQ |a| (CAR G167444)) + NIL) + (ATOM G167445) + (PROGN + (SETQ |v| (CAR G167445)) + NIL)) + (NREVERSE0 G167438)) + (SEQ (EXIT + (SETQ G167438 + (CONS (CONS |v| |a|) G167438)))))))) + (|convert| + (CONS |form| + (CONS (SUBLIS |pairlis| (CAR |ml|)) + (CONS |e| NIL))) + |m|)))))))) + +;compFormWithModemap(form,m,e,modemap) == +; compFormWithModemap1(form,m,e,modemap,true) or compFormWithModemap1(form,m,e,modemap,false) + +(DEFUN |compFormWithModemap| (|form| |m| |e| |modemap|) + (OR (|compFormWithModemap1| |form| |m| |e| |modemap| 'T) + (|compFormWithModemap1| |form| |m| |e| |modemap| NIL))) + +;compFormWithModemap1(form,m,e,modemap,Rep2Dollar?) == +; [op,:argl] := form := markKillExpr form +; [[dc,:.],:.] := modemap +;----------> new: <----------- +; if Rep2Dollar? then +; if dc = 'Rep then +; modemap := SUBST('Rep,'_$,modemap) +; m := SUBST('Rep,'_$,m) +; else return nil +;----------> new: <----------- +; [map:= [.,target,:.],[pred,impl]]:= modemap +; -- this fails if the subsuming modemap is conditional +; --impl is ['Subsumed,:.] => nil +; if isCategoryForm(target,e) and isFunctor op then +; [modemap,e]:= substituteIntoFunctorModemap(argl,modemap,e) or return nil +; [map:= [.,target,:.],:cexpr]:= modemap +; sv:=listOfSharpVars map +; if sv then +; -- SAY [ "compiling ", op, " in compFormWithModemap, +; -- mode= ",map," sharp vars=",sv] +; for x in argl for ss in $FormalMapVariableList repeat +; if ss in sv then +; [map:= [.,target,:.],:cexpr]:= modemap :=SUBST(x,ss,modemap) +; -- SAY ["new map is",map] +; not (target':= coerceable(target,m,e)) => nil +; markMap := map +; map:= [target',:rest map] +; [f,Tl,sl]:= compApplyModemap(form,modemap,e,nil) or return nil +; +; --generate code; return +; T:= +; e':= +; Tl => (LAST Tl).env +; e +; [x',m',e'] where +; m':= SUBLIS(sl,map.(1)) +; x':= +; form':= [f,:[t.expr for t in Tl]] +; m'=$Category or isCategoryForm(m',e) => form' +; -- try to deal with new-style Unions where we know the conditions +; op = "elt" and f is ['XLAM,:.] and IDENTP(z:=CAR argl) and +; (c:=get(z,'condition,e)) and +; c is [['case,=z,c1]] and +; (c1 is ['_:,=(CADR argl),=m] or EQ(c1,CADR argl) ) => +;-- first is a full tag, as placed by getInverseEnvironment +;-- second is what getSuccessEnvironment will place there +; ["CDR",z] +; markTran(form,form',markMap,e') +; qt(18,T) +; convert(T,m) + +(DEFUN |compFormWithModemap1| (|form| |m| |e| |modemap| |Rep2Dollar?|) + (PROG (|op| |argl| |dc| |pred| |impl| |sv| |target| |cexpr| |target'| + |markMap| |map| |LETTMP#1| |f| |Tl| |sl| |e'| |m'| + |form'| |z| |c| |ISTMP#3| |c1| |ISTMP#1| |ISTMP#2| |x'| + T$) + (declare (special |$Category| |$FormalMapVariableList|)) + (RETURN + (SEQ (PROGN + (SPADLET |form| (|markKillExpr| |form|)) + (SPADLET |op| (CAR |form|)) + (SPADLET |argl| (CDR |form|)) + (SPADLET |dc| (CAAR |modemap|)) + (COND + (|Rep2Dollar?| + (COND + ((BOOT-EQUAL |dc| '|Rep|) + (SPADLET |modemap| (MSUBST '|Rep| '$ |modemap|)) + (SPADLET |m| (MSUBST '|Rep| '$ |m|))) + ('T (RETURN NIL))))) + (SPADLET |map| (CAR |modemap|)) + (SPADLET |target| (CADAR |modemap|)) + (SPADLET |pred| (CAADR |modemap|)) + (SPADLET |impl| (CADADR |modemap|)) + (COND + ((AND (|isCategoryForm| |target| |e|) + (|isFunctor| |op|)) + (SPADLET |LETTMP#1| + (OR (|substituteIntoFunctorModemap| |argl| + |modemap| |e|) + (RETURN NIL))) + (SPADLET |modemap| (CAR |LETTMP#1|)) + (SPADLET |e| (CADR |LETTMP#1|)) + (SPADLET |map| (CAR |modemap|)) + (SPADLET |target| (CADAR |modemap|)) + (SPADLET |cexpr| (CDR |modemap|)) |modemap|)) + (SPADLET |sv| (|listOfSharpVars| |map|)) + (COND + (|sv| (DO ((G167572 |argl| (CDR G167572)) (|x| NIL) + (G167573 |$FormalMapVariableList| + (CDR G167573)) + (|ss| NIL)) + ((OR (ATOM G167572) + (PROGN (SETQ |x| (CAR G167572)) NIL) + (ATOM G167573) + (PROGN (SETQ |ss| (CAR G167573)) NIL)) + NIL) + (SEQ (EXIT (COND + ((|member| |ss| |sv|) + (SPADLET |modemap| + (MSUBST |x| |ss| |modemap|)) + (SPADLET |map| (CAR |modemap|)) + (SPADLET |target| + (CADAR |modemap|)) + (SPADLET |cexpr| (CDR |modemap|)) + |modemap|) + ('T NIL))))))) + (COND + ((NULL (SPADLET |target'| + (|coerceable| |target| |m| |e|))) + NIL) + ('T (SPADLET |markMap| |map|) + (SPADLET |map| (CONS |target'| (CDR |map|))) + (SPADLET |LETTMP#1| + (OR (|compApplyModemap| |form| |modemap| |e| + NIL) + (RETURN NIL))) + (SPADLET |f| (CAR |LETTMP#1|)) + (SPADLET |Tl| (CADR |LETTMP#1|)) + (SPADLET |sl| (CADDR |LETTMP#1|)) + (SPADLET T$ + (PROGN + (SPADLET |e'| + (COND + (|Tl| (CADDR (|last| |Tl|))) + ('T |e|))) + (SPADLET |m'| (SUBLIS |sl| (ELT |map| 1))) + (SPADLET |x'| + (PROGN + (SPADLET |form'| + (CONS |f| + (PROG (G167586) + (SPADLET G167586 NIL) + (RETURN + (DO + ((G167591 |Tl| + (CDR G167591)) + (|t| NIL)) + ((OR (ATOM G167591) + (PROGN + (SETQ |t| + (CAR G167591)) + NIL)) + (NREVERSE0 G167586)) + (SEQ + (EXIT + (SETQ G167586 + (CONS (CAR |t|) + G167586))))))))) + (COND + ((OR + (BOOT-EQUAL |m'| |$Category|) + (|isCategoryForm| |m'| |e|)) + |form'|) + ((AND (BOOT-EQUAL |op| '|elt|) + (PAIRP |f|) + (EQ (QCAR |f|) 'XLAM) + (IDENTP + (SPADLET |z| (CAR |argl|))) + (SPADLET |c| + (|get| |z| '|condition| |e|)) + (PAIRP |c|) + (EQ (QCDR |c|) NIL) + (PROGN + (SPADLET |ISTMP#1| + (QCAR |c|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) + '|case|) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQUAL (QCAR |ISTMP#2|) + |z|) + (PROGN + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND + (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) + NIL) + (PROGN + (SPADLET |c1| + (QCAR |ISTMP#3|)) + 'T))))))) + (OR + (AND (PAIRP |c1|) + (EQ (QCAR |c1|) '|:|) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |c1|)) + (AND (PAIRP |ISTMP#1|) + (EQUAL (QCAR |ISTMP#1|) + (CADR |argl|)) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) + NIL) + (EQUAL + (QCAR |ISTMP#2|) + |m|)))))) + (EQ |c1| (CADR |argl|)))) + (CONS 'CDR (CONS |z| NIL))) + ('T + (|markTran| |form| |form'| + |markMap| |e'|))))) + (CONS |x'| (CONS |m'| (CONS |e'| NIL))))) + (|qt| 18 T$) (|convert| T$ |m|)))))))) + +;convert(T,m) == +; tcheck T +; qe(23,T.env) +; coerce(T,resolve(T.mode,m) or return nil) + +(DEFUN |convert| (T$ |m|) + (PROG () + (RETURN + (PROGN + (|tcheck| T$) + (|qe| 23 (CADDR T$)) + (|coerce| T$ (OR (|resolve| (CADR T$) |m|) (RETURN NIL))))))) + +;compElt(origForm,m,E) == +; form := markKillAll origForm +; form isnt ["elt",aDomain,anOp] => compForm(origForm,m,E) +; aDomain="Lisp" => +; markLisp([anOp',m,E],E)where anOp'() == (anOp=$Zero => 0; anOp=$One => 1; anOp) +; isDomainForm(aDomain,E) => +; markImport opOf aDomain +; E:= addDomain(aDomain,E) +; mmList:= getModemapListFromDomain(anOp,0,aDomain,E) +; modemap:= +; n:=#mmList +; 1=n => mmList.(0) +; 0=n => +; return +; stackMessage ['"Operation ","%b",anOp,"%d", +; '"missing from domain: ", aDomain] +; stackWarning ['"more than 1 modemap for: ",anOp, +; '" with dc=",aDomain,'" ===>" +; ,mmList] +; mmList.(0) +;----------> new: <----------- +; if aDomain = 'Rep then +; modemap := SUBST('Rep,'_$,modemap) +; m := SUBST('Rep,'_$,m) +;----------> new: <----------- +; [sig,[pred,val]]:= modemap +; #sig^=2 and ^val is ["elt",:.] => nil --what does the second clause do ???? +;--+ +; val := genDeltaEntry [opOf anOp,:modemap] +; x := markTran(origForm,[val],sig,[E]) +; [x,first rest sig,E] --implies fn calls used to access constants +; compForm(origForm,m,E) + +(DEFUN |compElt| (|origForm| |m| E) + (PROG (|form| |ISTMP#1| |aDomain| |ISTMP#2| |anOp| |mmList| |n| + |modemap| |sig| |pred| |val| |x|) + (declare (special |$Zero| |$One|)) + (RETURN + (PROGN + (SPADLET |form| (|markKillAll| |origForm|)) + (COND + ((NULL (AND (PAIRP |form|) (EQ (QCAR |form|) '|elt|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |form|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |aDomain| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |anOp| (QCAR |ISTMP#2|)) + 'T))))))) + (|compForm| |origForm| |m| E)) + ((BOOT-EQUAL |aDomain| '|Lisp|) + (|markLisp| + (CONS (COND + ((BOOT-EQUAL |anOp| |$Zero|) 0) + ((BOOT-EQUAL |anOp| |$One|) 1) + ('T |anOp|)) + (CONS |m| (CONS E NIL))) + E)) + ((|isDomainForm| |aDomain| E) + (|markImport| (|opOf| |aDomain|)) + (SPADLET E (|addDomain| |aDomain| E)) + (SPADLET |mmList| + (|getModemapListFromDomain| |anOp| 0 |aDomain| E)) + (SPADLET |modemap| + (PROGN + (SPADLET |n| (|#| |mmList|)) + (COND + ((EQL 1 |n|) (ELT |mmList| 0)) + ((EQL 0 |n|) + (RETURN + (|stackMessage| + (CONS (MAKESTRING "Operation ") + (CONS '|%b| + (CONS |anOp| + (CONS '|%d| + (CONS + (MAKESTRING + "missing from domain: ") + (CONS |aDomain| NIL))))))))) + ('T + (|stackWarning| + (CONS (MAKESTRING + "more than 1 modemap for: ") + (CONS |anOp| + (CONS (MAKESTRING " with dc=") + (CONS |aDomain| + (CONS (MAKESTRING " ===>") + (CONS |mmList| NIL))))))) + (ELT |mmList| 0))))) + (COND + ((BOOT-EQUAL |aDomain| '|Rep|) + (SPADLET |modemap| (MSUBST '|Rep| '$ |modemap|)) + (SPADLET |m| (MSUBST '|Rep| '$ |m|)))) + (SPADLET |sig| (CAR |modemap|)) + (SPADLET |pred| (CAADR |modemap|)) + (SPADLET |val| (CADADR |modemap|)) + (COND + ((AND (NEQUAL (|#| |sig|) 2) + (NULL (AND (PAIRP |val|) (EQ (QCAR |val|) '|elt|)))) + NIL) + ('T + (SPADLET |val| + (|genDeltaEntry| + (CONS (|opOf| |anOp|) |modemap|))) + (SPADLET |x| + (|markTran| |origForm| (CONS |val| NIL) |sig| + (CONS E NIL))) + (CONS |x| (CONS (CAR (CDR |sig|)) (CONS E NIL)))))) + ('T (|compForm| |origForm| |m| E))))))) + +;pause op == op + +(DEFUN |pause| (|op|) |op|) + +;compApplyModemap(form,modemap,$e,sl) == +; [op,:argl] := form --form to be compiled +; [[mc,mr,:margl],:fnsel] := modemap --modemap we are testing +; +; -- $e is the current environment +; -- sl substitution list, nil means bottom-up, otherwise top-down +; +; -- 0. fail immediately if #argl=#margl +; +; if #argl^=#margl then return nil +; +; -- 1. use modemap to evaluate arguments, returning failed if +; -- not possible +; +; lt:= +; [[.,m',$e]:= +; comp(y,g,$e) or return "failed" where +; g:= SUBLIS(sl,m) where +; sl:= pmatchWithSl(m',m,sl) for y in argl for m in margl] +; lt="failed" => return nil +; +; -- 2. coerce each argument to final domain, returning failed +; -- if not possible +; +; lt':= [coerce(y,d) or return "failed" +; for y in lt for d in SUBLIS(sl,margl)] +; lt'="failed" => return nil +; +; -- 3. obtain domain-specific function, if possible, and return +; +; --$bindings is bound by compMapCond +; [f,$bindings]:= compMapCond(op,mc,sl,fnsel) or return nil +; +;--+ can no longer trust what the modemap says for a reference into +;--+ an exterior domain (it is calculating the displacement based on view +;--+ information which is no longer valid; thus ignore this index and +;--+ store the signature instead. +; +;--$NRTflag=true and f is [op1,d,.] and NE(d,'$) and MEMBER(op1,'(ELT CONST)) => +; f is [op1,d,.] and MEMBER(op1,'(ELT CONST Subsumed)) => +; [genDeltaEntry [op,:modemap],lt',$bindings] +; markImport mc +; [f,lt',$bindings] + +(DEFUN |compApplyModemap| (|form| |modemap| |$e| |sl|) + (DECLARE (SPECIAL |$e|)) + (PROG (|op| |argl| |mc| |mr| |margl| |fnsel| |g| |m'| |lt| |lt'| + |LETTMP#1| |f| |op1| |ISTMP#1| |d| |ISTMP#2|) + (declare (special |$bindings|)) + (RETURN + (SEQ (PROGN + (SPADLET |op| (CAR |form|)) + (SPADLET |argl| (CDR |form|)) + (SPADLET |mc| (CAAR |modemap|)) + (SPADLET |mr| (CADAR |modemap|)) + (SPADLET |margl| (CDDAR |modemap|)) + (SPADLET |fnsel| (CDR |modemap|)) + (COND ((NEQUAL (|#| |argl|) (|#| |margl|)) (RETURN NIL))) + (SPADLET |lt| + (PROG (G167753) + (SPADLET G167753 NIL) + (RETURN + (DO ((G167765 |argl| (CDR G167765)) + (|y| NIL) + (G167766 |margl| (CDR G167766)) + (|m| NIL)) + ((OR (ATOM G167765) + (PROGN + (SETQ |y| (CAR G167765)) + NIL) + (ATOM G167766) + (PROGN + (SETQ |m| (CAR G167766)) + NIL)) + (NREVERSE0 G167753)) + (SEQ (EXIT (SETQ G167753 + (CONS + (PROGN + (SPADLET |sl| + (|pmatchWithSl| |m'| |m| + |sl|)) + (SPADLET |g| + (SUBLIS |sl| |m|)) + (SPADLET |LETTMP#1| + (OR (|comp| |y| |g| |$e|) + (RETURN '|failed|))) + (SPADLET |m'| + (CADR |LETTMP#1|)) + (SPADLET |$e| + (CADDR |LETTMP#1|)) + |LETTMP#1|) + G167753)))))))) + (COND + ((BOOT-EQUAL |lt| '|failed|) (RETURN NIL)) + ('T + (SPADLET |lt'| + (PROG (G167780) + (SPADLET G167780 NIL) + (RETURN + (DO ((G167786 |lt| (CDR G167786)) + (|y| NIL) + (G167787 (SUBLIS |sl| |margl|) + (CDR G167787)) + (|d| NIL)) + ((OR (ATOM G167786) + (PROGN + (SETQ |y| (CAR G167786)) + NIL) + (ATOM G167787) + (PROGN + (SETQ |d| (CAR G167787)) + NIL)) + (NREVERSE0 G167780)) + (SEQ (EXIT + (SETQ G167780 + (CONS + (OR (|coerce| |y| |d|) + (RETURN '|failed|)) + G167780)))))))) + (COND + ((BOOT-EQUAL |lt'| '|failed|) (RETURN NIL)) + ('T + (SPADLET |LETTMP#1| + (OR (|compMapCond| |op| |mc| |sl| |fnsel|) + (RETURN NIL))) + (SPADLET |f| (CAR |LETTMP#1|)) + (SPADLET |$bindings| (CADR |LETTMP#1|)) + (COND + ((AND (PAIRP |f|) + (PROGN + (SPADLET |op1| (QCAR |f|)) + (SPADLET |ISTMP#1| (QCDR |f|)) + (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))))) + (|member| |op1| '(ELT CONST |Subsumed|))) + (CONS (|genDeltaEntry| (CONS |op| |modemap|)) + (CONS |lt'| (CONS |$bindings| NIL)))) + ('T (|markImport| |mc|) + (CONS |f| (CONS |lt'| (CONS |$bindings| NIL)))))))))))))) + +;compMapCond''(cexpr,dc) == +; cexpr=true => true +; --cexpr = "true" => true +;---------------> new <---------------------- +; cexpr is [op,:l] and MEMQ(op,'(_and AND)) => and/[compMapCond''(u,dc) for u in l] +; cexpr is [op,:l] and MEMQ(op,'(_or OR)) => or/[compMapCond''(u,dc) for u in l] +;---------------> new <---------------------- +; cexpr is ["not",u] => not compMapCond''(u,dc) +; cexpr is ["has",name,cat] => (knownInfo cexpr => true; false) +; --for the time being we'll stop here - shouldn't happen so far +; --$disregardConditionIfTrue => true +; --stackSemanticError(("not known that",'%b,name, +; -- '%d,"has",'%b,cat,'%d),nil) +; --now it must be an attribute +; MEMBER(["ATTRIBUTE",dc,cexpr],get("$Information","special",$e)) => true +; --for the time being we'll stop here - shouldn't happen so far +; stackMessage ["not known that",'%b,dc,'%d,"has",'%b,cexpr,'%d] +; false + +(DEFUN |compMapCond''| (|cexpr| |dc|) + (PROG (|op| |l| |u| |ISTMP#1| |name| |ISTMP#2| |cat|) + (declare (special |$e| |$Information|)) + (RETURN + (SEQ (COND + ((BOOT-EQUAL |cexpr| 'T) 'T) + ((AND (PAIRP |cexpr|) + (PROGN + (SPADLET |op| (QCAR |cexpr|)) + (SPADLET |l| (QCDR |cexpr|)) + 'T) + (MEMQ |op| '(|and| AND))) + (PROG (G167850) + (SPADLET G167850 'T) + (RETURN + (DO ((G167856 NIL (NULL G167850)) + (G167857 |l| (CDR G167857)) (|u| NIL)) + ((OR G167856 (ATOM G167857) + (PROGN (SETQ |u| (CAR G167857)) NIL)) + G167850) + (SEQ (EXIT (SETQ G167850 + (AND G167850 + (|compMapCond''| |u| |dc|))))))))) + ((AND (PAIRP |cexpr|) + (PROGN + (SPADLET |op| (QCAR |cexpr|)) + (SPADLET |l| (QCDR |cexpr|)) + 'T) + (MEMQ |op| '(|or| OR))) + (PROG (G167864) + (SPADLET G167864 NIL) + (RETURN + (DO ((G167870 NIL G167864) + (G167871 |l| (CDR G167871)) (|u| NIL)) + ((OR G167870 (ATOM G167871) + (PROGN (SETQ |u| (CAR G167871)) NIL)) + G167864) + (SEQ (EXIT (SETQ G167864 + (OR G167864 + (|compMapCond''| |u| |dc|))))))))) + ((AND (PAIRP |cexpr|) (EQ (QCAR |cexpr|) '|not|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |cexpr|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |u| (QCAR |ISTMP#1|)) 'T)))) + (NULL (|compMapCond''| |u| |dc|))) + ((AND (PAIRP |cexpr|) (EQ (QCAR |cexpr|) '|has|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |cexpr|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |name| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |cat| (QCAR |ISTMP#2|)) + 'T)))))) + (COND ((|knownInfo| |cexpr|) 'T) ('T NIL))) + ((|member| (CONS 'ATTRIBUTE + (CONS |dc| (CONS |cexpr| NIL))) + (|get| '|$Information| '|special| |$e|)) + 'T) + ('T + (|stackMessage| + (CONS '|not known that| + (CONS '|%b| + (CONS |dc| + (CONS '|%d| + (CONS '|has| + (CONS '|%b| + (CONS |cexpr| (CONS '|%d| NIL))))))))) + NIL)))))) + +;--====================================================================== +;-- From nruncomp.boot +;--====================================================================== +;NRTgetLocalIndex1(item,killBindingIfTrue) == +; k := NRTassocIndex item => k +; item = $NRTaddForm => 5 +; item = '$ => 0 +; item = '_$_$ => 2 +; value:= +; MEMQ(item,$formalArgList) => item +; nil +; atom item and null MEMQ(item,'($ _$_$)) +; and null value => --give slots to atoms +; $NRTdeltaList:= [['domain,NRTaddInner item,:value],:$NRTdeltaList] +; $NRTdeltaListComp:=[item,:$NRTdeltaListComp] +; $NRTdeltaLength := $NRTdeltaLength+1 +; $NRTbase + $NRTdeltaLength - 1 +; $NRTdeltaList:= [['domain,NRTaddInner item,:value],:$NRTdeltaList] +; saveNRTdeltaListComp:= $NRTdeltaListComp:=[nil,:$NRTdeltaListComp] +; saveIndex := $NRTbase + $NRTdeltaLength +; $NRTdeltaLength := $NRTdeltaLength+1 +; compEntry:= item +; ----94/11/07 +; -- WAS: compOrCroak(item,$EmptyMode,$e).expr +; RPLACA(saveNRTdeltaListComp,compEntry) +; saveIndex + +(DEFUN |NRTgetLocalIndex1| (|item| |killBindingIfTrue|) + (declare (ignore |killBindingIfTrue|)) + (PROG (|k| |value| |saveNRTdeltaListComp| |saveIndex| |compEntry|) + (declare (special |$NRTdeltaLength| |$NRTbase| |$NRTdeltaListComp| + |$NRTdeltaList| |$formalArgList| |$NRTaddForm|)) + (RETURN + (COND + ((SPADLET |k| (|NRTassocIndex| |item|)) |k|) + ((BOOT-EQUAL |item| |$NRTaddForm|) 5) + ((BOOT-EQUAL |item| '$) 0) + ((BOOT-EQUAL |item| '$$) 2) + ('T + (SPADLET |value| + (COND + ((MEMQ |item| |$formalArgList|) |item|) + ('T NIL))) + (COND + ((AND (ATOM |item|) (NULL (MEMQ |item| '($ $$))) + (NULL |value|)) + (SPADLET |$NRTdeltaList| + (CONS (CONS '|domain| + (CONS (|NRTaddInner| |item|) |value|)) + |$NRTdeltaList|)) + (SPADLET |$NRTdeltaListComp| + (CONS |item| |$NRTdeltaListComp|)) + (SPADLET |$NRTdeltaLength| (PLUS |$NRTdeltaLength| 1)) + (SPADDIFFERENCE (PLUS |$NRTbase| |$NRTdeltaLength|) 1)) + ('T + (SPADLET |$NRTdeltaList| + (CONS (CONS '|domain| + (CONS (|NRTaddInner| |item|) |value|)) + |$NRTdeltaList|)) + (SPADLET |saveNRTdeltaListComp| + (SPADLET |$NRTdeltaListComp| + (CONS NIL |$NRTdeltaListComp|))) + (SPADLET |saveIndex| (PLUS |$NRTbase| |$NRTdeltaLength|)) + (SPADLET |$NRTdeltaLength| (PLUS |$NRTdeltaLength| 1)) + (SPADLET |compEntry| |item|) + (RPLACA |saveNRTdeltaListComp| |compEntry|) |saveIndex|))))))) + +;optDeltaEntry(op,sig,dc,eltOrConst) == +; return nil --------> kill it +; $killOptimizeIfTrue = true => nil +; ndc := +; dc = '$ => $functorForm +; atom dc and (dcval := get(dc,'value,$e)) => dcval.expr +; dc +;--if (atom dc) and (dcval := get(dc,'value,$e)) +;-- then ndc := dcval.expr +;-- else ndc := dc +; sig := SUBST(ndc,dc,sig) +; not MEMQ(KAR ndc,$optimizableConstructorNames) => nil +; dcval := optCallEval ndc +; -- MSUBST guarantees to use EQUAL testing +; sig := MSUBST(devaluate dcval, ndc, sig) +; if rest ndc then +; for new in rest devaluate dcval for old in rest ndc repeat +; sig := MSUBST(new,old,sig) +; -- optCallEval sends (List X) to (LIst (Integer)) etc, +; -- so we should make the same transformation +; fn := compiledLookup(op,sig,dcval) +; if null fn then +; -- following code is to handle selectors like first, rest +; nsig := [quoteSelector tt for tt in sig] where +; quoteSelector(x) == +; not(IDENTP x) => x +; get(x,'value,$e) => x +; x='$ => x +; MKQ x +; fn := compiledLookup(op,nsig,dcval) +; if null fn then return nil +; eltOrConst="CONST" => +; hehe fn +; [op] -----------> return just the op here +;-- ['XLAM,'ignore,MKQ SPADCALL fn] +; GET(compileTimeBindingOf first fn,'SPADreplace) + +(DEFUN |optDeltaEntry,quoteSelector| (|x|) + (declare (special |$e|)) + (SEQ (IF (NULL (IDENTP |x|)) (EXIT |x|)) + (IF (|get| |x| '|value| |$e|) (EXIT |x|)) + (IF (BOOT-EQUAL |x| '$) (EXIT |x|)) (EXIT (MKQ |x|)))) + +(DEFUN |optDeltaEntry| (|op| |sig| |dc| |eltOrConst|) + (PROG (|ndc| |dcval| |nsig| |fn|) + (declare (special |$optimizableConstructorNames| |$e| |$functorForm| + |$killOptimizeIfTrue|)) + (RETURN + (SEQ (PROGN + (RETURN NIL) + (COND + ((BOOT-EQUAL |$killOptimizeIfTrue| 'T) NIL) + ('T + (SPADLET |ndc| + (COND + ((BOOT-EQUAL |dc| '$) |$functorForm|) + ((AND (ATOM |dc|) + (SPADLET |dcval| + (|get| |dc| '|value| |$e|))) + (CAR |dcval|)) + ('T |dc|))) + (SPADLET |sig| (MSUBST |ndc| |dc| |sig|)) + (COND + ((NULL (MEMQ (KAR |ndc|) + |$optimizableConstructorNames|)) + NIL) + ('T (SPADLET |dcval| (|optCallEval| |ndc|)) + (SPADLET |sig| + (MSUBST (|devaluate| |dcval|) |ndc| |sig|)) + (COND + ((CDR |ndc|) + (DO ((G167923 (CDR (|devaluate| |dcval|)) + (CDR G167923)) + (|new| NIL) + (G167924 (CDR |ndc|) (CDR G167924)) + (|old| NIL)) + ((OR (ATOM G167923) + (PROGN + (SETQ |new| (CAR G167923)) + NIL) + (ATOM G167924) + (PROGN + (SETQ |old| (CAR G167924)) + NIL)) + NIL) + (SEQ (EXIT (SPADLET |sig| + (MSUBST |new| |old| |sig|))))))) + (SPADLET |fn| (|compiledLookup| |op| |sig| |dcval|)) + (COND + ((NULL |fn|) + (SPADLET |nsig| + (PROG (G167937) + (SPADLET G167937 NIL) + (RETURN + (DO + ((G167942 |sig| (CDR G167942)) + (|tt| NIL)) + ((OR (ATOM G167942) + (PROGN + (SETQ |tt| (CAR G167942)) + NIL)) + (NREVERSE0 G167937)) + (SEQ + (EXIT + (SETQ G167937 + (CONS + (|optDeltaEntry,quoteSelector| + |tt|) + G167937)))))))) + (SPADLET |fn| + (|compiledLookup| |op| |nsig| |dcval|)) + (COND ((NULL |fn|) (RETURN NIL)) ('T NIL)))) + (COND + ((BOOT-EQUAL |eltOrConst| 'CONST) (|hehe| |fn|) + (CONS |op| NIL)) + ('T + (GETL (|compileTimeBindingOf| (CAR |fn|)) + '|SPADreplace|)))))))))))) + +;genDeltaEntry opMmPair == +;--called from compApplyModemap +;--$NRTdeltaLength=0.. always equals length of $NRTdeltaList +; [.,[odc,:.],.] := opMmPair +; --opModemapPair := SUBLIS($LocalDomainAlist,opMmPair) +; [op,[dc,:sig],[.,cform:=[eltOrConst,:.]]] := opMmPair +; if $profileCompiler = true then +; profileRecord(dc,op,sig) +;-- markImport dc +; eltOrConst = 'XLAM => cform +; if eltOrConst = 'Subsumed then eltOrConst := 'ELT +; -- following hack needed to invert Rep to $ substitution +; if odc = 'Rep and cform is [.,.,osig] then sig:=osig +; newimp := optDeltaEntry(op,sig,dc,eltOrConst) => newimp +; setDifference(listOfBoundVars dc,$functorLocalParameters) ^= [] => +; ['applyFun,['compiledLookupCheck,MKQ op, +; mkList consSig(sig,dc),consDomainForm(dc,nil)]] +; --if null atom dc then +; -- sig := substitute('$,dc,sig) +; -- cform := substitute('$,dc,cform) +; opModemapPair := +; [op,[dc,:[genDeltaSig x for x in sig]],['T,cform]] -- force pred to T +; if null NRTassocIndex dc and dc ^= $NRTaddForm and +; (MEMBER(dc,$functorLocalParameters) or null atom dc) then +; --create "domain" entry to $NRTdeltaList +; $NRTdeltaList:= [['domain,NRTaddInner dc,:dc],:$NRTdeltaList] +; saveNRTdeltaListComp:= $NRTdeltaListComp:=[nil,:$NRTdeltaListComp] +; $NRTdeltaLength := $NRTdeltaLength+1 +; compEntry:= +; dc +; RPLACA(saveNRTdeltaListComp,compEntry) +; chk(saveNRTdeltaListComp,102) +; u := +; [eltOrConst,'$,$NRTbase+$NRTdeltaLength-index] where index == +; (n:= POSN1(opModemapPair,$NRTdeltaList)) => n + 1 +; --n + 1 since $NRTdeltaLength is 1 too large +; $NRTdeltaList:= [opModemapPair,:$NRTdeltaList] +; $NRTdeltaListComp:=[nil,:$NRTdeltaListComp] +; $NRTdeltaLength := $NRTdeltaLength+1 +; 0 +; u + +(DEFUN |genDeltaEntry| (|opMmPair|) + (PROG (|odc| |op| |dc| |cform| |eltOrConst| |ISTMP#1| |ISTMP#2| + |osig| |sig| |newimp| |opModemapPair| + |saveNRTdeltaListComp| |compEntry| |n| |u|) + (declare (special |$NRTdeltaLength| |$NRTdeltaListComp| |$NRTbase| + |$functorLocalParameters| |$NRTaddForm| + |$profileCompiler| |$NRTdeltaList|)) + (RETURN + (SEQ (PROGN + (SPADLET |odc| (CAADR |opMmPair|)) + (SPADLET |op| (CAR |opMmPair|)) + (SPADLET |dc| (CAADR |opMmPair|)) + (SPADLET |sig| (CDADR |opMmPair|)) + (SPADLET |cform| (CAR (CDADDR |opMmPair|))) + (SPADLET |eltOrConst| (CAAR (CDADDR |opMmPair|))) + (COND + ((BOOT-EQUAL |$profileCompiler| 'T) + (|profileRecord| |dc| |op| |sig|))) + (COND + ((BOOT-EQUAL |eltOrConst| 'XLAM) |cform|) + ('T + (COND + ((BOOT-EQUAL |eltOrConst| '|Subsumed|) + (SPADLET |eltOrConst| 'ELT))) + (COND + ((AND (BOOT-EQUAL |odc| '|Rep|) (PAIRP |cform|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |cform|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |osig| + (QCAR |ISTMP#2|)) + 'T)))))) + (SPADLET |sig| |osig|))) + (COND + ((SPADLET |newimp| + (|optDeltaEntry| |op| |sig| |dc| + |eltOrConst|)) + |newimp|) + ((NEQUAL (SETDIFFERENCE (|listOfBoundVars| |dc|) + |$functorLocalParameters|) + NIL) + (CONS '|applyFun| + (CONS (CONS '|compiledLookupCheck| + (CONS (MKQ |op|) + (CONS + (|mkList| + (|consSig| |sig| |dc|)) + (CONS + (|consDomainForm| |dc| NIL) + NIL)))) + NIL))) + ('T + (SPADLET |opModemapPair| + (CONS |op| + (CONS (CONS |dc| + (PROG (G167987) + (SPADLET G167987 NIL) + (RETURN + (DO + ((G167992 |sig| + (CDR G167992)) + (|x| NIL)) + ((OR (ATOM G167992) + (PROGN + (SETQ |x| + (CAR G167992)) + NIL)) + (NREVERSE0 G167987)) + (SEQ + (EXIT + (SETQ G167987 + (CONS + (|genDeltaSig| |x|) + G167987)))))))) + (CONS + (CONS 'T (CONS |cform| NIL)) + NIL)))) + (COND + ((AND (NULL (|NRTassocIndex| |dc|)) + (NEQUAL |dc| |$NRTaddForm|) + (OR (|member| |dc| + |$functorLocalParameters|) + (NULL (ATOM |dc|)))) + (SPADLET |$NRTdeltaList| + (CONS (CONS '|domain| + (CONS (|NRTaddInner| |dc|) |dc|)) + |$NRTdeltaList|)) + (SPADLET |saveNRTdeltaListComp| + (SPADLET |$NRTdeltaListComp| + (CONS NIL |$NRTdeltaListComp|))) + (SPADLET |$NRTdeltaLength| + (PLUS |$NRTdeltaLength| 1)) + (SPADLET |compEntry| |dc|) + (RPLACA |saveNRTdeltaListComp| |compEntry|) + (|chk| |saveNRTdeltaListComp| 102))) + (SPADLET |u| + (CONS |eltOrConst| + (CONS '$ + (CONS + (SPADDIFFERENCE + (PLUS |$NRTbase| + |$NRTdeltaLength|) + (COND + ((SPADLET |n| + (POSN1 |opModemapPair| + |$NRTdeltaList|)) + (PLUS |n| 1)) + ('T + (SPADLET |$NRTdeltaList| + (CONS |opModemapPair| + |$NRTdeltaList|)) + (SPADLET + |$NRTdeltaListComp| + (CONS NIL + |$NRTdeltaListComp|)) + (SPADLET |$NRTdeltaLength| + (PLUS |$NRTdeltaLength| + 1)) + 0))) + NIL)))) + |u|))))))))) + +;--====================================================================== +;-- From nruncomp.boot +;--====================================================================== +;parseIf t == +; t isnt [p,a,b] => t +; ifTran(parseTran p,parseTran a,parseTran b) where +; ifTran(p,a,b) == +; null($InteractiveMode) and p='true => a +; null($InteractiveMode) and p='false => b +; p is ['not,p'] => ifTran(p',b,a) +; p is ['IF,p',a',b'] => ifTran(p',ifTran(a',COPY a,COPY b),ifTran(b',a,b)) +; p is ['SEQ,:l,['exit,1,p']] => +; ['SEQ,:l,['exit,1,ifTran(p',incExitLevel a,incExitLevel b)]] +; --this assumes that l has no exits +; a is ['IF, =p,a',.] => ['IF,p,a',b] +; b is ['IF, =p,.,b'] => ['IF,p,a,b'] +;-- makeSimplePredicateOrNil p is ['SEQ,:s,['exit,1,val]] => +;-- parseTran ['SEQ,:s,['exit,1,incExitLevel ['IF,val,a,b]]] +; ['IF,p,a,b] + +;;; *** |parseIf,ifTran| REDEFINED + +(DEFUN |parseIf,ifTran| (|p| |a| |b|) + (PROG (|ISTMP#4| |ISTMP#5| |p'| |l| |a'| |ISTMP#1| |ISTMP#2| + |ISTMP#3| |b'|) + (declare (special |$InteractiveMode|)) + (RETURN + (SEQ (IF (AND (NULL |$InteractiveMode|) (BOOT-EQUAL |p| '|true|)) + (EXIT |a|)) + (IF (AND (NULL |$InteractiveMode|) + (BOOT-EQUAL |p| '|false|)) + (EXIT |b|)) + (IF (AND (PAIRP |p|) (EQ (QCAR |p|) '|not|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |p|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |p'| (QCAR |ISTMP#1|)) 'T)))) + (EXIT (|parseIf,ifTran| |p'| |b| |a|))) + (IF (AND (PAIRP |p|) (EQ (QCAR |p|) 'IF) + (PROGN + (SPADLET |ISTMP#1| (QCDR |p|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |p'| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |a'| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |b'| (QCAR |ISTMP#3|)) + 'T)))))))) + (EXIT (|parseIf,ifTran| |p'| + (|parseIf,ifTran| |a'| (COPY |a|) (COPY |b|)) + (|parseIf,ifTran| |b'| |a| |b|)))) + (IF (AND (PAIRP |p|) (EQ (QCAR |p|) 'SEQ) + (PROGN + (SPADLET |ISTMP#1| (QCDR |p|)) + (AND (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| + (REVERSE |ISTMP#1|)) + 'T)) + (AND (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 |p'| + (QCAR |ISTMP#5|)) + 'T))))))) + (PROGN + (SPADLET |l| (QCDR |ISTMP#2|)) + 'T)) + (PROGN (SPADLET |l| (NREVERSE |l|)) 'T)))) + (EXIT (CONS 'SEQ + (APPEND |l| + (CONS + (CONS '|exit| + (CONS 1 + (CONS + (|parseIf,ifTran| |p'| + (|incExitLevel| |a|) + (|incExitLevel| |b|)) + NIL))) + NIL))))) + (IF (AND (PAIRP |a|) (EQ (QCAR |a|) 'IF) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a|)) + (AND (PAIRP |ISTMP#1|) + (EQUAL (QCAR |ISTMP#1|) |p|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |a'| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL)))))))) + (EXIT (CONS 'IF (CONS |p| (CONS |a'| (CONS |b| NIL)))))) + (IF (AND (PAIRP |b|) (EQ (QCAR |b|) 'IF) + (PROGN + (SPADLET |ISTMP#1| (QCDR |b|)) + (AND (PAIRP |ISTMP#1|) + (EQUAL (QCAR |ISTMP#1|) |p|) + (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 |b'| (QCAR |ISTMP#3|)) + 'T)))))))) + (EXIT (CONS 'IF (CONS |p| (CONS |a| (CONS |b'| NIL)))))) + (EXIT (CONS 'IF (CONS |p| (CONS |a| (CONS |b| NIL))))))))) + +;;; *** |parseIf| REDEFINED + +(DEFUN |parseIf| (|t|) + (PROG (|p| |ISTMP#1| |a| |ISTMP#2| |b|) + (RETURN + (COND + ((NULL (AND (PAIRP |t|) + (PROGN + (SPADLET |p| (QCAR |t|)) + (SPADLET |ISTMP#1| (QCDR |t|)) + (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))))))) + |t|) + ('T + (|parseIf,ifTran| (|parseTran| |p|) (|parseTran| |a|) + (|parseTran| |b|))))))) + +;--====================================================================== +;-- From parse.boot +;--====================================================================== +;parseNot u == ['not,parseTran first u] + +;;; *** |parseNot| REDEFINED + +(DEFUN |parseNot| (|u|) + (CONS '|not| (CONS (|parseTran| (CAR |u|)) NIL))) + +;makeSimplePredicateOrNil p == nil + +;;; *** |makeSimplePredicateOrNil| REDEFINED + +(DEFUN |makeSimplePredicateOrNil| (|p|) + (declare (ignore |p|)) + NIL) + +; +;--====================================================================== +;-- From g-cndata.boot +;--====================================================================== +;mkUserConstructorAbbreviation(c,a,type) == +; if $AnalyzeOnly or $convert2NewCompiler then +; $abbreviationStack := [[type,a,:c],:$abbreviationStack] +; if not atom c then c:= CAR c -- Existing constructors will be wrapped +; constructorAbbreviationErrorCheck(c,a,type,'abbreviationError) +; clearClams() +; clearConstructorCache(c) +; installConstructor(c,type) +; setAutoLoadProperty(c) + +(DEFUN |mkUserConstructorAbbreviation| (|c| |a| |type|) + (declare (special |$abbreviationStack| |$AnalyzeOnly| |$convert2NewCompiler|)) + (PROGN + (COND + ((OR |$AnalyzeOnly| |$convert2NewCompiler|) + (SPADLET |$abbreviationStack| + (CONS (CONS |type| (CONS |a| |c|)) + |$abbreviationStack|)))) + (COND ((NULL (ATOM |c|)) (SPADLET |c| (CAR |c|)))) + (|constructorAbbreviationErrorCheck| |c| |a| |type| + '|abbreviationError|) + (|clearClams|) + (|clearConstructorCache| |c|) + (|installConstructor| |c| |type|) + (|setAutoLoadProperty| |c|))) + +;--====================================================================== +;-- From iterator.boot +;--====================================================================== +;compreduce(form is [.,op,x],m,e) == +; T := compForm(form,m,e) or return nil +; y := T.expr +; RPLACA(y,"REDUCE") +; ------------------<== distinquish this as the special reduce form +; (y is ["REDUCE",:.]) and (id:= getIdentity(op,e)) and (u := comp0(id,m,e)) and +; # getNumberTypesInScope() > 1 => markSimpleReduce([:y, ["@",u.expr,m]], T) +; T + +(DEFUN |compreduce| (|form| |m| |e|) + (PROG (|op| |x| T$ |y| |id| |u|) + (RETURN + (PROGN + (SPADLET |op| (CADR |form|)) + (SPADLET |x| (CADDR |form|)) + (SPADLET T$ (OR (|compForm| |form| |m| |e|) (RETURN NIL))) + (SPADLET |y| (CAR T$)) + (RPLACA |y| 'REDUCE) + (COND + ((AND (PAIRP |y|) (EQ (QCAR |y|) 'REDUCE) + (SPADLET |id| (|getIdentity| |op| |e|)) + (SPADLET |u| (|comp0| |id| |m| |e|)) + (> (|#| (|getNumberTypesInScope|)) 1)) + (|markSimpleReduce| + (APPEND |y| + (CONS (CONS '@ (CONS (CAR |u|) (CONS |m| NIL))) + NIL)) + T$)) + ('T T$)))))) + +;compReduce1(form is ["REDUCE",op,.,collectForm],m,e,$formalArgList) == +;-------------------------------> 11/28 all new to preserve collect forms +; markImport m +; [collectOp,:itl,body]:= collectForm +; $e:= e +; itl:= [([.,$e]:= compIterator(x,$e) or return "failed").(0) for x in itl] +; itl="failed" => return nil +; e:= $e +; T0 := comp0(body,m,e) or return nil +; md := T0.mode +; T1 := compOrCroak(collectForm,["List",md],e) +; T := [["REDUCE",op,nil,T1.expr],md,T1.env] +; markReduce(form,T) + +(DEFUN |compReduce1| (|form| |m| |e| |$formalArgList|) + (DECLARE (SPECIAL |$formalArgList|)) + (PROG (|op| |collectForm| |collectOp| |body| |LETTMP#1| |itl| T0 |md| + T1 T$) + (declare (special |$e|)) + (RETURN + (SEQ (PROGN + (COND ((EQ (CAR |form|) 'REDUCE) (CAR |form|))) + (SPADLET |op| (CADR |form|)) + (SPADLET |collectForm| (CADDDR |form|)) + (|markImport| |m|) + (SPADLET |collectOp| (CAR |collectForm|)) + (SPADLET |LETTMP#1| (REVERSE (CDR |collectForm|))) + (SPADLET |body| (CAR |LETTMP#1|)) + (SPADLET |itl| (NREVERSE (CDR |LETTMP#1|))) + (SPADLET |$e| |e|) + (SPADLET |itl| + (PROG (G168260) + (SPADLET G168260 NIL) + (RETURN + (DO ((G168268 |itl| (CDR G168268)) + (|x| NIL)) + ((OR (ATOM G168268) + (PROGN + (SETQ |x| (CAR G168268)) + NIL)) + (NREVERSE0 G168260)) + (SEQ (EXIT (SETQ G168260 + (CONS + (ELT + (PROGN + (SPADLET |LETTMP#1| + (OR + (|compIterator| |x| |$e|) + (RETURN '|failed|))) + (SPADLET |$e| + (CADR |LETTMP#1|)) + |LETTMP#1|) + 0) + G168260)))))))) + (COND + ((BOOT-EQUAL |itl| '|failed|) (RETURN NIL)) + ('T (SPADLET |e| |$e|) + (SPADLET T0 (OR (|comp0| |body| |m| |e|) (RETURN NIL))) + (SPADLET |md| (CADR T0)) + (SPADLET T1 + (|compOrCroak| |collectForm| + (CONS '|List| (CONS |md| NIL)) |e|)) + (SPADLET T$ + (CONS (CONS 'REDUCE + (CONS |op| + (CONS NIL (CONS (CAR T1) NIL)))) + (CONS |md| (CONS (CADDR T1) NIL)))) + (|markReduce| |form| T$)))))))) + +;compIterator(it,e) == +; it is ["IN",x,y] => +; --these two lines must be in this order, to get "for f in list f" +; --to give an error message if f is undefined +; ---------------> new <--------------------- +; [y',m,e] := markInValue(y, e) +; x := markKillAll x +; ------------------ +; $formalArgList:= [x,:$formalArgList] +; [.,mUnder]:= +; modeIsAggregateOf("List",m,e) or modeIsAggregateOf("Vector",m,e) or return +; stackMessage ["mode: ",m," must be a list or vector of some mode"] +; if null get(x,"mode",e) then [.,.,e]:= +; compMakeDeclaration([":",x,mUnder],$EmptyMode,e) or return nil +; e:= put(x,"value",[genSomeVariable(),mUnder,e],e) +; markReduceIn(it, [["IN",x,y'],e]) +; it is ["ON",x,y] => +;---------------> new <--------------------- +; x := markKillAll x +; ------------------ +; $formalArgList:= [x,:$formalArgList] +; y := markKillAll y +; markImport m +;---------------> new <--------------------- +; [y',m,e]:= comp(y,$EmptyMode,e) or return nil +; [.,mUnder]:= +; modeIsAggregateOf("List",m,e) or return +; stackMessage ["mode: ",m," must be a list of other modes"] +; if null get(x,"mode",e) then [.,.,e]:= +; compMakeDeclaration([":",x,m],$EmptyMode,e) or return nil +; e:= put(x,"value",[genSomeVariable(),m,e],e) +; [["ON",x,y'],e] +; it is ["STEP",oindex,start,inc,:optFinal] => +; index := markKillAll oindex +; $formalArgList:= [index,:$formalArgList] +; --if all start/inc/end compile as small integers, then loop +; --is compiled as a small integer loop +; final':= nil +;---------------> new <--------------------- +; u := smallIntegerStep(it,index,start,inc,optFinal,e) => u +;---------------> new <--------------------- +; [start,.,e]:= +; comp(markKillAll start,$Integer,e) or return +; stackMessage ["start value of index: ",start," must be an integer"] +; [inc,.,e]:= +; comp(markKillAll inc,$Integer,e) or return +; stackMessage ["index increment:",inc," must be an integer"] +; if optFinal is [final] then +; [final,.,e]:= +; comp(markKillAll final,$Integer,e) or return +; stackMessage ["final value of index: ",final," must be an integer"] +; optFinal:= [final] +; indexmode:= +; comp(CADDR it,$NonNegativeInteger,e) => $NonNegativeInteger +; $Integer +;-- markImport ['Segment,indexmode] +; if null get(index,"mode",e) then [.,.,e]:= +; compMakeDeclaration([":",index,indexmode],$EmptyMode,e) or return nil +; e:= put(index,"value",[genSomeVariable(),indexmode,e],e) +; markReduceStep(it, [["STEP",markStep(index),start,inc,:optFinal],e]) +; it is ["WHILE",p] => +; [p',m,e]:= +; comp(p,$Boolean,e) or return +; stackMessage ["WHILE operand: ",p," is not Boolean valued"] +; markReduceWhile(it, [["WHILE",p'],e]) +; it is ["UNTIL",p] => markReduceUntil(it, ($until:= p; ['$until,e])) +; it is ["|",x] => +; u:= +; comp(x,$Boolean,e) or return +; stackMessage ["SUCHTHAT operand: ",x," is not Boolean value"] +; markReduceSuchthat(it, [["|",u.expr],u.env]) +; nil + +(DEFUN |compIterator| (|it| |e|) + (PROG (|y| |y'| |mUnder| |oindex| |ISTMP#2| |ISTMP#3| |index| + |final'| |start| |inc| |final| |optFinal| |indexmode| + |LETTMP#1| |p'| |m| |p| |ISTMP#1| |x| |u|) + (declare (special |$Boolean| |$until| |$EmptyMode| |$Integer| + |$NonNegativeInteger| |$formalArgList|)) + (RETURN + (COND + ((AND (PAIRP |it|) (EQ (QCAR |it|) 'IN) + (PROGN + (SPADLET |ISTMP#1| (QCDR |it|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |x| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |y| (QCAR |ISTMP#2|)) 'T)))))) + (SPADLET |LETTMP#1| (|markInValue| |y| |e|)) + (SPADLET |y'| (CAR |LETTMP#1|)) + (SPADLET |m| (CADR |LETTMP#1|)) + (SPADLET |e| (CADDR |LETTMP#1|)) + (SPADLET |x| (|markKillAll| |x|)) + (SPADLET |$formalArgList| (CONS |x| |$formalArgList|)) + (SPADLET |LETTMP#1| + (OR (|modeIsAggregateOf| '|List| |m| |e|) + (|modeIsAggregateOf| '|Vector| |m| |e|) + (RETURN + (|stackMessage| + (CONS '|mode: | + (CONS |m| + (CONS + '| must be a list or vector of some mode| + NIL))))))) + (SPADLET |mUnder| (CADR |LETTMP#1|)) + (COND + ((NULL (|get| |x| '|mode| |e|)) + (SPADLET |LETTMP#1| + (OR (|compMakeDeclaration| + (CONS '|:| (CONS |x| (CONS |mUnder| NIL))) + |$EmptyMode| |e|) + (RETURN NIL))) + (SPADLET |e| (CADDR |LETTMP#1|)) |LETTMP#1|)) + (SPADLET |e| + (|put| |x| '|value| + (CONS (|genSomeVariable|) + (CONS |mUnder| (CONS |e| NIL))) + |e|)) + (|markReduceIn| |it| + (CONS (CONS 'IN (CONS |x| (CONS |y'| NIL))) + (CONS |e| NIL)))) + ((AND (PAIRP |it|) (EQ (QCAR |it|) 'ON) + (PROGN + (SPADLET |ISTMP#1| (QCDR |it|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |x| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |y| (QCAR |ISTMP#2|)) 'T)))))) + (SPADLET |x| (|markKillAll| |x|)) + (SPADLET |$formalArgList| (CONS |x| |$formalArgList|)) + (SPADLET |y| (|markKillAll| |y|)) (|markImport| |m|) + (SPADLET |LETTMP#1| + (OR (|comp| |y| |$EmptyMode| |e|) (RETURN NIL))) + (SPADLET |y'| (CAR |LETTMP#1|)) + (SPADLET |m| (CADR |LETTMP#1|)) + (SPADLET |e| (CADDR |LETTMP#1|)) + (SPADLET |LETTMP#1| + (OR (|modeIsAggregateOf| '|List| |m| |e|) + (RETURN + (|stackMessage| + (CONS '|mode: | + (CONS |m| + (CONS + '| must be a list of other modes| + NIL))))))) + (SPADLET |mUnder| (CADR |LETTMP#1|)) + (COND + ((NULL (|get| |x| '|mode| |e|)) + (SPADLET |LETTMP#1| + (OR (|compMakeDeclaration| + (CONS '|:| (CONS |x| (CONS |m| NIL))) + |$EmptyMode| |e|) + (RETURN NIL))) + (SPADLET |e| (CADDR |LETTMP#1|)) |LETTMP#1|)) + (SPADLET |e| + (|put| |x| '|value| + (CONS (|genSomeVariable|) + (CONS |m| (CONS |e| NIL))) + |e|)) + (CONS (CONS 'ON (CONS |x| (CONS |y'| NIL))) (CONS |e| NIL))) + ((AND (PAIRP |it|) (EQ (QCAR |it|) 'STEP) + (PROGN + (SPADLET |ISTMP#1| (QCDR |it|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |oindex| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |start| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |inc| (QCAR |ISTMP#3|)) + (SPADLET |optFinal| + (QCDR |ISTMP#3|)) + 'T)))))))) + (SPADLET |index| (|markKillAll| |oindex|)) + (SPADLET |$formalArgList| (CONS |index| |$formalArgList|)) + (SPADLET |final'| NIL) + (COND + ((SPADLET |u| + (|smallIntegerStep| |it| |index| |start| |inc| + |optFinal| |e|)) + |u|) + ('T + (SPADLET |LETTMP#1| + (OR (|comp| (|markKillAll| |start|) |$Integer| + |e|) + (RETURN + (|stackMessage| + (CONS '|start value of index: | + (CONS |start| + (CONS '| must be an integer| NIL))))))) + (SPADLET |start| (CAR |LETTMP#1|)) + (SPADLET |e| (CADDR |LETTMP#1|)) + (SPADLET |LETTMP#1| + (OR (|comp| (|markKillAll| |inc|) |$Integer| |e|) + (RETURN + (|stackMessage| + (CONS '|index increment:| + (CONS |inc| + (CONS '| must be an integer| NIL))))))) + (SPADLET |inc| (CAR |LETTMP#1|)) + (SPADLET |e| (CADDR |LETTMP#1|)) + (COND + ((AND (PAIRP |optFinal|) (EQ (QCDR |optFinal|) NIL) + (PROGN (SPADLET |final| (QCAR |optFinal|)) 'T)) + (SPADLET |LETTMP#1| + (OR (|comp| (|markKillAll| |final|) |$Integer| + |e|) + (RETURN + (|stackMessage| + (CONS '|final value of index: | + (CONS |final| + (CONS '| must be an integer| + NIL))))))) + (SPADLET |final| (CAR |LETTMP#1|)) + (SPADLET |e| (CADDR |LETTMP#1|)) + (SPADLET |optFinal| (CONS |final| NIL)))) + (SPADLET |indexmode| + (COND + ((|comp| (CADDR |it|) |$NonNegativeInteger| |e|) + |$NonNegativeInteger|) + ('T |$Integer|))) + (COND + ((NULL (|get| |index| '|mode| |e|)) + (SPADLET |LETTMP#1| + (OR (|compMakeDeclaration| + (CONS '|:| + (CONS |index| + (CONS |indexmode| NIL))) + |$EmptyMode| |e|) + (RETURN NIL))) + (SPADLET |e| (CADDR |LETTMP#1|)) |LETTMP#1|)) + (SPADLET |e| + (|put| |index| '|value| + (CONS (|genSomeVariable|) + (CONS |indexmode| (CONS |e| NIL))) + |e|)) + (|markReduceStep| |it| + (CONS (CONS 'STEP + (CONS (|markStep| |index|) + (CONS |start| + (CONS |inc| |optFinal|)))) + (CONS |e| NIL)))))) + ((AND (PAIRP |it|) (EQ (QCAR |it|) 'WHILE) + (PROGN + (SPADLET |ISTMP#1| (QCDR |it|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |p| (QCAR |ISTMP#1|)) 'T)))) + (SPADLET |LETTMP#1| + (OR (|comp| |p| |$Boolean| |e|) + (RETURN + (|stackMessage| + (CONS '|WHILE operand: | + (CONS |p| + (CONS '| is not Boolean valued| + NIL))))))) + (SPADLET |p'| (CAR |LETTMP#1|)) + (SPADLET |m| (CADR |LETTMP#1|)) + (SPADLET |e| (CADDR |LETTMP#1|)) + (|markReduceWhile| |it| + (CONS (CONS 'WHILE (CONS |p'| NIL)) (CONS |e| NIL)))) + ((AND (PAIRP |it|) (EQ (QCAR |it|) 'UNTIL) + (PROGN + (SPADLET |ISTMP#1| (QCDR |it|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |p| (QCAR |ISTMP#1|)) 'T)))) + (|markReduceUntil| |it| + (PROGN + (SPADLET |$until| |p|) + (CONS '|$until| (CONS |e| NIL))))) + ((AND (PAIRP |it|) (EQ (QCAR |it|) '|\||) + (PROGN + (SPADLET |ISTMP#1| (QCDR |it|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |x| (QCAR |ISTMP#1|)) 'T)))) + (SPADLET |u| + (OR (|comp| |x| |$Boolean| |e|) + (RETURN + (|stackMessage| + (CONS '|SUCHTHAT operand: | + (CONS |x| + (CONS '| is not Boolean value| + NIL))))))) + (|markReduceSuchthat| |it| + (CONS (CONS '|\|| (CONS (CAR |u|) NIL)) + (CONS (CADDR |u|) NIL)))) + ('T NIL))))) + +;smallIntegerStep(it,index,start,inc,optFinal,e) == +; start := markKillAll start +; inc := markKillAll inc +; optFinal := markKillAll optFinal +; startNum := source2Number start +; incNum := source2Number inc +; mode := get(index,"mode",e) +;--fail if +;----> a) index has a mode that is not $SmallInteger +;----> b) one of start,inc, final won't comp as a $SmallInteger +; mode and mode ^= $SmallInteger => nil +; null (start':= comp(start,$SmallInteger,e)) => nil +; null (inc':= comp(inc,$SmallInteger,start'.env)) => nil +; if optFinal is [final] and not (final':= comp(final,$SmallInteger,inc'.env)) then +;-- not (FIXP startNum and FIXP incNum) => return nil +;-- null FIXP startNum or ABSVAL startNum > 100 => return nil +; -----> assume that optFinal is $SmallInteger +; T := comp(final,$EmptyMode,inc'.env) or return nil +; final' := T +; maxSuperType(T.mode,e) ^= $Integer => return nil +; givenRange := T.mode +; indexmode:= $SmallInteger +; [.,.,e]:= compMakeDeclaration([":",index,indexmode],$EmptyMode, +; (final' => final'.env; inc'.env)) or return nil +; range := +; FIXP startNum and FIXP incNum => +; startNum > 0 and incNum > 0 => $PositiveInteger +; startNum < 0 and incNum < 0 => $NegativeInteger +; incNum > 0 => $NonNegativeInteger --startNum = 0 +; $NonPositiveInteger +; givenRange => givenRange +; nil +; e:= put(index,"range",range,e) +; e:= put(index,"value",[genSomeVariable(),indexmode,e],e) +; noptFinal := +; final' => +; [final'.expr] +; nil +; [markStepSI(it,["ISTEP",index,start'.expr,inc'.expr,:noptFinal]),e] + +(DEFUN |smallIntegerStep| (|it| |index| |start| |inc| |optFinal| |e|) + (PROG (|startNum| |incNum| |mode| |start'| |inc'| |final| T$ |final'| + |givenRange| |indexmode| |LETTMP#1| |range| |noptFinal|) + (declare (special |$NonPositiveInteger| |$PositiveInteger| |$EmptyMode| + |$SmallInteger| |$Integer|)) + (RETURN + (PROGN + (SPADLET |start| (|markKillAll| |start|)) + (SPADLET |inc| (|markKillAll| |inc|)) + (SPADLET |optFinal| (|markKillAll| |optFinal|)) + (SPADLET |startNum| (|source2Number| |start|)) + (SPADLET |incNum| (|source2Number| |inc|)) + (SPADLET |mode| (|get| |index| '|mode| |e|)) + (COND + ((AND |mode| (NEQUAL |mode| |$SmallInteger|)) NIL) + ((NULL (SPADLET |start'| + (|comp| |start| |$SmallInteger| |e|))) + NIL) + ((NULL (SPADLET |inc'| + (|comp| |inc| |$SmallInteger| + (CADDR |start'|)))) + NIL) + ('T + (COND + ((AND (PAIRP |optFinal|) (EQ (QCDR |optFinal|) NIL) + (PROGN (SPADLET |final| (QCAR |optFinal|)) 'T) + (NULL (SPADLET |final'| + (|comp| |final| |$SmallInteger| + (CADDR |inc'|))))) + (SPADLET T$ + (OR (|comp| |final| |$EmptyMode| (CADDR |inc'|)) + (RETURN NIL))) + (SPADLET |final'| T$) + (COND + ((NEQUAL (|maxSuperType| (CADR T$) |e|) |$Integer|) + (RETURN NIL)) + ('T (SPADLET |givenRange| (CADR T$)))))) + (SPADLET |indexmode| |$SmallInteger|) + (SPADLET |LETTMP#1| + (OR (|compMakeDeclaration| + (CONS '|:| + (CONS |index| (CONS |indexmode| NIL))) + |$EmptyMode| + (COND + (|final'| (CADDR |final'|)) + ('T (CADDR |inc'|)))) + (RETURN NIL))) + (SPADLET |e| (CADDR |LETTMP#1|)) + (SPADLET |range| + (COND + ((AND (FIXP |startNum|) (FIXP |incNum|)) + (COND + ((AND (> |startNum| 0) (> |incNum| 0)) + |$PositiveInteger|) + ((AND (MINUSP |startNum|) (MINUSP |incNum|)) + |$NegativeInteger|) + ((> |incNum| 0) |$NonNegativeInteger|) + ('T |$NonPositiveInteger|))) + (|givenRange| |givenRange|) + ('T NIL))) + (SPADLET |e| (|put| |index| '|range| |range| |e|)) + (SPADLET |e| + (|put| |index| '|value| + (CONS (|genSomeVariable|) + (CONS |indexmode| (CONS |e| NIL))) + |e|)) + (SPADLET |noptFinal| + (COND + (|final'| (CONS (CAR |final'|) NIL)) + ('T NIL))) + (CONS (|markStepSI| |it| + (CONS 'ISTEP + (CONS |index| + (CONS (CAR |start'|) + (CONS (CAR |inc'|) |noptFinal|))))) + (CONS |e| NIL)))))))) + +;source2Number n == +; n := markKillAll n +; n = $Zero => 0 +; n = $One => 1 +; n + +(DEFUN |source2Number| (|n|) + (declare (special |$Zero| |$One|)) + (PROGN + (SPADLET |n| (|markKillAll| |n|)) + (COND + ((BOOT-EQUAL |n| |$Zero|) 0) + ((BOOT-EQUAL |n| |$One|) 1) + ('T |n|)))) + +;compRepeatOrCollect(form,m,e) == +; fn(form,[m,:$exitModeStack],[#$exitModeStack,:$leaveLevelStack],$formalArgList +; ,e) where +; fn(form,$exitModeStack,$leaveLevelStack,$formalArgList,e) == +; $until: local +; [repeatOrCollect,:itl,body]:= form +; itl':= +; [([x',e]:= compIterator(x,e) or return "failed"; x') for x in itl] +; itl'="failed" => nil +; targetMode:= first $exitModeStack +;-- pp '"---------" +;-- pp targetMode +; bodyMode:= +; repeatOrCollect="COLLECT" => +; targetMode = '$EmptyMode => '$EmptyMode +; (u:=modeIsAggregateOf('List,targetMode,e)) => +; CADR u +; (u:=modeIsAggregateOf('Vector,targetMode,e)) => +; repeatOrCollect:='COLLECTV +; CADR u +; stackMessage('"Invalid collect bodytype") +; return nil +; -- If we're doing a collect, and the type isn't conformable +; -- then we've boobed. JHD 26.July.1990 +; $NoValueMode +; [body',m',e']:= T := +; -- (m1:= listOrVectorElementMode targetMode) and comp(body,m1,e) or +; compOrCroak(body,bodyMode,e) or return nil +; markRepeatBody(body, T) +; if $until then +; [untilCode,.,e']:= comp($until,$Boolean,e') +; itl':= substitute(["UNTIL",untilCode],'$until,itl') +; form':= [repeatOrCollect,:itl',body'] +; m'':= +; repeatOrCollect="COLLECT" => +; (u:=modeIsAggregateOf('List,targetMode,e)) => CAR u +; ["List",m'] +; repeatOrCollect="COLLECTV" => +; (u:=modeIsAggregateOf('Vector,targetMode,e)) => CAR u +; ["Vector",m'] +; m' +;--------> new <-------------- +; markImport m'' +;--------> new <-------------- +; markRepeat(form,coerceExit([form',m'',e'],targetMode)) + +(DEFUN |compRepeatOrCollect,fn| + (|form| |$exitModeStack| |$leaveLevelStack| |$formalArgList| + |e|) + (DECLARE (SPECIAL |$exitModeStack| |$leaveLevelStack| + |$formalArgList|)) + (PROG (|$until| |body| |itl| |x'| |targetMode| |repeatOrCollect| + |bodyMode| T$ |body'| |m'| |LETTMP#1| |untilCode| |e'| + |itl'| |form'| |u| |m''|) + (DECLARE (SPECIAL |$until| |$Boolean| |$NoValueMode|)) + (RETURN + (SEQ (SPADLET |$until| NIL) + (PROGN + (SPADLET |repeatOrCollect| (CAR |form|)) + (SPADLET |LETTMP#1| (REVERSE (CDR |form|))) + (SPADLET |body| (CAR |LETTMP#1|)) + (SPADLET |itl| (NREVERSE (CDR |LETTMP#1|))) + |form|) + (SPADLET |itl'| + (PROG (G168618) + (SPADLET G168618 NIL) + (RETURN + (DO ((G168627 |itl| (CDR G168627)) + (|x| NIL)) + ((OR (ATOM G168627) + (PROGN + (SETQ |x| (CAR G168627)) + NIL)) + (NREVERSE0 G168618)) + (SEQ (EXIT (SETQ G168618 + (CONS + (SEQ + (PROGN + (SPADLET |LETTMP#1| + (OR (|compIterator| |x| |e|) + (RETURN '|failed|))) + (SPADLET |x'| + (CAR |LETTMP#1|)) + (SPADLET |e| + (CADR |LETTMP#1|)) + |LETTMP#1|) + (EXIT |x'|)) + G168618)))))))) + (IF (BOOT-EQUAL |itl'| '|failed|) (EXIT NIL)) + (SPADLET |targetMode| (CAR |$exitModeStack|)) + (SPADLET |bodyMode| + (SEQ (IF (BOOT-EQUAL |repeatOrCollect| 'COLLECT) + (EXIT (SEQ + (IF + (BOOT-EQUAL |targetMode| + '|$EmptyMode|) + (EXIT '|$EmptyMode|)) + (IF + (SPADLET |u| + (|modeIsAggregateOf| '|List| + |targetMode| |e|)) + (EXIT (CADR |u|))) + (IF + (SPADLET |u| + (|modeIsAggregateOf| '|Vector| + |targetMode| |e|)) + (EXIT + (SEQ + (SPADLET |repeatOrCollect| + 'COLLECTV) + (EXIT (CADR |u|))))) + (|stackMessage| + (MAKESTRING + "Invalid collect bodytype")) + (EXIT (RETURN NIL))))) + (EXIT |$NoValueMode|))) + (PROGN + (SPADLET T$ + (OR (|compOrCroak| |body| |bodyMode| |e|) + (RETURN NIL))) + (SPADLET |body'| (CAR T$)) + (SPADLET |m'| (CADR T$)) + (SPADLET |e'| (CADDR T$)) + T$) + (|markRepeatBody| |body| T$) + (IF |$until| + (SEQ (PROGN + (SPADLET |LETTMP#1| + (|comp| |$until| |$Boolean| |e'|)) + (SPADLET |untilCode| (CAR |LETTMP#1|)) + (SPADLET |e'| (CADDR |LETTMP#1|)) + |LETTMP#1|) + (EXIT (SPADLET |itl'| + (MSUBST + (CONS 'UNTIL + (CONS |untilCode| NIL)) + '|$until| |itl'|)))) + NIL) + (SPADLET |form'| + (CONS |repeatOrCollect| + (APPEND |itl'| (CONS |body'| NIL)))) + (SPADLET |m''| + (SEQ (IF (BOOT-EQUAL |repeatOrCollect| 'COLLECT) + (EXIT (SEQ + (IF + (SPADLET |u| + (|modeIsAggregateOf| '|List| + |targetMode| |e|)) + (EXIT (CAR |u|))) + (EXIT + (CONS '|List| (CONS |m'| NIL)))))) + (IF (BOOT-EQUAL |repeatOrCollect| 'COLLECTV) + (EXIT (SEQ + (IF + (SPADLET |u| + (|modeIsAggregateOf| '|Vector| + |targetMode| |e|)) + (EXIT (CAR |u|))) + (EXIT + (CONS '|Vector| (CONS |m'| NIL)))))) + (EXIT |m'|))) + (|markImport| |m''|) + (EXIT (|markRepeat| |form| + (|coerceExit| + (CONS |form'| (CONS |m''| (CONS |e'| NIL))) + |targetMode|))))))) + +(DEFUN |compRepeatOrCollect| (|form| |m| |e|) + (declare (special |$exitModeStack| |$leaveLevelStack| |$formalArgList|)) + (|compRepeatOrCollect,fn| |form| (CONS |m| |$exitModeStack|) + (CONS (|#| |$exitModeStack|) |$leaveLevelStack|) |$formalArgList| + |e|)) + +;chaseInferences(origPred,$e) == +; pred := markKillAll origPred +; ----------------------------12/4/94 do this immediately +; foo hasToInfo pred where +; foo pred == +; knownInfo pred => nil +; $e:= actOnInfo(pred,$e) +; pred:= infoToHas pred +; for u in get("$Information","special",$e) repeat +; u is ["COND",:l] => +; for [ante,:conseq] in l repeat +; ante=pred => [foo w for w in conseq] +; ante is ["and",:ante'] and MEMBER(pred,ante') => +; ante':= DELETE(pred,ante') +; v':= +; LENGTH ante'=1 => first ante' +; ["and",:ante'] +; v':= ["COND",[v',:conseq]] +; MEMBER(v',get("$Information","special",$e)) => nil +; $e:= +; put("$Information","special",[v',: +; get("$Information","special",$e)],$e) +; nil +; $e + +(DEFUN |chaseInferences,foo| (|pred|) + (PROG (|l| |ante| |conseq| |ante'| |v'|) + (declare (special |$e| |$Information|)) + (RETURN + (SEQ (IF (|knownInfo| |pred|) (EXIT NIL)) + (SPADLET |$e| (|actOnInfo| |pred| |$e|)) + (SPADLET |pred| (|infoToHas| |pred|)) + (EXIT (DO ((G168688 + (|get| '|$Information| '|special| |$e|) + (CDR G168688)) + (|u| NIL)) + ((OR (ATOM G168688) + (PROGN (SETQ |u| (CAR G168688)) NIL)) + NIL) + (SEQ (EXIT (IF (AND (PAIRP |u|) + (EQ (QCAR |u|) 'COND) + (PROGN + (SPADLET |l| (QCDR |u|)) + 'T)) + (EXIT (DO + ((G168700 |l| + (CDR G168700)) + (G168673 NIL)) + ((OR (ATOM G168700) + (PROGN + (SETQ G168673 + (CAR G168700)) + NIL) + (PROGN + (PROGN + (SPADLET |ante| + (CAR G168673)) + (SPADLET |conseq| + (CDR G168673)) + G168673) + NIL)) + NIL) + (SEQ + (IF + (BOOT-EQUAL |ante| |pred|) + (EXIT + (PROG (G168711) + (SPADLET G168711 NIL) + (RETURN + (DO + ((G168716 |conseq| + (CDR G168716)) + (|w| NIL)) + ((OR (ATOM G168716) + (PROGN + (SETQ |w| + (CAR G168716)) + NIL)) + (NREVERSE0 + G168711)) + (SEQ + (EXIT + (SETQ G168711 + (CONS + (|chaseInferences,foo| + |w|) + G168711))))))))) + (IF + (AND + (AND (PAIRP |ante|) + (EQ (QCAR |ante|) '|and|) + (PROGN + (SPADLET |ante'| + (QCDR |ante|)) + 'T)) + (|member| |pred| |ante'|)) + (EXIT + (SEQ + (SPADLET |ante'| + (|delete| |pred| + |ante'|)) + (SPADLET |v'| + (SEQ + (IF + (EQL (LENGTH |ante'|) + 1) + (EXIT (CAR |ante'|))) + (EXIT + (CONS '|and| |ante'|)))) + (SPADLET |v'| + (CONS 'COND + (CONS + (CONS |v'| |conseq|) + NIL))) + (IF + (|member| |v'| + (|get| '|$Information| + '|special| |$e|)) + (EXIT NIL)) + (EXIT + (SPADLET |$e| + (|put| '|$Information| + '|special| + (CONS |v'| + (|get| + '|$Information| + '|special| |$e|)) + |$e|)))))) + (EXIT NIL))))))))))))) + +(DEFUN |chaseInferences| (|origPred| |$e|) + (DECLARE (SPECIAL |$e|)) + (PROG (|pred|) + (RETURN + (PROGN + (SPADLET |pred| (|markKillAll| |origPred|)) + (|chaseInferences,foo| (|hasToInfo| |pred|)) + |$e|)))) + +;--====================================================================== +;-- doit Code +;--====================================================================== +;doIt(item,$predl) == +; $GENNO: local:= 0 +; $coerceList: local := nil +; ---> +; if item is ['PART,.,a] then item := a +; ------------------------------------- +; item is ['SEQ,:.] => doItSeq item +; isDomainForm(item,$e) => doItDomain item +; item is ['LET,:.] => doItLet item +; item is [":",a,t] => [.,.,$e]:= +; markDeclaredImport markKillAll t +; compOrCroak(item,$EmptyMode,$e) +; item is ['import,:doms] => +; item := ['import,:(doms := markKillAll doms)] +; for dom in doms repeat +; sayBrightly ['" importing ",:formatUnabbreviated dom] +; [.,.,$e] := compOrCroak(item,$EmptyMode,$e) +; wiReplaceNode(item,'(PROGN),10) +; 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,:.] => doItDef item +; T:= compOrCroak(item,$EmptyMode,$e) => doItExpression(item,T) +; true => cannotDo() + +(DEFUN |doIt| (|item| |$predl|) + (DECLARE (SPECIAL |$predl|)) + (PROG ($GENNO |$coerceList| |a| |ISTMP#2| |t| |doms| |ISTMP#1| |b| + |l| |LETTMP#1| T$) + (DECLARE (SPECIAL $GENNO |$coerceList| |$EmptyMode| |$e| |$coerceList|)) + (RETURN + (SEQ (PROGN + (SPADLET $GENNO 0) + (SPADLET |$coerceList| NIL) + (COND + ((AND (PAIRP |item|) (EQ (QCAR |item|) 'PART) + (PROGN + (SPADLET |ISTMP#1| (QCDR |item|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |a| (QCAR |ISTMP#2|)) + 'T)))))) + (SPADLET |item| |a|))) + (COND + ((AND (PAIRP |item|) (EQ (QCAR |item|) 'SEQ)) + (|doItSeq| |item|)) + ((|isDomainForm| |item| |$e|) (|doItDomain| |item|)) + ((AND (PAIRP |item|) (EQ (QCAR |item|) 'LET)) + (|doItLet| |item|)) + ((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| + (PROGN + (|markDeclaredImport| (|markKillAll| |t|)) + (|compOrCroak| |item| |$EmptyMode| |$e|))) + (SPADLET |$e| (CADDR |LETTMP#1|)) |LETTMP#1|) + ((AND (PAIRP |item|) (EQ (QCAR |item|) '|import|) + (PROGN (SPADLET |doms| (QCDR |item|)) 'T)) + (SPADLET |item| + (CONS '|import| + (SPADLET |doms| (|markKillAll| |doms|)))) + (DO ((G168798 |doms| (CDR G168798)) (|dom| NIL)) + ((OR (ATOM G168798) + (PROGN (SETQ |dom| (CAR G168798)) NIL)) + NIL) + (SEQ (EXIT (|sayBrightly| + (CONS (MAKESTRING " importing ") + (|formatUnabbreviated| |dom|)))))) + (SPADLET |LETTMP#1| + (|compOrCroak| |item| |$EmptyMode| |$e|)) + (SPADLET |$e| (CADDR |LETTMP#1|)) + (|wiReplaceNode| |item| '(PROGN) 10)) + ((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)) + (|doItDef| |item|)) + ((SPADLET T$ (|compOrCroak| |item| |$EmptyMode| |$e|)) + (|doItExpression| |item| T$)) + ('T (|cannotDo|)))))))) + +;holdIt item == item + +(DEFUN |holdIt| (|item|) |item|) + +;doItIf(item is [.,p,x,y],$predl,$e) == +; olde:= $e +; [p',.,$e]:= qt(19,comp(p,$Boolean,$e)) or userError ['"not a Boolean:",p] +; oldFLP:=$functorLocalParameters +; if x^="noBranch" then +;--> new <----------------------- +; qe(20,compSingleCapsuleItem(x,[p,:$predl],getSuccessEnvironment(markKillAll p,$e))) +;---> new ----------- +; 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,:REVERSE nils] +; REVERSE ans +; oldFLP:=$functorLocalParameters +; if y^="noBranch" then +;--> new <----------------------- +; qe(21,compSingleCapsuleItem(y,[['not, p],:$predl],getInverseEnvironment(markKillAll p,olde))) +;--> ----------- +; y':=localExtras(oldFLP) +; wiReplaceNode(item,["COND",[p',x,:x'],['(QUOTE T),y,:y']],12) + +(DEFUN |doItIf,localExtras| (|oldFLP|) + (PROG (|oldFLP'| |flp1| |ISTMP#1| |gv| |ans| |nils| |n|) + (declare (special |$functorLocalParameters| |$getDomainCode|)) + (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 ((G168862 |flp1| (CDR G168862)) (|u| NIL)) + ((OR (ATOM G168862) + (PROGN (SETQ |u| (CAR G168862)) NIL)) + NIL) + (SEQ (IF (OR (ATOM |u|) + (PROG (G168868) + (SPADLET G168868 NIL) + (RETURN + (DO ((G168876 NIL G168868) + (G168877 |$getDomainCode| + (CDR G168877)) + (|v| NIL)) + ((OR G168876 (ATOM G168877) + (PROGN + (SETQ |v| (CAR G168877)) + NIL)) + G168868) + (SEQ (EXIT + (SETQ G168868 + (OR G168868 + (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| (REVERSE |nils|))) + (EXIT (REVERSE |ans|)))))) + +(DEFUN |doItIf| (|item| |$predl| |$e|) + (DECLARE (SPECIAL |$predl| |$e|)) + (PROG (|p| |x| |y| |olde| |LETTMP#1| |p'| |x'| |oldFLP| |y'|) + (declare (special |$functorLocalParameters| |$Boolean|)) + (RETURN + (PROGN + (SPADLET |p| (CADR |item|)) + (SPADLET |x| (CADDR |item|)) + (SPADLET |y| (CADDDR |item|)) + (SPADLET |olde| |$e|) + (SPADLET |LETTMP#1| + (OR (|qt| 19 (|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|) + (|qe| 20 + (|compSingleCapsuleItem| |x| (CONS |p| |$predl|) + (|getSuccessEnvironment| (|markKillAll| |p|) |$e|))) + (SPADLET |x'| (|doItIf,localExtras| |oldFLP|)))) + (SPADLET |oldFLP| |$functorLocalParameters|) + (COND + ((NEQUAL |y| '|noBranch|) + (|qe| 21 + (|compSingleCapsuleItem| |y| + (CONS (CONS '|not| (CONS |p| NIL)) |$predl|) + (|getInverseEnvironment| (|markKillAll| |p|) + |olde|))) + (SPADLET |y'| (|doItIf,localExtras| |oldFLP|)))) + (|wiReplaceNode| |item| + (CONS 'COND + (CONS (CONS |p'| (CONS |x| |x'|)) + (CONS (CONS ''T (CONS |y| |y'|)) NIL))) + 12))))) + +;doItSeq item == +; ['SEQ,:l,['exit,1,x]] := item +; RPLACA(item,"PROGN") +; RPLACA(LASTNODE item,x) +; for it1 in rest item repeat $e:= compSingleCapsuleItem(it1,$predl,$e) + +(DEFUN |doItSeq| (|item|) + (PROG (|LETTMP#1| |x| |l|) + (declare (special |$e| |$predl|)) + (RETURN + (SEQ (PROGN + (SPADLET |LETTMP#1| (REVERSE (CDR |item|))) + (COND ((EQUAL (CADAR |LETTMP#1|) 1) (CADAR |LETTMP#1|))) + (SPADLET |x| (CADDAR |LETTMP#1|)) + (SPADLET |l| (NREVERSE (CDR |LETTMP#1|))) + (RPLACA |item| 'PROGN) + (RPLACA (LASTNODE |item|) |x|) + (DO ((G168945 (CDR |item|) (CDR G168945)) (|it1| NIL)) + ((OR (ATOM G168945) + (PROGN (SETQ |it1| (CAR G168945)) NIL)) + NIL) + (SEQ (EXIT (SPADLET |$e| + (|compSingleCapsuleItem| |it1| + |$predl| |$e|)))))))))) + +;doItDomain item == +; -- convert naked top level domains to import +; u:= ['import, [first item,:rest item]] +; markImport CADR u +; stackWarning ["Use: import ", [first item,:rest item]] +;--wiReplaceNode(item, u, 14) +; RPLACA(item, first u) +; RPLACD(item, rest u) +; doIt(item,$predl) + +(DEFUN |doItDomain| (|item|) + (PROG (|u|) + (declare (special |$predl|)) + (RETURN + (PROGN + (SPADLET |u| + (CONS '|import| + (CONS (CONS (CAR |item|) (CDR |item|)) NIL))) + (|markImport| (CADR |u|)) + (|stackWarning| + (CONS '|Use: import | + (CONS (CONS (CAR |item|) (CDR |item|)) NIL))) + (RPLACA |item| (CAR |u|)) + (RPLACD |item| (CDR |u|)) + (|doIt| |item| |$predl|))))) + +;doItLet item == +; qe(3,$e) +; res := doItLet1 item +; qe(4,$e) +; res + +(DEFUN |doItLet| (|item|) + (PROG (|res|) + (declare (special |$e|)) + (RETURN + (PROGN + (|qe| 3 |$e|) + (SPADLET |res| (|doItLet1| |item|)) + (|qe| 4 |$e|) + |res|)))) + +;doItLet1 item == +; ['LET,lhs,rhs,:.] := item +; not (compOrCroak(item,$EmptyMode,$e) is [code,.,$e]) => +; stackSemanticError(["cannot compile assigned value to",:bright lhs],nil) +; qe(5,$e) +; code := markKillAll code +; not (code is ['LET,lhs',rhs',:.] and atom lhs') => +; code is ["PROGN",:.] => +; stackSemanticError(["multiple assignment ",item," not allowed"],nil) +; wiReplaceNode(item, code, 24) +; lhs:= lhs' +; if not MEMBER(KAR rhs,$NonMentionableDomainNames) and +; not MEMQ(lhs, $functorLocalParameters) then +; $functorLocalParameters:= [:$functorLocalParameters,lhs] +; if (rhs' := rhsOfLetIsDomainForm code) then +; if isFunctor rhs' then +; $functorsUsed:= insert(opOf rhs',$functorsUsed) +; $packagesUsed:= insert([opOf rhs'],$packagesUsed) +; $globalImportDefAlist := pp [[lhs, :rhs'],:$globalImportDefAlist] +; 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] +;--+ +; qe(6,$e) +; code is ['LET,:.] => +; rhsCode:= rhs' +; op := ($QuickCode => 'QSETREFV;'SETELT) +; wiReplaceNode(item,[op,'$,NRTgetLocalIndexClear lhs,rhsCode], 16) +; wiReplaceNode(item, code, 18) + +(DEFUN |doItLet1| (|item|) + (PROG (|rhs| |ISTMP#3| |code| |ISTMP#1| |lhs'| |ISTMP#2| |lhs| |rhs'| + |rhsCode| |op|) + (declare (special |$QuickCode| |$e| |$LocalDomainAlist| |$Representation| + |$NRTopt| |$globalImportDefAlist| |$packagesUsed| + |$functorsUsed| |$functorLocalParameters| |$EmptyMode| + |$NonMentionableDomainNames| )) + (RETURN + (PROGN + (SPADLET |lhs| (CADR |item|)) + (SPADLET |rhs| (CADDR |item|)) + (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)) + ('T (|qe| 5 |$e|) (SPADLET |code| (|markKillAll| |code|)) + (COND + ((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 (|wiReplaceNode| |item| |code| 24)))) + ('T (SPADLET |lhs| |lhs'|) + (COND + ((AND (NULL (|member| (KAR |rhs|) + |$NonMentionableDomainNames|)) + (NULL (MEMQ |lhs| |$functorLocalParameters|))) + (SPADLET |$functorLocalParameters| + (APPEND |$functorLocalParameters| + (CONS |lhs| NIL))))) + (COND + ((SPADLET |rhs'| (|rhsOfLetIsDomainForm| |code|)) + (COND + ((|isFunctor| |rhs'|) + (SPADLET |$functorsUsed| + (|insert| (|opOf| |rhs'|) |$functorsUsed|)) + (SPADLET |$packagesUsed| + (|insert| (CONS (|opOf| |rhs'|) NIL) + |$packagesUsed|)) + (SPADLET |$globalImportDefAlist| + (|pp| (CONS (CONS |lhs| |rhs'|) + |$globalImportDefAlist|))))) + (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|)))) + (|qe| 6 |$e|) + (COND + ((AND (PAIRP |code|) (EQ (QCAR |code|) 'LET)) + (SPADLET |rhsCode| |rhs'|) + (SPADLET |op| + (COND (|$QuickCode| 'QSETREFV) ('T 'SETELT))) + (|wiReplaceNode| |item| + (CONS |op| + (CONS '$ + (CONS (|NRTgetLocalIndexClear| |lhs|) + (CONS |rhsCode| NIL)))) + 16)) + ('T (|wiReplaceNode| |item| |code| 18))))))))))) + +;rhsOfLetIsDomainForm code == +; code is ['LET,.,rhs',:.] => +; isDomainForm(rhs',$e) => rhs' +; isDomainForm(rhs' := markKillAll rhs',$e) => rhs' +; false +; false + +(DEFUN |rhsOfLetIsDomainForm| (|code|) + (PROG (|ISTMP#1| |ISTMP#2| |rhs'|) + (declare (special |$e|)) + (RETURN + (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)))))) + (COND + ((|isDomainForm| |rhs'| |$e|) |rhs'|) + ((|isDomainForm| (SPADLET |rhs'| (|markKillAll| |rhs'|)) + |$e|) + |rhs'|) + ('T NIL))) + ('T NIL))))) + +;doItDef item == +; ['DEF,[op,:.],:.] := item +; body:= isMacro(item,$e) => $e:= put(op,'macro,body,$e) +; [.,.,$e]:= t:= compOrCroak(item,$EmptyMode,$e) +; chk(item,3) +; RPLACA(item,"CodeDefine") +; --Note that DescendCode, in CodeDefine, is looking for this +; RPLACD(CADR item,[$signatureOfForm]) +; chk(item,4) +; --This is how the signature is updated for buildFunctor to recognise +;--+ +; functionPart:= ['dispatchFunction,t.expr] +; wiReplaceNode(CDDR item,[functionPart], 20) +; chk(item, 30) + +(DEFUN |doItDef| (|item|) + (PROG (|op| |body| |t| |functionPart|) + (declare (special |$signatureOfForm| |$e|)) + (RETURN + (PROGN + (SPADLET |op| (CAADR |item|)) + (COND + ((SPADLET |body| (|isMacro| |item| |$e|)) + (SPADLET |$e| (|put| |op| '|macro| |body| |$e|))) + ('T (SPADLET |t| (|compOrCroak| |item| |$EmptyMode| |$e|)) + (SPADLET |$e| (CADDR |t|)) (|chk| |item| 3) + (RPLACA |item| '|CodeDefine|) + (RPLACD (CADR |item|) (CONS |$signatureOfForm| NIL)) + (|chk| |item| 4) + (SPADLET |functionPart| + (CONS '|dispatchFunction| (CONS (CAR |t|) NIL))) + (|wiReplaceNode| (CDDR |item|) (CONS |functionPart| NIL) 20) + (|chk| |item| 30))))))) + +;doItExpression(item,T) == +; SETQ($ITEM,COPY item) +; SETQ($T1,COPY T.expr) +; chk(T.expr, 304) +; u := markCapsuleExpression(item, T) +; [code,.,$e]:= u +; wiReplaceNode(item,code, 22) + +(DEFUN |doItExpression| (|item| T$) + (PROG (|u| |code|) + (declare (special |$e| $ITEM $T1)) + (RETURN + (PROGN + (SETQ $ITEM (COPY |item|)) + (SETQ $T1 (COPY (CAR T$))) + (|chk| (CAR T$) 304) + (SPADLET |u| (|markCapsuleExpression| |item| T$)) + (SPADLET |code| (CAR |u|)) + (SPADLET |$e| (CADDR |u|)) + (|wiReplaceNode| |item| |code| 22))))) + +;wiReplaceNode(node,ocode,key) == +; ncode := CONS(first ocode, rest ocode) +; code := replaceNodeInStructureBy(node,ncode) +; SETQ($NODE,COPY node) +; SETQ($NODE1, COPY first code) +; SETQ($NODE2, COPY rest code) +; RPLACA(node,first code) +; RPLACD(node,rest code) +; chk(code, key) +; chk(node, key + 1) + +(DEFUN |wiReplaceNode| (|node| |ocode| |key|) + (PROG (|ncode| |code|) + (declare (special $node $node1 $node2)) + (RETURN + (PROGN + (SPADLET |ncode| (CONS (CAR |ocode|) (CDR |ocode|))) + (SPADLET |code| (|replaceNodeInStructureBy| |node| |ncode|)) + (SETQ $NODE (COPY |node|)) + (SETQ $NODE1 (COPY (CAR |code|))) + (SETQ $NODE2 (COPY (CDR |code|))) + (RPLACA |node| (CAR |code|)) + (RPLACD |node| (CDR |code|)) + (|chk| |code| |key|) + (|chk| |node| (PLUS |key| 1)))))) + +;replaceNodeInStructureBy(node, x) == +; $nodeCopy: local := [CAR node,:CDR node] +; replaceNodeBy(node, x) +; node + +(DEFUN |replaceNodeInStructureBy| (|node| |x|) + (PROG (|$nodeCopy|) + (DECLARE (SPECIAL |$nodeCopy|)) + (RETURN + (PROGN + (SPADLET |$nodeCopy| (CONS (CAR |node|) (CDR |node|))) + (|replaceNodeBy| |node| |x|) + |node|)))) + +;replaceNodeBy(node, x) == +; atom x => nil +; for y in tails x | EQCAR(x,node) repeat RPLAC(CAR x, $nodeCopy) +; nil + +(DEFUN |replaceNodeBy| (|node| |x|) + (declare (special |$nodeCopy|)) + (SEQ (COND + ((ATOM |x|) NIL) + ('T + (DO ((|y| |x| (CDR |y|))) ((ATOM |y|) NIL) + (SEQ (EXIT (COND + ((EQCAR |x| |node|) + (RPLAC (CAR |x|) |$nodeCopy|)))))) + NIL)))) + +;chk(x,key) == fn(x,0,key) where fn(x,cnt,key) == +; cnt > 10000 => +; sayBrightly ["--> ", key, " <---"] +; hahaha(key) +; atom x => cnt +; VECP x => systemError nil +; for y in x repeat cnt := fn(y, cnt + 1, key) +; cnt +; + +(DEFUN |chk,fn| (|x| |cnt| |key|) + (SEQ (IF (> |cnt| 10000) + (EXIT (SEQ (|sayBrightly| + (CONS (MAKESTRING "--> ") + (CONS |key| + (CONS (MAKESTRING " <---") NIL)))) + (EXIT (|hahaha| |key|))))) + (IF (ATOM |x|) (EXIT |cnt|)) + (IF (VECP |x|) (EXIT (|systemError| NIL))) + (DO ((G169120 |x| (CDR G169120)) (|y| NIL)) + ((OR (ATOM G169120) + (PROGN (SETQ |y| (CAR G169120)) NIL)) + NIL) + (SEQ (EXIT (SPADLET |cnt| (|chk,fn| |y| (PLUS |cnt| 1) |key|))))) + (EXIT |cnt|))) + +(DEFUN |chk| (|x| |key|) (|chk,fn| |x| 0 |key|)) + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document}