From ab8cc85adde879fb963c94d15675783f2cf4b183 Mon Sep 17 00:00:00 2001 From: dos-reis Date: Tue, 14 Aug 2007 05:14:52 +0000 Subject: Initial population. --- src/interp/wi2.boot.pamphlet | 1256 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 1256 insertions(+) create mode 100644 src/interp/wi2.boot.pamphlet (limited to 'src/interp/wi2.boot.pamphlet') diff --git a/src/interp/wi2.boot.pamphlet b/src/interp/wi2.boot.pamphlet new file mode 100644 index 00000000..75e650a3 --- /dev/null +++ b/src/interp/wi2.boot.pamphlet @@ -0,0 +1,1256 @@ +\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 + $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] + 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} -- cgit v1.2.3