\documentclass{article} \usepackage{axiom} \title{\File{src/interp/wi2.boot} Pamphlet} \author{The Axiom Team} \begin{document} \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. @ <<*>>= <> )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 $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] GETL(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}