aboutsummaryrefslogtreecommitdiff
path: root/src/interp/wi2.boot.pamphlet
diff options
context:
space:
mode:
Diffstat (limited to 'src/interp/wi2.boot.pamphlet')
-rw-r--r--src/interp/wi2.boot.pamphlet1256
1 files changed, 1256 insertions, 0 deletions
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}
+
+<<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.
+
+@
+<<*>>=
+<<license>>
+
+)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}
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-02 18:11:33 +0000