diff options
Diffstat (limited to 'src/interp/wi1.boot.pamphlet')
| -rw-r--r-- | src/interp/wi1.boot.pamphlet | 1287 |
1 files changed, 1287 insertions, 0 deletions
diff --git a/src/interp/wi1.boot.pamphlet b/src/interp/wi1.boot.pamphlet new file mode 100644 index 00000000..a86a7da2 --- /dev/null +++ b/src/interp/wi1.boot.pamphlet @@ -0,0 +1,1287 @@ +\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} |