diff options
Diffstat (limited to 'src/interp/wi1.boot.pamphlet')
| -rw-r--r-- | src/interp/wi1.boot.pamphlet | 1287 |
1 files changed, 0 insertions, 1287 deletions
diff --git a/src/interp/wi1.boot.pamphlet b/src/interp/wi1.boot.pamphlet deleted file mode 100644 index a86a7da2..00000000 --- a/src/interp/wi1.boot.pamphlet +++ /dev/null @@ -1,1287 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/wi1.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" - --- !! do not delete the next function ! - -spad2AsTranslatorAutoloadOnceTrigger() == nil - -pairList(u,v) == [[x,:y] for x in u for y in v] - ---====================================================================== --- Temporary definitions---for tracing and debugging ---====================================================================== -tr fn == - $convertingSpadFile : local := true - $options: local := nil - sfn := STRINGIMAGE fn - newname := STRCONC(sfn,'".as") - $outStream :local := MAKE_-OUTSTREAM newname - markSay '"#pile" - markSay('"#include _"axiom.as_"") - markTerpri() - CATCH("SPAD__READER",compiler [INTERN sfn]) - SHUT $outStream - -stackMessage msg == ---if msg isnt ["cannot coerce: ",:.] then foobum msg - $compErrorMessageStack:= [msg,:$compErrorMessageStack] - nil - -ppFull x == - _*PRINT_-LEVEL_* : local := nil - _*PRINT_-DEPTH_* : local := nil - _*PRINT_-LENGTH_* : local := nil - pp x - -put(x,prop,val,e) == ---if prop = 'mode and CONTAINED('PART,val) then foobar val - $InteractiveMode and not EQ(e,$CategoryFrame) => - putIntSymTab(x,prop,val,e) - --e must never be $CapsuleModemapFrame - null atom x => put(first x,prop,val,e) - newProplist:= augProplistOf(x,prop,val,e) - prop="modemap" and $insideCapsuleFunctionIfTrue=true => - SAY ["**** modemap PUT on CapsuleModemapFrame: ",val] - $CapsuleModemapFrame:= - addBinding(x,augProplistOf(x,"modemap",val,$CapsuleModemapFrame), - $CapsuleModemapFrame) - e - addBinding(x,newProplist,e) - -addBinding(var,proplist,e is [[curContour,:tailContour],:tailEnv]) == ---if CONTAINED('PART,proplist) then foobar proplist - EQ(proplist,getProplist(var,e)) => e - $InteractiveMode => addBindingInteractive(var,proplist,e) - if curContour is [[ =var,:.],:.] then curContour:= rest curContour - --Previous line should save some space - [[[lx,:curContour],:tailContour],:tailEnv] where lx:= [var,:proplist] - ---====================================================================== --- From define.boot ---====================================================================== -compJoin(["Join",:argl],m,e) == - catList:= [(compForMode(x,$Category,e) or return 'failed).expr for x in argl] - catList='failed => stackSemanticError(["cannot form Join of: ",argl],nil) - catList':= - [extract for x in catList] where - extract() == - x := markKillAll x - isCategoryForm(x,e) => - parameters:= - union("append"/[getParms(y,e) for y in rest x],parameters) - where getParms(y,e) == - atom y => - isDomainForm(y,e) => LIST y - nil - y is ['LENGTH,y'] => [y,y'] - LIST y - x - x is ["DomainSubstitutionMacro",pl,body] => - (parameters:= union(pl,parameters); body) - x is ["mkCategory",:.] => x - atom x and getmode(x,e)=$Category => x - stackSemanticError(["invalid argument to Join: ",x],nil) - x - T:= [wrapDomainSub(parameters,["Join",:catList']),$Category,e] - convert(T,m) - - -compDefineFunctor(dfOriginal,m,e,prefix,fal) == - df := markInsertParts dfOriginal - $domainShell: local -- holds the category of the object being compiled - $profileCompiler: local := true - $profileAlist: local := nil - $LISPLIB => compDefineLisplib(df,m,e,prefix,fal,'compDefineFunctor1) - compDefineFunctor1(df,m,e,prefix,fal) - -compDefineLisplib(df,m,e,prefix,fal,fn) == - ["DEF",[op,:.],:.] := df - --fn= compDefineCategory OR compDefineFunctor - sayMSG fillerSpaces(72,'"-") - $LISPLIB: local := 'T - $op: local := op - $lisplibAttributes: local := NIL - $lisplibPredicates: local := NIL -- set by makePredicateBitVector - $lisplibCategoriesExtended: local := NIL -- this is always nil. why? (tpd) - $lisplibForm: local := NIL - $lisplibKind: local := NIL - $lisplibModemap: local := NIL - $lisplibModemapAlist: local := NIL - $lisplibSlot1 : local := NIL -- used by NRT mechanisms - $lisplibOperationAlist: local := NIL - $lisplibSuperDomain: local := NIL - $libFile: local := NIL - $lisplibVariableAlist: local := NIL - $lisplibRelatedDomains: local := NIL --from ++ Related Domains: see c-doc - $lisplibCategory: local := nil - --for categories, is rhs of definition; otherwise, is target of functor - --will eventually become the "constructorCategory" property in lisplib - --set in compDefineCategory if category, otherwise in finalizeLisplib - libName := getConstructorAbbreviation op - -- $incrementalLisplibFlag seems never to be set so next line not used - -- originalLisplibCategory:= getLisplib(libName,'constructorCategory) - BOUNDP '$compileDocumentation and $compileDocumentation => - compileDocumentation libName - sayMSG ['" initializing ",$spadLibFT,:bright libName, - '"for",:bright op] - initializeLisplib libName - sayMSG ['" compiling into ",$spadLibFT,:bright libName] - res:= FUNCALL(fn,df,m,e,prefix,fal) - sayMSG ['" finalizing ",$spadLibFT,:bright libName] ---finalizeLisplib libName - FRESH_-LINE $algebraOutputStream - sayMSG fillerSpaces(72,'"-") - unloadOneConstructor(op,libName) - res - -compTopLevel(x,m,e) == ---+ signals that target is derived from lhs-- see NRTmakeSlot1Info - $NRTderivedTargetIfTrue: local := false - $killOptimizeIfTrue: local:= false - $forceAdd: local:= false - $compTimeSum: local := 0 - $resolveTimeSum: local := 0 - $packagesUsed: local := [] - -- The next line allows the new compiler to be tested interactively. - compFun := if $newCompAtTopLevel=true then 'newComp else 'compOrCroak - if x is ["where",:.] then x := markWhereTran x - def := - x is ["where",a,:.] => a - x - $originalTarget : local := - def is ["DEF",.,[target,:.],:.] => target - 'sorry - x is ["DEF",:.] or x is ["where",["DEF",:.],:.] => - ([val,mode,.]:= FUNCALL(compFun,x,m,e); [val,mode,e]) - --keep old environment after top level function defs - FUNCALL(compFun,x,m,e) - -markWhereTran ["where",["DEF",form,sig,clist,body],:tail] == - items := - tail is [['SEQ,:l,['exit,n,x]]] => [:l,x] - [first tail] - [op,:argl] := form - [target,:atypeList] := sig - decls := [[":",a,b] for a in argl for b in atypeList | b] --- not (and/[null x for x in atypeList]) => --- systemError ['"unexpected WHERE argument list: ",:atypeList] - for x in items repeat - x is [":",a,b] => - a is ['LISTOF,:r] => - for y in r repeat decls := [[":",y,b],:decls] - decls := [x,:decls] - x is [key,fn,p,q,bd] and MEMQ(key,'(DEF MDEF)) and p='(NIL) and q='(NIL) => - fn = target or fn is [=target] => ttype := bd - fn = body or fn is [=body] => body := bd - macros := [x,:macros] - systemError ['"unexpected WHERE item: ",x] - nargtypes := [p for arg in argl | - p := or/[t for d in decls | d is [.,=arg,t]] or - systemError ['"Missing WHERE declaration for :", arg]] - nform := form - ntarget := ttype or target - ndef := ['DEF,nform,[ntarget,:nargtypes],clist,body] - result := - REVERSE macros is [:m,e] => - mpart := - m => ['SEQ,:m,['exit,1,e]] - e - ['where,ndef,mpart] - ndef - result - -compPART(u,m,e) == ---------new------------------------------------------94/10/11 - ['PART,.,x] := u - T := comp(x,m,e) => markAny('compPART,u, T) - nil - -xxxxx x == x - -qt(n,T) == - null T => nil - if null getProplist('R,T.env) then xxxxx n - T - -qe(n,e) == - if null getProplist('R,e) then xxxxx n - e - -comp(x,m,e) == - qe(7,e) - T := qt(8,comp0(x,m,e)) => qt(9,markComp(x,T)) ---T := m = "$" and comp(x,$EmptyMode,e) => coerce(T, m) - --------------------------------------------------------94/11/10 - nil - -comp0(x,m,e) == - qe(8,e) ---version of comp which skips the marking (see compReduce1) - T:= compNoStacking(x,m,e) => - $compStack:= nil - qt(10,T) - $compStack:= [[x,m,e,$exitModeStack],:$compStack] - nil - -compNoStacking(xOrig,m,e) == - $partExpression: local := nil - xOrig := markKillAllRecursive xOrig --->xOrig is ['PART,n,x] => compNoStackingAux(xOrig,m,e) -----------------------------------------------------------94/10/11 - qt(11,compNoStacking0(xOrig,m,e)) - -markKillAllRecursive x == - x is [op,:r] => ---->op = 'PART => markKillAllRecursive CADR r - op = 'PART => ['PART, CAR r, markKillAllRecursive CADR r] -----------------------------------------------------------94/10/11 - constructor? op => markKillAll x - op = 'elt and constructor? opOf CAR r => - ['elt,markKillAllRecursive CAR r,CADR r] - x - x - -compNoStackingAux($partExpression,m,e) == ------------------not used---------------------94/10/11 - x := CADDR $partExpression - T := compNoStacking0(x,m,e) or return nil - markParts($partExpression,T) - -compNoStacking0(x,m,e) == - qe(1,e) - T := compNoStacking01(x,m,qe(51,e)) - qt(52,T) - -compNoStacking01(x,m,e) == ---compNoStacking0(x,m,e) == - if CONTAINED('MI,m) then m := markKillAll(m) - T:= comp2(x,m,e) => - (m=$EmptyMode and T.mode=IFCAR(get('Rep,'value,e)) => - [T.expr,"Rep",T.env]; qt(12,T)) - --$Representation is bound in compDefineFunctor, set by doIt - --this hack says that when something is undeclared, $ is - --preferred to the underlying representation -- RDJ 9/12/83 - T := compNoStacking1(x,m,e,$compStack) - qt(13,T) - -compNoStacking1(x,m,e,$compStack) == - u:= get(if m="$" then "Rep" else m,"value",e) => - m1 := markKillAll u.expr ---------------------> new <------------------------- - T:= comp2(x,m1,e) => coerce(T,m) - nil ---------------------> new <------------------------- - nil - -compWithMappingMode(x,m,oldE) == - ["Mapping",m',:sl] := m - $killOptimizeIfTrue: local:= true - e:= oldE - x := markKillAll x - ------------------ - m := markKillAll m - ------------------ ---if x is ['PART,.,y] then x := y ---------------------------------- - isFunctor x => - if get(x,"modemap",$CategoryFrame) is [[[.,target,:argModeList],.],:.] and - (and/[extendsCategoryForm("$",s,mode) for mode in argModeList for s in sl] - ) and extendsCategoryForm("$",target,m') then return [x,m,e] - if STRINGP x then x:= INTERN x - for m in sl for v in (vl:= take(#sl,$FormalMapVariableList)) repeat - [.,.,e]:= compMakeDeclaration([":",v,m],$EmptyMode,e) - not null vl and not hasFormalMapVariable(x, vl) => return - [u,.,.] := comp([x,:vl],m',e) or return nil - extractCodeAndConstructTriple(u, m, oldE) - null vl and (t := comp([x], m', e)) => return - [u,.,.] := t - extractCodeAndConstructTriple(u, m, oldE) - [u,.,.]:= comp(x,m',e) or return nil - originalFun := u - if originalFun is ['WI,a,b] then u := b - uu := ['LAMBDA,vl,u] - --------------------------> 11/28 drop COMP-TRAN, optimizations - T := [uu,m,oldE] - originalFun is ['WI,a,b] => markLambda(vl,a,m,T) - markLambda(vl,originalFun,m,T) - -compAtom(x,m,e) == - T:= compAtomWithModemap(x,m,e,get(x,"modemap",e)) => markCompAtom(x,T) - x="nil" => - T:= - modeIsAggregateOf('List,m,e) is [.,R]=> compList(x,['List,R],e) - modeIsAggregateOf('Vector,m,e) is [.,R]=> compVector(x,['Vector,R],e) - T => convert(T,m) ---> - FIXP x and MEMQ(opOf m, '(Integer NonNegativeInteger PositiveInteger SmallInteger)) => markAt [x,m,e] --- FIXP x and (T := [x, $Integer,e]) and (T' := convert(T,m)) => markAt(T, T') - t:= - isSymbol x => - compSymbol(x,m,e) or return nil - m = $Expression and primitiveType x => [x,m,e] - STRINGP x => - x ^= '"failed" and (member('(Symbol), $localImportStack) or - member('(Symbol), $globalImportStack)) => markAt [x, '(String), e] - [x, x, e] - [x,primitiveType x or return nil,e] - convert(t,m) - -extractCodeAndConstructTriple(u, m, oldE) == - u := markKillAll u - u is ["call",fn,:.] => - if fn is ["applyFun",a] then fn := a - [fn,m,oldE] - [op,:.,env] := u - [["CONS",["function",op],env],m,oldE] - -compSymbol(s,m,e) == - s="$NoValue" => ["$NoValue",$NoValueMode,e] - isFluid s => [s,getmode(s,e) or return nil,e] - s="true" => ['(QUOTE T),$Boolean,e] - s="false" => [false,$Boolean,e] - s=m or get(s,"isLiteral",e) => [["QUOTE",s],s,e] - v:= get(s,"value",e) => ---+ - MEMQ(s,$functorLocalParameters) => - NRTgetLocalIndex s - [s,v.mode,e] --s will be replaced by an ELT form in beforeCompile - [s,v.mode,e] --s has been SETQd - m':= getmode(s,e) => - if not member(s,$formalArgList) and not MEMQ(s,$FormalMapVariableList) and - not isFunction(s,e) and null ($compForModeIfTrue=true) then errorRef s - [s,m',e] --s is a declared argument - MEMQ(s,$FormalMapVariableList) => stackMessage ["no mode found for",s] ----> - m = $Symbol or m = $Expression => [['QUOTE,s],m,e] - ---> was ['QUOTE, s] - not isFunction(s,e) => errorRef s - -compForm(form,m,e) == - if form is [['PART,.,op],:r] then form := [op,:r] - ----------------------------------------------------- 94/10/16 - T:= - compForm1(form,m,e) or compArgumentsAndTryAgain(form,m,e) or return - stackMessageIfNone ["cannot compile","%b",form,"%d"] - T - -compForm1(form,m,e) == - [op,:argl] := form - $NumberOfArgsIfInteger: local:= #argl --see compElt - op="error" => - [[op,:[([.,.,e]:=outputComp(x,e)).expr - for x in argl]],m,e] - op is ['MI,a,b] => compForm1([markKillExpr b,:argl],m,e) - op is ["elt",domain,op'] => - domain := markKillAll domain - domain="Lisp" => - --op'='QUOTE and null rest argl => [first argl,m,e] - val := [op',:[([.,.,e]:= compOrCroak(x,$EmptyMode,e)).expr for x in argl]] - markLisp([val,m,e],m) --------> new <------------- --- foobar domain --- markImport(domain,true) --------> new <------------- - domain=$Expression and op'="construct" => compExpressionList(argl,m,e) - (op'="COLLECT") and coerceable(domain,m,e) => - (T:= comp([op',:argl],domain,e) or return nil; coerce(T,m)) --------> new <------------- - domain= 'Rep and - (ans := compForm2([op',:argl],SUBST('Rep,'_$,m),e:= addDomain(domain,e), - [SUBST('Rep,'_$,x) for x in getFormModemaps([op',:argl],e) - | x is [[ =domain,:.],:.]])) => ans --------> new <------------- - ans := compForm2([op',:argl],m,e:= addDomain(domain,e), - [x for x in getFormModemaps([op',:argl],e) | x is [[ =domain,:.],:.]]) => ans - (op'="construct") and coerceable(domain,m,e) => - (T:= comp([op',:argl],domain,e) or return nil; coerce(T,m)) - nil - - e:= addDomain(m,e) --???unneccessary because of comp2's call??? - (mmList:= getFormModemaps(form,e)) and (T:= compForm2(form,m,e,mmList)) => T - compToApply(op,argl,m,e) - ---% WI and MI - -compForm3(form is [op,:argl],m,e,modemapList) == ---order modemaps so that ones from Rep are moved to the front - modemapList := compFormOrderModemaps(modemapList,m = "$") - qe(22,e) - T:= - or/ - [compFormWithModemap(form,m,e,first (mml:= ml)) - for ml in tails modemapList] or return nil - qt(14,T) - result := - $compUniquelyIfTrue => - or/[compFormWithModemap(form,m,e,mm) for mm in rest mml] => - THROW("compUniquely",nil) - qt(15,T) - qt(16,T) - qt(17,markAny('compForm3,form,result)) - -compFormOrderModemaps(mml,targetIsDollar?) == ---order modemaps so that ones from Rep are moved to the front ---exceptions: if $ is the target and there are 2 modemaps with --- identical signatures, move the $ one ahead - repMms := [mm for (mm:= [[dc,:.],:.]) in mml | dc = 'Rep] - if repMms and targetIsDollar? then - dollarMms := [mm for (mm := [[dc,:sig],:.]) in mml | dc = "$" - and or/[mm1 for (mm1:= [[dc1,:sig1],:.]) in repMms | sig1 = sig]] - repMms := [:dollarMms, :repMms] - null repMms => mml - [:repMms,:SETDIFFERENCE(mml,repMms)] - -compWI(["WI",a,b],m,E) == - u := comp(b,m,E) - pp (u => "====> ok"; 'NO) - u - -compMI(["MI",a,b],m,E) == - u := comp(b,m,E) - pp (u => "====> ok"; 'NO) - u - -compWhere([.,form,:exprList],m,eInit) == - $insideExpressionIfTrue: local:= false - $insideWhereIfTrue: local:= true --- if not $insideFunctorIfTrue then --- $originalTarget := --- form is ['DEF,a,osig,:.] and osig is [otarget,:.] => --- exprList is [['SEQ,:l,['exit,n,y]]] and (u := [:l,y]) and --- (ntarget := or/[def for x in u | x is [op,a',:.,def] and ([op,a',otarget]) and --- MEMQ(op,'(DEF MDEF)) and (a' = otarget or a' is [=otarget])]) => --- [ntarget,:rest osig] --- osig --- nil --- foobum exprList - e:= eInit - u:= - for item in exprList repeat - [.,.,e]:= comp(item,$EmptyMode,e) or return "failed" - u="failed" => return nil - $insideWhereIfTrue:= false - [x,m,eAfter]:= comp(macroExpand(form,eBefore:= e),m,e) or return nil - eFinal:= - del:= deltaContour(eAfter,eBefore) => addContour(del,eInit) - eInit - [x,m,eFinal] - -compMacro(form,m,e) == - $macroIfTrue: local:= true - ["MDEF",lhs,signature,specialCases,rhs]:= form := markKillAll form - firstForm := ["MDEF",first lhs,'(NIL),'(NIL),rhs] - markMacro(first lhs,rhs) - rhs := - rhs is ['CATEGORY,:.] => ['"-- the constructor category"] - rhs is ['Join,:.] => ['"-- the constructor category"] - rhs is ['CAPSULE,:.] => ['"-- the constructor capsule"] - rhs is ['add,:.] => ['"-- the constructor capsule"] - formatUnabbreviated rhs - sayBrightly ['" processing macro definition",'%b, - :formatUnabbreviated lhs,'" ==> ",:rhs,'%d] - ["MDEF",lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e) - m=$EmptyMode or m=$NoValueMode => - ["/throwAway",$NoValueMode,put(first lhs,"macro",rhs,e)] - ---compMacro(form,m,e) == --- $macroIfTrue: local:= true --- ["MDEF",lhs,signature,specialCases,rhs]:= form --- rhs := --- rhs is ['CATEGORY,:.] => ['"-- the constructor category"] --- rhs is ['Join,:.] => ['"-- the constructor category"] --- rhs is ['CAPSULE,:.] => ['"-- the constructor capsule"] --- rhs is ['add,:.] => ['"-- the constructor capsule"] --- formatUnabbreviated rhs --- sayBrightly ['" processing macro definition",'%b, --- :formatUnabbreviated lhs,'" ==> ",:rhs,'%d] --- ["MDEF",lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e) --- m=$EmptyMode or m=$NoValueMode => --- rhs := markMacro(lhs,rhs) --- ["/throwAway",$NoValueMode,put(first lhs,"macro",rhs,e)] - -compSetq(oform,m,E) == - ["LET",form,val] := oform - T := compSetq1(form,val,m,E) => markSetq(oform,T) - nil - -compSetq1(oform,val,m,E) == - form := markKillAll oform - IDENTP form => setqSingle(form,val,m,E) - form is [":",x,y] => - [.,.,E']:= compMakeDeclaration(form,$EmptyMode,E) - compSetq(["LET",x,val],m,E') - form is [op,:l] => - op="CONS" => setqMultiple(uncons form,val,m,E) - op="Tuple" => setqMultiple(l,val,m,E) - setqSetelt(oform,form,val,m,E) - -setqSetelt(oform,[v,:s],val,m,E) == - T:= comp0(["setelt",:oform,val],m,E) or return nil ----> ------- - markComp(oform,T) - -setqSingle(id,val,m,E) == - $insideSetqSingleIfTrue: local:= true - --used for comping domain forms within functions - currentProplist:= getProplist(id,E) - m'':= get(id,'mode,E) or getmode(id,E) or - (if m=$NoValueMode then $EmptyMode else m) ------------------------> new <------------------------- - trialT := m'' = "$" and get("Rep",'value,E) and comp(val,'Rep,E) ------------------------> new <------------------------- - T:= - (trialT and coerce(trialT,m'')) or eval or return nil where - eval() == - T:= comp(val,m'',E) => T - not get(id,"mode",E) and m'' ^= (maxm'':=maxSuperType(m'',E)) and - (T:=comp(val,maxm'',E)) => T - (T:= comp(val,$EmptyMode,E)) and getmode(T.mode,E) => - assignError(val,T.mode,id,m'') - T':= [x,m',e']:= convert(T,m) or return nil - if $profileCompiler = true then - null IDENTP id => nil - key := - MEMQ(id,rest $form) => 'arguments - 'locals - profileRecord(key,id,T.mode) - newProplist:= consProplistOf(id,currentProplist,"value",markKillAll removeEnv T) - e':= (PAIRP id => e'; addBinding(id,newProplist,e')) - x1 := markKillAll x - if isDomainForm(x1,e') then - if isDomainInScope(id,e') then - stackWarning ["domain valued variable","%b",id,"%d", - "has been reassigned within its scope"] - e':= augModemapsFromDomain1(id,x1,e') - --all we do now is to allocate a slot number for lhs - --e.g. the LET form below will be changed by putInLocalDomainReferences ---+ - if (k:=NRTassocIndex(id)) - then - $markFreeStack := [id,:$markFreeStack] - form:=['SETELT,"$",k,x] - else form:= - $QuickLet => ["LET",id,x] - ["LET",id,x, - (isDomainForm(x,e') => ['ELT,id,0];CAR outputComp(id,e'))] - [form,m',e'] - -setqMultiple(nameList,val,m,e) == - val is ["CONS",:.] and m=$NoValueMode => - setqMultipleExplicit(nameList,uncons val,m,e) - val is ["Tuple",:l] and m=$NoValueMode => setqMultipleExplicit(nameList,l,m,e) - --1. create a gensym, %add to local environment, compile and assign rhs - g:= genVariable() - e:= addBinding(g,nil,e) - T:= [.,m1,.]:= compSetq1(g,val,$EmptyMode,e) or return nil - e:= put(g,"mode",m1,e) - [x,m',e]:= convert(T,m) or return nil - --1.1 exit if result is a list - m1 is ["List",D] => - for y in nameList repeat e:= put(y,"value",[genSomeVariable(),D,$noEnv],e) - convert([["PROGN",x,["LET",nameList,g],g],m',e],m) - --2. verify that the #nameList = number of parts of right-hand-side - selectorModePairs:= - --list of modes - decompose(m1,#nameList,e) or return nil where - decompose(t,length,e) == - t is ["Record",:l] => [[name,:mode] for [":",name,mode] in l] - comp(t,$EmptyMode,e) is [.,["RecordCategory",:l],.] => - [[name,:mode] for [":",name,mode] in l] - stackMessage ["no multiple assigns to mode: ",t] - #nameList^=#selectorModePairs => - stackMessage [val," must decompose into ",#nameList," components"] - -- 3.generate code; return - assignList:= - [([.,.,e]:= compSetq1(x,["elt",g,y],z,e) or return "failed").expr - for x in nameList for [y,:z] in selectorModePairs] - if assignList="failed" then NIL - else [MKPROGN [x,:assignList,g],m',e] - -setqMultipleExplicit(nameList,valList,m,e) == - #nameList^=#valList => - stackMessage ["Multiple assignment error; # of items in: ",nameList, - "must = # in: ",valList] - gensymList:= [genVariable() for name in nameList] - for g in gensymList for name in nameList repeat - e := put(g,"mode",get(name,"mode",e),e) - assignList:= - --should be fixed to declare genVar when possible - [[.,.,e]:= compSetq1(g,val,$EmptyMode,e) or return "failed" - for g in gensymList for val in valList for name in nameList] - assignList="failed" => nil - reAssignList:= - [[.,.,e]:= compSetq1(name,g,$EmptyMode,e) or return "failed" - for g in gensymList for name in nameList] - reAssignList="failed" => nil - T := [["PROGN",:[T.expr for T in assignList], - :[T.expr for T in reAssignList]], $NoValueMode, (LAST reAssignList).env] - markMultipleExplicit(nameList,valList,T) - -canReturn(expr,level,exitCount,ValueFlag) == --SPAD: exit and friends - atom expr => ValueFlag and level=exitCount - (op:= first expr)="QUOTE" => ValueFlag and level=exitCount - MEMQ(op,'(WI MI)) => canReturn(CADDR expr,level,count,ValueFlag) - op="TAGGEDexit" => - expr is [.,count,data] => canReturn(data.expr,level,count,count=level) - level=exitCount and not ValueFlag => nil - op="SEQ" => or/[canReturn(u,level+1,exitCount,false) for u in rest expr] - op="TAGGEDreturn" => nil - op="CATCH" => - [.,gs,data]:= expr - (findThrow(gs,data,level,exitCount,ValueFlag) => true) where - findThrow(gs,expr,level,exitCount,ValueFlag) == - atom expr => nil - expr is ["THROW", =gs,data] => true - --this is pessimistic, but I know of no more accurate idea - expr is ["SEQ",:l] => - or/[findThrow(gs,u,level+1,exitCount,ValueFlag) for u in l] - or/[findThrow(gs,u,level,exitCount,ValueFlag) for u in rest expr] - canReturn(data,level,exitCount,ValueFlag) - op = "COND" => - level = exitCount => - or/[canReturn(last u,level,exitCount,ValueFlag) for u in rest expr] - or/[or/[canReturn(u,level,exitCount,ValueFlag) for u in v] - for v in rest expr] - op="IF" => - expr is [.,a,b,c] - if not canReturn(a,0,0,true) and not (BOUNDP '$convert2NewCompiler and $convert2NewCompiler) then - SAY "IF statement can not cause consequents to be executed" - pp expr - canReturn(a,level,exitCount,nil) or canReturn(b,level,exitCount,ValueFlag) - or canReturn(c,level,exitCount,ValueFlag) - --now we have an ordinary form - atom op => and/[canReturn(u,level,exitCount,ValueFlag) for u in expr] - op is ["XLAM",args,bods] => - and/[canReturn(u,level,exitCount,ValueFlag) for u in expr] - systemErrorHere '"canReturn" --for the time being - -compList(l,m is ["List",mUnder],e) == - markImport m - markImport mUnder - null l => [NIL,m,e] - Tl:= [[.,mUnder,e]:= - comp(x,mUnder,e) or return "failed" for i in 1.. for x in l] - Tl="failed" => nil - T:= [["LIST",:[T.expr for T in Tl]],["List",mUnder],e] - -compVector(l,m is ["Vector",mUnder],e) == - markImport m - markImport mUnder - null l => [$EmptyVector,m,e] - Tl:= [[.,mUnder,e]:= comp(x,mUnder,e) or return "failed" for x in l] - Tl="failed" => nil - [["VECTOR",:[T.expr for T in Tl]],m,e] - -compColon([":",f,t],m,e) == - $insideExpressionIfTrue=true => compPretend(["pretend",f,t],m,e) - --if inside an expression, ":" means to convert to m "on faith" - f := markKillAll f - $lhsOfColon: local:= f - t:= - t := markKillAll t - atom t and (t':= ASSOC(t,getDomainsInScope e)) => t' - isDomainForm(t,e) and not $insideCategoryIfTrue => - (if not member(t,getDomainsInScope e) then e:= addDomain(t,e); t) - isDomainForm(t,e) or isCategoryForm(t,e) => t - t is ["Mapping",m',:r] => t - unknownTypeError t - t - if $insideCapsuleFunctionIfTrue then markDeclaredImport t - f is ["LISTOF",:l] => - (for x in l repeat T:= [.,.,e]:= compColon([":",x,t],m,e); T) - e:= - f is [op,:argl] and not (t is ["Mapping",:.]) => - --for MPOLY--replace parameters by formal arguments: RDJ 3/83 - newTarget:= EQSUBSTLIST(take(#argl,$FormalMapVariableList), - [(x is [":",a,m] => a; x) for x in argl],t) - signature:= - ["Mapping",newTarget,: - [(x is [":",a,m] => m; - getmode(x,e) or systemErrorHere '"compColonOld") for x in argl]] - put(op,"mode",signature,e) - put(f,"mode",t,e) - if not $bootStrapMode and $insideFunctorIfTrue and - makeCategoryForm(t,e) is [catform,e] then - e:= put(f,"value",[genSomeVariable(),t,$noEnv],e) - ["/throwAway",getmode(f,e),e] - -compConstruct(form,m,e) == (T := compConstruct1(form,m,e)) and markConstruct(form,T) - -compConstruct1(form is ["construct",:l],m,e) == - y:= modeIsAggregateOf("List",m,e) => - T:= compList(l,["List",CADR y],e) => convert(T,m) - y:= modeIsAggregateOf("Vector",m,e) => - T:= compVector(l,["Vector",CADR y],e) => convert(T,m) - T:= compForm(form,m,e) => T - for D in getDomainsInScope e repeat - (y:=modeIsAggregateOf("List",D,e)) and - (T:= compList(l,["List",CADR y],e)) and (T':= convert(T,m)) => - return T' - (y:=modeIsAggregateOf("Vector",D,e)) and - (T:= compVector(l,["Vector",CADR y],e)) and (T':= convert(T,m)) => - return T' - -compPretend(u := ["pretend",x,t],m,e) == - t := markKillAll t - m := markKillAll m - e:= addDomain(t,e) - T:= comp(x,t,e) or comp(x,$EmptyMode,e) or return nil - if T.mode=t then warningMessage:= ["pretend",t," -- should replace by @"] - T1:= [T.expr,t,T.env] - t = "$" and m = "Rep" => markPretend(T1,T1) -->! WATCH OUT: correct? !<-- - T':= coerce(T1,m) => - warningMessage => - stackWarning warningMessage - markCompColonInside("@",T') - markPretend(T1,T') - nil - -compAtSign(["@",x,m'],m,e) == - m' := markKillAll m' - m := markKillAll m - e:= addDomain(m',e) - T:= comp(x,m',e) or return nil - coerce(T,m) - -compColonInside(x,m,e,m') == - m' := markKillAll m' - e:= addDomain(m',e) - T:= comp(x,$EmptyMode,e) or return nil - if T.mode=m' then warningMessage:= [":",m'," -- should replace by ::"] - T:= [T.expr,m',T.env] - m := markKillAll m - T':= coerce(T,m) => - warningMessage => - stackWarning warningMessage - markCompColonInside("@",T') - stackWarning [":",m'," -- should replace by pretend"] - markCompColonInside("pretend",T') - nil - -resolve(min, mout) == - din := markKillAll min - dout := markKillAll mout - din=$NoValueMode or dout=$NoValueMode => $NoValueMode - dout=$EmptyMode => din - STRINGP din and dout = '(Symbol) => dout ------> hack 8/14/94 - STRINGP dout and din = '(Symbol) => din ------> hack 8/14/94 - din^=dout and (STRINGP din or STRINGP dout) => - modeEqual(dout,$String) => dout - modeEqual(din,$String) => nil - mkUnion(din,dout) - dout - -coerce(T,m) == - T := [T.expr,markKillAll T.mode,T.env] - m := markKillAll m - if not get(m, 'isLiteral,T.env) then markImport m - $InteractiveMode => - keyedSystemError("S2GE0016",['"coerce", - '"function coerce called from the interpreter."]) ---==================> changes <====================== ---The following line is inappropriate for our needs::: ---rplac(CADR T,substitute("$",$Rep,CADR T)) - T' := coerce0(T,m) => T' - T := [T.expr,fullSubstitute("$",$Representation,T.mode),T.env] ---==================> changes <====================== - coerce0(T,m) - -coerce0(T,m) == - T':= coerceEasy(T,m) => T' - T':= coerceSubset(T,m) => markCoerce(T,T','AUTOSUBSET) - T':= coerceHard(T,m) => markCoerce(T,T','AUTOHARD) - T':= coerceExtraHard(T,m) => T' - T.expr = "$fromCoerceable$" or isSomeDomainVariable m => nil - T' := coerceRep(T,m) => markCoerce(T,T','AUTOREP) - stackMessage fn(T.expr,T.mode,m) where - -- if from from coerceable, this coerce was just a trial coercion - -- from compFormWithModemap to filter through the modemaps - fn(x,m1,m2) == - ["Cannot coerce","%b",x,"%d","%l"," of mode","%b",m1,"%d","%l", - " to mode","%b",m2,"%d"] - -coerceSubset(T := [x,m,e],m') == - m = $SmallInteger => - m' = $Integer => [x,m',e] - m' = (r := get(x,'range,e)) or isSubset(r,m',e) => [x,r,e] - nil --- pp [m, m'] - isSubset(m,m',e) or m="Rep" and m'="$" => [x,m',e] - m is ['SubDomain,=m',:.] => [x,m',e] - (pred:= LASSOC(opOf m',get(opOf m,'SubDomain,e))) and INTEGERP x and - -- obviously this is temporary - eval substitute(x,"#1",pred) => [x,m',e] - (pred:= isSubset(m',maxSuperType(m,e),e)) and INTEGERP x -- again temporary - and eval substitute(x,"*",pred) => - [x,m',e] - nil - -coerceRep(T,m) == - md := T.mode - atom md => nil - CONTAINED('Rep,md) and SUBST('$,'Rep,md) = m or - CONTAINED('Rep,m) and SUBST('$,'Rep,m) = md => T - nil - ---- GET rid of XLAMs -spadCompileOrSetq form == - --bizarre hack to take account of the existence of "known" functions - --good for performance (LISPLLIB size, BPI size, NILSEC) - [nam,[lam,vl,body]] := form - CONTAINED(" ",body) => sayBrightly ['" ",:bright nam,'" not compiled"] - if vl is [:vl',E] and body is [nam',: =vl'] then - LAM_,EVALANDFILEACTQ ['PUT,MKQ nam,MKQ 'SPADreplace,MKQ nam'] - sayBrightly ['" ",:bright nam,'"is replaced by",:bright nam'] - else if (ATOM body or and/[ATOM x for x in body]) - and vl is [:vl',E] and not CONTAINED(E,body) then - macform := ['XLAM,vl',body] - LAM_,EVALANDFILEACTQ ['PUT,MKQ nam,MKQ 'SPADreplace,MKQ macform] - sayBrightly ['" ",:bright nam,'"is replaced by",:bright body] - $insideCapsuleFunctionIfTrue => first COMP LIST form - compileConstructor form - -coerceHard(T,m) == - $e: local:= T.env - m':= T.mode - STRINGP m' and modeEqual(m,$String) => [T.expr,m,$e] - modeEqual(m',m) or - (get(m',"value",$e) is [m'',:.] or getmode(m',$e) is ["Mapping",m'']) and - modeEqual(m'',m) or - (get(m,"value",$e) is [m'',:.] or getmode(m,$e) is ["Mapping",m'']) and - modeEqual(m'',m') => [T.expr,m,T.env] - STRINGP T.expr and T.expr=m => [T.expr,m,$e] - isCategoryForm(m,$e) => - $bootStrapMode = true => [T.expr,m,$e] - extendsCategoryForm(T.expr,T.mode,m) => [T.expr,m,$e] - nil - nil - -coerceExtraHard(T is [x,m',e],m) == - T':= autoCoerceByModemap(T,m) => T' - isUnionMode(m',e) is ["Union",:l] and (t:= hasType(x,e)) and - member(t,l) and (T':= autoCoerceByModemap(T,t)) and - (T'':= coerce(T',m)) => T'' - m' is ['Record,:.] and m = $Expression => - [['coerceRe2E,x,['ELT,COPY m',0]],m,e] - nil - -compCoerce(u := ["::",x,m'],m,e) == - m' := markKillAll m' - e:= addDomain(m',e) - m := markKillAll m ---------------> new code <------------------- - T:= compCoerce1(x,m',e) => coerce(T,m) - T := comp(x,$EmptyMode,e) or return nil - T.mode = $SmallInteger and - MEMQ(opOf m,'(NonNegativeInteger PositiveInteger)) => - compCoerce(["::",["::",x,$Integer],m'],m,e) ---------------> new code <------------------- - getmode(m',e) is ["Mapping",["UnionCategory",:l]] => - l := [markKillAll x for x in l] - T:= (or/[compCoerce1(x,m1,e) for m1 in l]) or return nil - coerce([T.expr,m',T.env],m) - -compCoerce1(x,m',e) == - T:= comp(x,m',e) - if null T then T := comp(x,$EmptyMode,e) - null T => return nil - m1:= - STRINGP T.mode => $String - T.mode - m':=resolve(m1,m') - T:=[T.expr,m1,T.env] - T':= coerce(T,m') => T' - T':= coerceByModemap(T,m') => T' - pred:=isSubset(m',T.mode,e) => - gg:=GENSYM() - pred:= substitute(gg,"*",pred) - code:= ['PROG1,['LET,gg,T.expr], ['check_-subtype,pred,MKQ m',gg]] - [code,m',T.env] - -coerceByModemap([x,m,e],m') == ---+ modified 6/27 for new runtime system - u:= - [modemap - for (modemap:= [map,cexpr]) in getModemapList("coerce",1,e) | map is [.,t, - s] and (modeEqual(t,m') or isSubset(t,m',e)) - and (modeEqual(s,m) or isSubset(m,s,e))] or return nil - mm:=first u -- patch for non-trival conditons - fn := genDeltaEntry ['coerce,:mm] - T := [["call",fn,x],m',e] - markCoerceByModemap(x,m,m',markCallCoerce(x,m',T),nil) - -autoCoerceByModemap([x,source,e],target) == - u:= - [cexpr - for (modemap:= [map,cexpr]) in getModemapList("autoCoerce",1,e) | map is [ - .,t,s] and modeEqual(t,target) and modeEqual(s,source)] or return nil - fn:= (or/[selfn for [cond,selfn] in u | cond=true]) or return nil - markCoerceByModemap(x,source,target,[["call",fn,x],target,e],true) - ---====================================================================== --- From compiler.boot ---====================================================================== ---comp3x(x,m,$e) == - -comp3(x,m,$e) == - --returns a Triple or %else nil to signalcan't do' - $e:= addDomain(m,$e) - e:= $e --for debugging purposes - m is ["Mapping",:.] => compWithMappingMode(x,m,e) - m is ["QUOTE",a] => (x=a => [x,m,$e]; nil) - STRINGP m => (atom x => (m=x or m=STRINGIMAGE x => [m,m,e]; nil); nil) - ^x or atom x => compAtom(x,m,e) - op:= first x - getmode(op,e) is ["Mapping",:ml] and (u:= applyMapping(x,m,e,ml)) => u - op is ["KAPPA",sig,varlist,body] => compApply(sig,varlist,body,rest x,m,e) - op=":" => compColon(x,m,e) - op="::" => compCoerce(x,m,e) - not ($insideCompTypeOf=true) and stringPrefix?('"TypeOf",PNAME op) => - compTypeOf(x,m,e) - ------------special jump out code for PART (don't want $insideExpressionIfTrue=true)-- - x is ['PART,:.] => compPART(x,m,e) - ---------------------------------- - t:= qt(14,compExpression(x,m,e)) - t is [x',m',e'] and not member(m',getDomainsInScope e') => - qt(15,[x',m',addDomain(m',e')]) - qt(16,t) - -yyyyy x == x -compExpression(x,m,e) == - $insideExpressionIfTrue: local:= true - if x is ['LET,['PART,.,w],[['elt,B,'new],['PART,.,["#",['PART,.,l]]],:.],:.] then yyyyy x - x := compRenameOp x - atom first x and (fn:= GETL(first x,"SPECIAL")) => - FUNCALL(fn,x,m,e) - compForm(x,m,e) - -compRenameOp x == ----------> new 12/3/94 - x is [op,:r] and op is ['PART,.,op1] => - [op1,:r] - x - -compCase(["case",x,m1],m,e) == - m' := markKillAll m1 - e:= addDomain(m',e) - T:= compCase1(x,m',e) => coerce(T,m) - nil - -compCase1(x,m,e) == - x1 := - x is ['PART,.,a] => a - x - [x',m',e']:= comp(x1,$EmptyMode,e) or return nil - if m' = "$" then (m' := IFCAR get('Rep,'value,e)) and (switchMode := true) - -------------------------------------------------------------------------- - m' isnt ['Union,:r] => nil - mml := [mm for (mm := [map,cexpr]) in getModemapList("case",2,e') - | map is [.,.,s,t] and modeEqual(t,m) and - (modeEqual(s,m') or switchMode and modeEqual(s,"$"))] - or return nil - u := [cexpr for [.,cexpr] in mml] - fn:= (or/[selfn for [cond,selfn] in u | cond=true]) or return nil - tag := genCaseTag(m, r, 1) or return nil - x1 := - switchMode => markRepper('rep, x) - x - markCase(x, tag, markCaseWas(x1,[["call",fn,x'],$Boolean,e'])) - -genCaseTag(t,l,n) == - l is [x, :l] => - x = t => - STRINGP x => INTERN x - INTERN STRCONC("value", STRINGIMAGE n) - x is ["::",=t,:.] => t - STRINGP x => genCaseTag(t, l, n) - genCaseTag(t, l, n + 1) - nil - -compIf(["IF",aOrig,b,c],m,E) == - a := markKillButIfs aOrig - [xa,ma,Ea,Einv]:= compBoolean(a,aOrig,$Boolean,E) or return nil - [xb,mb,Eb]:= Tb:= compFromIf(b,m,Ea) or return nil - [xc,mc,Ec]:= Tc:= compFromIf(c,resolve(mb,m),Einv) or return nil - xb':= coerce(Tb,mc) or return nil - x:= ["IF",xa,quotify xb'.expr,quotify xc] - (returnEnv:= Env(xb'.env,Ec,xb'.expr,xc,E)) where - Env(bEnv,cEnv,b,c,E) == - canReturn(b,0,0,true) => - (canReturn(c,0,0,true) => intersectionEnvironment(bEnv,cEnv); bEnv) - canReturn(c,0,0,true) => cEnv - E - [x,mc,returnEnv] - -compBoolean(p,pWas,m,Einit) == - op := opOf p - [p',m,E]:= - fop := LASSOC(op,'((and . compAnd) (or . compOr) (not . compNot))) => - APPLY(fop,[p,pWas,m,Einit]) or return nil - T := comp(p,m,Einit) or return nil - markAny('compBoolean,pWas,T) - [p',m,getSuccessEnvironment(markKillAll p,E), - getInverseEnvironment(markKillAll p,E)] - -compAnd([op,:args], pWas, m, e) == ---called ONLY from compBoolean - cargs := [T.expr for x in args - | [.,.,e,.] := T := compBoolean(x,x,$Boolean,e) or return nil] - null cargs => nil - coerce(markAny('compAnd,pWas,[["AND",:cargs],$Boolean,e]),m) - -compOr([op,:args], pWas, m, e) == ---called ONLY from compBoolean - cargs := [T.expr for x in args - | [.,.,.,e] := T := compBoolean(x,x,$Boolean,e) or return nil] - null cargs => nil - coerce(markAny('compOr,pWas, [["OR",:cargs],$Boolean,e]),m) - -compNot([op,arg], pWas, m, e) == ---called ONLY from compBoolean - [x,m1,.,ei] := compBoolean(arg,arg,$Boolean,e) or return nil - coerce(markAny('compNot, pWas, [["NOT",x],$Boolean,ei]),m) - -compDefine(form,m,e) == - $tripleHits: local:= 0 - $macroIfTrue: local - $packagesUsed: local - ['DEF,.,originalSignature,.,body] := form - if not $insideFunctorIfTrue then - $originalBody := COPY body - compDefine1(form,m,e) - -compDefine1(form,m,e) == - $insideExpressionIfTrue: local:= false - --1. decompose after macro-expanding form - ['DEF,lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e) - $insideWhereIfTrue and isMacro(form,e) and (m=$EmptyMode or m=$NoValueMode) - => [lhs,m,put(first lhs,'macro,rhs,e)] - null signature.target and not MEMQ(KAR rhs,$ConstructorNames) and - (sig:= getSignatureFromMode(lhs,e)) => - -- here signature of lhs is determined by a previous declaration - compDefine1(['DEF,lhs,[first sig,:rest signature],specialCases,rhs],m,e) - if signature.target=$Category then $insideCategoryIfTrue:= true - if signature.target is ['Mapping,:map] then - signature:= map - form:= ['DEF,lhs,signature,specialCases,rhs] - - --- RDJ (11/83): when argument and return types are all declared, --- or arguments have types declared in the environment, --- and there is no existing modemap for this signature, add --- the modemap by a declaration, then strip off declarations and recurse - e := compDefineAddSignature(lhs,signature,e) --- 2. if signature list for arguments is not empty, replace ('DEF,..) by --- ('where,('DEF,..),..) with an empty signature list; --- otherwise, fill in all NILs in the signature - not (and/[null x for x in rest signature]) => compDefWhereClause(form,m,e) - signature.target=$Category => - compDefineCategory(form,m,e,nil,$formalArgList) - isDomainForm(rhs,e) and not $insideFunctorIfTrue => - if null signature.target then signature:= - [getTargetFromRhs(lhs,rhs,giveFormalParametersValues(rest lhs,e)),: - rest signature] - rhs:= addEmptyCapsuleIfNecessary(signature.target,rhs) - compDefineFunctor(['DEF,lhs,signature,specialCases,rhs],m,e,nil, - $formalArgList) - null $form => stackAndThrow ['"bad == form ",form] - newPrefix:= - $prefix => INTERN STRCONC(encodeItem $prefix,'",",encodeItem $op) - getAbbreviation($op,#rest $form) - compDefineCapsuleFunction(form,m,e,newPrefix,$formalArgList) - -compDefineCategory(df,m,e,prefix,fal) == - $domainShell: local -- holds the category of the object being compiled - $lisplibCategory: local - not $insideFunctorIfTrue and $LISPLIB => - compDefineLisplib(df,m,e,prefix,fal,'compDefineCategory1) - compDefineCategory1(df,m,e,prefix,fal) - -compDefineCategory1(df,m,e,prefix,fal) == - $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 - $catAddForm : local := nil --for conversion to new compiler 2/95 - $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 - $categoryTranForm : local := nil --for conversion to new compiler 10/93 - ['DEF,form,sig,sc,body] := df - body := markKillAll body --these parts will be replaced by compDefineLisplib - categoryCapsule := ---+ - body is ['add,cat,capsule] => - body := cat - capsule - nil - [d,m,e]:= compDefineCategory2(form,sig,sc,body,m,e,prefix,fal) ---+ next two lines --- if BOUNDP '$convertingSpadFile and $convertingSpadFile then nil --- else - if categoryCapsule and not $bootStrapMode then - [.,.,e] := - $insideCategoryPackageIfTrue: local := true --see NRTmakeSlot1 - $categoryPredicateList: local := - makeCategoryPredicates(form,$lisplibCategory) - defform := mkCategoryPackage(form,cat,categoryCapsule) - ['DEF,[.,arg,:.],:.] := defform - $categoryNameForDollar :local := arg - compDefine1(defform,$EmptyMode,e) - else - [body,T] := $categoryTranForm - markFinish(body,T) - - [d,m,e] - -compDefineCategory2(form,signature,specialCases,body,m,e, - $prefix,$formalArgList) == - --1. bind global variables - $insideCategoryIfTrue: local:= true - $TOP__LEVEL: local - $definition: local - --used by DomainSubstitutionFunction - $form: local - $op: local - $extraParms: local - --Set in DomainSubstitutionFunction, used further down --- 1.1 augment e to add declaration $: <form> - [$op,:argl]:= $definition:= form - e:= addBinding("$",[['mode,:$definition]],e) - --- 2. obtain signature - signature':= - [first signature,:[getArgumentModeOrMoan(a,$definition,e) for a in argl]] - e:= giveFormalParametersValues(argl,e) - --- 3. replace arguments by $1,..., substitute into body, --- and introduce declarations into environment - sargl:= TAKE(# argl, $TriangleVariableList) - $functorForm:= $form:= [$op,:sargl] - $formalArgList:= [:sargl,:$formalArgList] - aList:= [[a,:sa] for a in argl for sa in sargl] - formalBody:= SUBLIS(aList,body) - signature' := SUBLIS(aList,signature') ---Begin lines for category default definitions - $functionStats: local:= [0,0] - $functorStats: local:= [0,0] - $frontier: local := 0 - $getDomainCode: local := nil - $addForm: local:= nil - for x in sargl for t in rest signature' repeat - [.,.,e]:= compMakeDeclaration([":",x,t],m,e) - --- 4. compile body in environment of %type declarations for arguments - op':= $op - -- following line causes cats with no with or Join to be fresh copies - if opOf(formalBody)^='Join and opOf(formalBody)^='mkCategory then - formalBody := ['Join, formalBody] - T := compOrCroak(formalBody,signature'.target,e) ---------------------> new <------------------- - $catAddForm := - $originalBody is ['add,y,:.] => y - $originalBody - $categoryTranForm := [$originalBody,[$form,['Mapping,:signature'],T.env]] ---------------------> new <------------------- - body:= optFunctorBody markKillAll T.expr - if $extraParms then - formals:=actuals:=nil - for u in $extraParms repeat - formals:=[CAR u,:formals] - actuals:=[MKQ CDR u,:actuals] - body := ['sublisV,['PAIR,['QUOTE,formals],['LIST,:actuals]],body] - if argl then body:= -- always subst for args after extraparms - ['sublisV,['PAIR,['QUOTE,sargl],['LIST,: - [['devaluate,u] for u in sargl]]],body] - body:= - ['PROG1,['LET,g:= GENSYM(),body],['SETELT,g,0,mkConstructor $functorForm]] - fun:= compile [op',['LAM,sargl,body]] - --- 5. give operator a 'modemap property - pairlis:= [[a,:v] for a in argl for v in $FormalMapVariableList] - parSignature:= SUBLIS(pairlis,signature') - parForm:= SUBLIS(pairlis,form) ----- lisplibWrite('"compilerInfo", ----- ['SETQ,'$CategoryFrame, ----- ['put,['QUOTE,op'],' ----- (QUOTE isCategory),true,['addModemap,MKQ op',MKQ parForm, ----- MKQ parSignature,true,MKQ fun,'$CategoryFrame]]],$libFile) - --Equivalent to the following two lines, we hope - if null sargl then - evalAndRwriteLispForm('NILADIC, - ['MAKEPROP,['QUOTE,op'],'(QUOTE NILADIC),true]) - --- 6. put modemaps into InteractiveModemapFrame - $domainShell := - BOUNDP '$convertingSpadFile and $convertingSpadFile => nil - eval [op',:MAPCAR('MKQ,sargl)] - $lisplibCategory:= formalBody ----- if $LISPLIB then ----- $lisplibForm:= form ----- $lisplibKind:= 'category ----- modemap:= [[parForm,:parSignature],[true,op']] ----- $lisplibModemap:= modemap ----- $lisplibCategory:= formalBody ----- form':=[op',:sargl] ----- augLisplibModemapsFromCategory(form',formalBody,signature') - [fun,'(Category),e] -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} |