-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd. -- All rights reserved. -- Copyright (C) 2007-2016, Gabriel Dos Reis. -- 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. import msgdb import pathname import define namespace BOOT module compiler where coerce: (%Triple,%Mode) -> %Maybe %Triple convert: (%Triple,%Mode) -> %Maybe %Triple comp: (%Form,%Mode,%Env) -> %Maybe %Triple compOrCroak: (%Form,%Mode,%Env) -> %Maybe %Triple compCompilerPredicate: (%Form,%Env) -> %Maybe %Triple checkCallingConvention: (%List %Sig,%Short) -> %SimpleArray %Short --% compUniquely: (%Form,%Mode,%Env) -> %Maybe %Triple compNoStacking: (%Maybe %Database,%Form,%Mode,%Env) -> %Maybe %Triple compNoStacking1: (%Maybe %Database,%Form,%Mode,%Env,%List %Thing) -> %Maybe %Triple compOrCroak1: (%Form,%Mode,%Env) -> %Maybe %Triple comp2: (%Maybe %Database,%Form,%Mode,%Env) -> %Maybe %Triple comp3: (%Maybe %Database,%Form,%Mode,%Env) -> %Maybe %Triple compExpression: (%Maybe %Database,%Form,%Mode,%Env) -> %Maybe %Triple compAtom: (%Maybe %Database,%Form,%Mode,%Env) -> %Maybe %Triple compSymbol: (%Form,%Mode,%Env) -> %Maybe %Triple compForm: (%Maybe %Database,%Form,%Mode,%Env) -> %Maybe %Triple compForm1: (%Maybe %Database,%Form,%Mode,%Env) -> %Maybe %Triple compForm2: (%Maybe %Database,%Form,%Mode,%Env,%List %Modemap) -> %Maybe %Triple compForm3: (%Maybe %Database,%Form,%Mode,%Env,%List %Modemap) -> %Maybe %Triple compArgumentsAndTryAgain: (%Maybe %Database,%Form,%Mode,%Env) -> %Maybe %Triple compWithMappingMode: (%Form,%Mode,%Env) -> %Maybe %Triple compFormMatch: (%Modemap,%List %Mode) -> %Boolean compFormWithModemap: (%Maybe %Database,%Form,%Mode,%Env,%Modemap) -> %Maybe %Triple compToApply: (%Form,%List %Form,%Mode,%Env) -> %Maybe %Triple compApplication: (%Form,%List %Form,%Mode,%Triple) -> %Maybe %Triple primitiveType: (%Maybe %Database,%Form,%Mode) -> %Mode modeEqual: (%Form,%Form) -> %Boolean hasUniqueCaseView: (%Form,%Mode,%Env) -> %Boolean convertOrCroak: (%Triple,%Mode) -> %Maybe %Triple getFormModemaps: (%Maybe %Database,%Form,%Env) -> %List %Modemap reshapeArgumentList: (%Form,%Sig) -> %Form applyMapping: (%Form,%Mode,%Env,%List %Mode) -> %Maybe %Triple $IOFormDomains == [$InputForm,$OutputForm,$Syntax] --% compTopLevel: (%Form,%Mode,%Env) -> %Maybe %Triple compTopLevel(x,m,e) == $forceAdd: local:= false -- start with a base list of domains we may want to inline. $optimizableConstructorNames: local := $SystemInlinableConstructorNames x is ["DEF",:.] or x is ["where",["DEF",:.],:.] => ([val,mode,.]:= compOrCroak(x,m,e); [val,mode,e]) --keep old environment after top level function defs compOrCroak(x,m,e) ++ True if no ambiguity is allowed in overload resolution. $compUniquelyIfTrue := false compUniquely(x,m,e) == $compUniquelyIfTrue: local:= true CATCH("compUniquely",comp(x,m,e)) compOrCroak(x,m,e) == compOrCroak1(x,m,e) compOrCroak1(x,m,e) == fn(x,m,e,nil,nil) where fn(x,m,e,$compStack,$compErrorMessageStack) == T:= CATCH("compOrCroak",comp(x,m,e)) => T --stackAndThrow here and moan in UT LISP K does the appropriate THROW $compStack:= [[x,m,e,$exitModeStack],:$compStack] $s: local := compactify $compStack where compactify al == null al => nil LASSOC(first first al,rest al) => compactify rest al [first al,:compactify rest al] $level: local := #$s errorMessage:= $compErrorMessageStack ~= nil => first $compErrorMessageStack "unspecified error" $scanIfTrue => stackSemanticError(errorMessage,mkErrorExpr $level) ["failedCompilation",m,e] displaySemanticErrors() SAY("****** comp fails at level ",$level," with expression: ******") displayComp $level userError errorMessage ++ The form `x' is intended to be evaluated by the compiler, e.g. in ++ toplevel conditional definition or as sub-domain predicate. ++ Normalize operators and compile the form. compCompilerPredicate(x,e) == $normalizeTree: local := true compOrCroak(parseTran x, $Boolean, e) comp(x,m,e) == T:= compNoStacking(currentDB e,x,m,e) => ($compStack:= nil; T) $compStack:= [[x,m,e,$exitModeStack],:$compStack] nil compNoStacking(db,x,m,e) == T:= comp2(db,x,m,e) => $useRepresentationHack and m=$EmptyMode and T.mode=$Representation => [T.expr,"$",T.env] 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 --Now that `per' and `rep' are built in, we use the above --hack only when `Rep' is defined the old way. -- gdr 2008/01/26 compNoStacking1(db,x,m,e,$compStack) compNoStacking1(db,x,m,e,$compStack) == u:= get(RepIfRepHack m,"value",e) => (T:= comp2(db,x,u.expr,e) => [T.expr,m,T.env]; nil) nil comp2(db,x,m,e) == [y,m',e] := T := comp3(db,x,m,e) or return nil T.mode = $Category => T --if cons? y and isDomainForm(y,e) then e := addDomain(db,x,e) --line commented out to prevent adding derived domain forms m~=m' and isDomainForm(m',e) => [y,m',addDomain(db,m',e)] --isDomainForm test needed to prevent error while compiling Ring T comp3(db,x,m,$e) == --returns a Triple or %else nil to signalcan't do' $e:= addDomain(db,m,$e) e:= $e --for debugging purposes m is ["Mapping",:.] => compWithMappingMode(x,m,e) string? m => string? x and stringEq?(x,m) => [x,m,e] nil -- In quasiquote mode, x should match exactly (y := isQuasiquote m) => y = x => [quote x, m, $e] nil x isnt [.,:.] => compAtom(db,x,m,e) op:= x.op ident? op and getXmode(op,e) is ["Mapping",:ml] and (T := applyMapping(x,m,e,ml)) => T op is ":" => compColon(x,m,e) op is "::" => compCoerce(x,m,e) op is 'DEF => compDefine(db,x,m,e) t:= compExpression(db,x,m,e) t is [x',m',e'] and not listMember?(m',getDomainsInScope e') => [x',m',addDomain(db,m',e')] t ++ We just determined that `op' is called with argument list `args', where ++ `op' is either a local capsule function, or an external function ++ with a local signature-import declaration. Emit insn for the call. emitLocalCallInsn: (%Symbol,%List %Code,%Env) -> %Code emitLocalCallInsn(op,args,e) == op' := -- Find out the linkage name for `op'. get(op,"%Link",e) or encodeLocalFunctionName op get(op,"%Lang",e) => -- non-Spad calling convention ['%call,['%external,op'],:args] ['%call,['%closure,['%function,op'],'$],:args] applyMapping([op,:argl],m,e,ml) == #argl ~= #ml-1 => nil isCategoryForm(first ml,e) => --is op a functor? pairlis := pairList($FormalMapVariableList,argl) ml' := applySubst(pairlis,ml) argl' := [T.expr for x in argl for m' in rest ml'] where T() == [.,.,e]:= comp(x,m',e) or return "failed" argl' is "failed" => nil form := ident? op and symbolMember?(op,$formalArgList) => -- this domain form is given by a general function application ['%funcall,op,:argl'] -- constructor call linkage is special [op,:argl'] convert([form,first ml',e],m) argl':= [T.expr for x in argl for m' in rest ml] where T() == [.,.,e]:= comp(x,m',e) or return "failed" if argl' is "failed" then return nil form:= symbol? op and not symbolMember?(op,$formalArgList) and (u := get(op,"value",e)) = nil => emitLocalCallInsn(op,argl',e) -- Compiler synthetized operators are inline. u ~= nil and u.expr is ["XLAM",:.] => ['%call,u.expr,:argl'] ['%call,['%apply,op],:argl'] pairlis := pairList($FormalMapVariableList,argl') convert([form,applySubst(pairlis,first ml),e],m) hasFormalMapVariable(x, vl) == $formalMapVariables: local := vl null vl => false ScanOrPairVec(function hasone?,x) where hasone? x == symbolMember?(x,$formalMapVariables) ++ Return the usage list of free variables in a lambda expresion. ++ The usage list is an a-list (name, number of timed used.) freeVarUsage([.,vars,body],env) == freeList(body,vars,nil,env) where freeList(u,bound,free,e) == u isnt [.,:.] => not ident? u => free symbolMember?(u,bound) => free v := objectAssoc(u,free) => v.rest := 1 + rest v free getmode(u,e) = nil => free [[u,:1],:free] atomic? u => free op := u.op op in '(GO %external %function function) => free op in '(LAMBDA %lambda) => bound := setUnion(u.absParms,bound) for v in CDDR u repeat free := freeList(v,bound,free,e) free op = 'PROG => bound := setUnion(bound, second u) for v in CDDR u | cons? v repeat free := freeList(v,bound,free,e) free op = '%bind => for [v,init] in second u repeat bound := [v,:bound] free := freeList(init,bound,free,e) freeList(third u,bound,free,e) op = 'LET => locals := nil for [v,init] in second u repeat free := freeList(init,bound,free,e) locals := [v,:locals] freeList(third u,setUnion(locals,bound),free,e) op = '%seq => for v in rest u | cons? v repeat free := freeList(v,bound,free,e) free op in '(COND %when) => for v in rest u repeat for vv in v repeat free := freeList(vv,bound,free,e) free if op isnt [.,:.] then --Atomic functions aren't descended u := rest u for v in u repeat free := freeList(v,bound,free,e) free ++ Finish processing a lambda expression with parameter list `vars', ++ and `env' as the environement after the compilation its body. finishLambdaExpression(expr is ['%lambda,vars,.],env) == $FUNNAME: local := nil $FUNNAME__TAIL: local := [nil] expandedFunction := transformToBackendCode expr frees := freeVarUsage(expandedFunction,env) vec := nil -- mini-vector expandedFunction := frees = nil => ["LAMBDA",[:vars,"$$"], :CDDR expandedFunction] -- At this point, we have a function that we would like to pass. -- Unfortunately, it makes various free variable references outside -- itself. So we build a mini-vector that contains them all, and -- pass this as the environment to our inner function. -- One free can go by itself, more than one needs a vector. frees is [[var,:.]] => vec := var ["LAMBDA",[:vars,var],:CDDR expandedFunction] scode := nil -- list of multiple used variables, need local bindings. slist := nil -- list of single used variables, no local bindings. for v in frees for i in 0.. repeat val := ['%vref,"$$",i] vec := [first v,:vec] rest v = 1 => slist := [[first v,:val],:slist] scode := [[first v,val],:scode] body := slist => applySubstNQ(slist,CDDR expandedFunction) CDDR expandedFunction if scode ~= nil then body := [['%bind,reverse! scode,:body]] vec := ['%vector,:reverse! vec] ["LAMBDA",[:vars,"$$"],:body] fname := ["CLOSEDFN",expandedFunction] --Like QUOTE, but gets compiled ['%closure,fname,vec] compWithMappingMode(x,m is ["Mapping",m',:sl],oldE) == e := oldE isFunctor x => db := currentDB e if get(x,"modemap",$CategoryFrame) is [[[.,target,:argModeList],.],:.] and (and/[extendsCategoryForm(db,"$",s,mode) for mode in argModeList for s in sl] ) and extendsCategoryForm(db,"$",target,m') then return [['%function,x],m,e] x is ["+->",:.] => compLambda(x,m,oldE) if string? x then x := makeSymbol x for m in sl for v in (vl:= take(#sl,$FormalMapVariableList)) repeat [.,.,e]:= compMakeDeclaration(v,m,e) (vl ~= nil) and not hasFormalMapVariable(x, vl) => [u,.,.] := comp([x,:vl],m',e) or return nil [extractCode(u,vl),m,oldE] null vl and (t := comp([x], m', e)) => [u,.,.] := t [extractCode(u,nil),m,oldE] [u,.,.]:= comp(x,m',e) or return nil [.,fun] := optimizeFunctionDef [nil,['%lambda,vl,u]] [finishLambdaExpression(fun,e),m,oldE] extractCode(u,vars) == u is ['%call,[q,:etc],: =vars] and q in '(ELT CONST) => ['%tref,:etc] u is ['%call,['%apply,a],: =vars] => a u is ['%call,['%closure,:.],: =vars] => first u.args ['%closure,['%function,['%lambda,[:vars,'$],u]],'$] compExpression(db,x,m,e) == $insideExpressionIfTrue: local:= true -- special forms have dedicated compilers. (op := x.op) and ident? op and (fn := property(op,'SPECIAL)) => apply(fn,[x,m,e]) compForm(db,x,m,e) ++ Subroutine of compAtomWithModemap. ++ `Ts' is list of (at least 2) triples. Return the one with most ++ specific mode. Otherwise, return nil. mostSpecificTriple(Ts,e) == [T,:Ts] := Ts and/[T := lesser(T,T',e) for T' in Ts] where lesser(t,t',e) == isSubset(t.mode,t'.mode,e) => t isSubset(t'.mode,t.mode,e) => t' nil ++ Elaborate use of an overloaded constant. compAtomWithModemap: (%Maybe %Database,%Symbol,%Mode,%Env,%List %Modemap) -> %Maybe %Triple compAtomWithModemap(db,x,m,e,mmList) == mmList := [mm for mm in mmList | mm.mmImplementation is ['CONST,:.]] mmList = nil => nil name := -- constant name displayed in diagnostics. externalName x -- FIXME: Remove when the parser is fixed. -- Try constants with exact type matches, first. Ts := [[['%call,first y],mm.mmTarget,e] for mm in mmList | mm.mmTarget = m and (y := compViableModemap(db,x,nil,mm,e))] Ts is [T] => T -- Only one possibility, take it. Ts ~= nil => -- Ambiguous constant. stackMessage('"Too many (%1b) constants named %2b with type %3pb", [#Ts,name,m]) -- Fallback to constants that are coercible to the target. Ts := [[['%call,first y],mm.mmTarget,nil] for mm in mmList | coerceable(mm.mmTarget,m,e) and (y := compViableModemap(db,x,nil,mm,e))] Ts = nil => stackMessage('"No viable constant named %1b in %2pb context",[name,m]) Ts is [T] or (T := mostSpecificTriple(Ts,e)) => coerce([T.expr,T.mode,e],m) stackMessage('"Ambiguous constant %1b in %2pb constext. Candidates are %3f", [name,m,[function formatConstantCandidates,name,Ts]]) ++ Format constants named `op' with mode given in the list of triples `Ts'. formatConstantCandidates(op,Ts) == displayAmbiguousSignatures(op,[[T.mode,'constant] for T in Ts]) ++ Attempt to elaborate the integer literal `x' as an exported operator ++ in the type context `m' and assumption environment `e'. compIntegerLiteral(db,x,m,e) == x := internalName x compAtomWithModemap(db,x,m,e,get(x,'modemap,e)) compAtom(db,x,m,e) == x is "break" => compBreak(x,m,e) x is "iterate" => compIterate(x,m,e) T := ident? x and compAtomWithModemap(db,x,m,e,get(x,"modemap",e)) => T T := integer? x and x > 1 and compIntegerLiteral(db,x,m,e) => T t := ident? x => compSymbol(x,m,e) or return nil listMember?(m,$IOFormDomains) and primitiveType(db,x,m) => [x,m,e] string? x => [x,x,e] [x,primitiveType(db,x,m) or return nil,e] convert(t,m) modeIfTypeBeingDefined(db,t,m) == db = nil or m = $EmptyMode => t substitute(dbConstructorForm db,'$,m) = t => m t primitiveType(db,x,m) == x is nil => $EmptyMode string? x => modeIfTypeBeingDefined(db,$String,m) integer? x => db ~= nil and substitute(dbConstructorForm db,'$,m) = $Integer => m x = 0 => modeIfTypeBeingDefined(db,$NonNegativeInteger,m) x > 0 => modeIfTypeBeingDefined(db,$PositiveInteger,m) $Integer float? x => $DoubleFloat nil compSymbol(s,m,e) == s is "$NoValue" => ["$NoValue",$NoValueMode,e] isFluid s => [s,getmode(s,e) or return nil,e] sameObject?(s,m) or isLiteral(s,e) => [quote s,s,e] v := get(s,"value",e) => symbolMember?(s,$functorLocalParameters) => getLocalIndex(currentDB e,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 symbolMember?(s,$formalArgList) and not symbolMember?(s,$FormalMapVariableList) and not isFunction(s,e) and not $compForModeIfTrue then errorRef s [s,m',e] --s is a declared argument symbolMember?(s,$FormalMapVariableList) => stackMessage('"no mode found for %1b",[s]) listMember?(m,$IOFormDomains) or member(m,[$Identifier,$Symbol]) => [quote s,m,e] not isFunction(s,e) => errorRef s ++ Return true if `m' is the most recent unique type case assumption ++ on `x' that predates its declaration in environment `e'. hasUniqueCaseView(x,m,e) == props := getProplist(x,e) for [p,:v] in props repeat p is "condition" and v is [["case",.,t],:.] => return modeEqual(t,m) p is "value" => return false convertOrCroak(T,m) == u := convert(T,m) => u userError ['"CANNOT CONVERT: ",T.expr,"%l",'" OF MODE: ",T.mode,"%l", '" TO MODE: ",m,"%l"] convert(T,m) == coerce(T,resolve(T.mode,m) or return nil) mkUnion(a,b) == b is "$" and $Rep is ["Union",:l] => b a is ["Union",:l] => b is ["Union",:l'] => ["Union",:union(l,l')] ["Union",:union([b],l)] b is ["Union",:l] => ["Union",:union([a],l)] ["Union",a,b] hasType(x,e) == fn get(x,"condition",e) where fn x == x = nil => nil x is [["case",.,y],:.] => y fn rest x --% General Forms compForm(db,form,m,e) == T := compForm1(db,form,m,e) or compArgumentsAndTryAgain(db,form,m,e) or return stackMessageIfNone ["cannot compile","%b",form,"%d"] T compArgumentsAndTryAgain(db,form is [.,:argl],m,e) == -- used in case: f(g(x)) where f is in domain introduced by -- comping g, e.g. for (ELT (ELT x a) b), environment can have no -- modemap with selector b form is ["elt",a,.] => ([.,.,e]:= comp(a,$EmptyMode,e) or return nil; compForm1(db,form,m,e)) +/[(e := T.env; 1) for x in argl | T := comp(x,$EmptyMode,e)] = 0 => nil compForm1(db,form,m,e) outputComp(x,e) == u:=comp(['_:_:,x,$OutputForm],$OutputForm,e) => u x is ['construct,:argl] => [['%list,:[([.,.,e]:=outputComp(x,e)).expr for x in argl]],$OutputForm,e] (v:= get(x,"value",e)) and (v.mode is ['Union,:l]) => [['coerceUn2E,x,v.mode],$OutputForm,e] [x,$OutputForm,e] compForm1(db,form is [op,:argl],m,e) == symbolMember?(op,$coreDiagnosticFunctions) => [[op,:[([.,.,e]:=outputComp(x,e)).expr for x in argl]],m,e] op is ["elt",domain,op'] => domain="Lisp" => [[op',:[([.,.,e]:= compOrCroak(x,$EmptyMode,e)).expr for x in argl]],m,e] domain is ["Foreign",lang] => compForeignPackageCall(lang,op',argl,m,e) (op'="COLLECT") and coerceable(domain,m,e) => (T:= comp([op',:argl],domain,e) or return nil; coerce(T,m)) -- Next clause added JHD 8/Feb/94: the clause after doesn't work -- since addDomain refuses to add modemaps from Mapping (domain is ['Mapping,:.]) and (ans := compForm2(db,[op',:argl],m,e:= augModemapsFromDomain1(db,domain,domain,e), [x for x in getFormModemaps(db,[op',:argl],e) | x.mmDC = domain])) => ans ans := compForm2(db,[op',:argl],m,e:= addDomain(db,domain,e), [x for x in getFormModemaps(db,[op',:argl],e) | x.mmDC = domain]) => ans (op'="construct") and coerceable(domain,m,e) => (T:= comp([op',:argl],domain,e) or return nil; coerce(T,m)) nil T := compForm2(db,form,m,e,getFormModemaps(db,form,e)) => T --FIXME: remove next line when the parser is fixed. form = $Zero or form = $One => nil compToApply(op,argl,m,e) compForm2(db,form is [op,:argl],m,e,modemapList) == modemapList = nil => nil aList := pairList($TriangleVariableList,argl) modemapList := applySubst(aList,modemapList) -- The calling convention vector is used to determine when it is -- appropriate to infer type by compiling the argument vs. just -- looking up the parameter type for flag arguments. cc := checkCallingConvention([mm.mmSignature for mm in modemapList], #argl) Tl := [[.,.,e] := T for x in argl for i in 0.. while (T := inferMode(x,cc.i > 0,e))] where inferMode(x,flag,e) == flag => [x,quasiquote x,e] isSimple x => compUniquely(x,$EmptyMode,e) nil or/[x for x in Tl] => partialModeList := [(x => x.mode; nil) for x in Tl] compFormPartiallyBottomUp(db,form,m,e,modemapList,partialModeList) or compForm3(db,form,m,e,modemapList) compForm3(db,form,m,e,modemapList) ++ We are about to compile a call. Returns true if each argument ++ partially matches (as could be determined by type inference) the ++ corresponding expected type in the callee's modemap. compFormMatch(mm,partialModeList) == main where main() == match(mm.mmSource,partialModeList) or wantArgumentsAsTuple(partialModeList,mm.mmSource) match(a,b) == b = nil => true first b = nil => match(rest a,rest b) first a=first b and match(rest a,rest b) compFormPartiallyBottomUp(db,form,m,e,modemapList,partialModeList) == mmList := [mm for mm in modemapList | compFormMatch(mm,partialModeList)] => compForm3(db,form,m,e,mmList) nil compForm3(db,form is [op,:argl],m,e,modemapList) == T := or/ [compFormWithModemap(db,form,m,e,first (mml:= ml)) for ml in tails modemapList] $compUniquelyIfTrue => or/[compFormWithModemap(db,form,m,e,mm) for mm in rest mml] => THROW("compUniquely",nil) T T compFormWithModemap(db,form,m,e,modemap) == [map:= [.,target,:sig],[pred,impl]]:= modemap [op,:argl] := form := reshapeArgumentList(form,sig) if isCategoryForm(target,e) and isFunctor op then [modemap,e] := evaluateConstructorModemap(argl,modemap,e) or return nil [map:=[.,target,:.],:cexpr] := modemap sv := listOfSharpVars map if sv ~= nil then -- SAY [ "compiling ", op, " in compFormWithModemap, -- mode= ",map," sharp vars=",sv] for x in argl for ss in $FormalMapVariableList repeat if symbolMember?(ss,sv) then [map:= [.,target,:.],:cexpr]:= modemap :=SUBST(x,ss,modemap) -- SAY ["new map is",map] not coerceable(target,m,e) => nil [f,Tl] := compApplyModemap(db,form,modemap,e) or return nil --generate code; return T := [x',target,e'] where x':= form' := [f,:[t.expr for t in Tl]] target = $Category or isCategoryForm(target,e) => -- Constructor instantiations are direct calls ident? f and constructorDB f ~= nil => form' -- Otherwise, this is an indirect call ['%call,:form'] -- try to deal with new-style Unions where we know the conditions op = "elt" and f is ['XLAM,:.] and ident?(z := first argl) and (c := get(z,'condition,e)) and c is [["case",=z,c1]] and (c1 is [":",=(second argl),=m] or sameObject?(c1,second argl) ) => -- first is a full tag, as placed by getInverseEnvironment -- second is what getSuccessEnvironment will place there ['%tail,z] ['%call,:form'] e':= Tl ~= nil => last(Tl).env e convert(T,m) ++ Returns the list of candidate modemaps for a form. A modemap ++ is candidate for a form if its signature has the same number ++ of paramter types as arguments supplied to the form. A special ++ case is made for a modemap whose sole parameter type is a Tuple. ++ In that case, it matches any number of supplied arguments. getFormModemaps(db,form is [op,:argl],e) == op is ["elt",domain,op1] and isDomainForm(domain,e) => [x for x in getFormModemaps(db,[op1,:argl],e) | x.mmDC = domain] op is [.,:.] => nil modemapList := get(op,"modemap",e) -- Within default implementations, modemaps cannot mention the -- current domain. if $insideCategoryPackageIfTrue then modemapList := [x for x in modemapList | x.mmDC isnt '$] if form is ["elt",.,f] then modemapList := eltModemapFilter(f,modemapList,e) or return nil else if form is ["setelt",.,f,.] then modemapList := seteltModemapFilter(f,modemapList,e) or return nil nargs := #argl finalModemapList:= [mm for mm in modemapList | enoughArguments(argl,mm.mmSource)] modemapList and null finalModemapList => stackMessage('"no modemap for %1b with %2 arguments", [op,nargs]) finalModemapList ++ We are either compiling a function call, or trying to determine ++ whether we know something about a function being defined with ++ parameters are not declared in the definition. `sigs' is the list of ++ candidate signatures for `nargs' arguments or parameters. We need ++ to detemine whether any of the arguments are flags. If any ++ operation takes a flag argument, then all other overloads must have ++ the same arity and must take flag argument in the same position. ++ Returns a vector of length `nargs' with positive entries indicating ++ flag arguments, and negative entries for normal argument passing. checkCallingConvention(sigs,nargs) == v := makeFilledSimpleArray("%Short",nargs,0) for sig in sigs repeat for t in rest sig for i in 0.. repeat isQuasiquote t => arrayRef(v,i) < 0 => userError '"flag argument restriction violation" arrayRef(v,i) := arrayRef(v,i) + 1 arrayRef(v,i) > 0 => userError '"flag argument restriction violation" arrayRef(v,i) := arrayRef(v,i) - 1 v eltModemapFilter(name,mmList,e) == isConstantId(name,e) => l:= [mm for mm in mmList | second mm.mmSource = name] => l --there are elts with extra parameters stackMessage('"selector variable: %1b is undeclared and unbound",[name]) nil mmList seteltModemapFilter(name,mmList,e) == isConstantId(name,e) => l:= [mm for mm in mmList | second mm.mmSource = name] => l --there are setelts with extra parameters stackMessage('"selector variable: %1b is undeclared and unbound",[name]) nil mmList compApplication(op,argl,m,T) == e := T.env T.mode is ['Mapping, retm, :argml] => #argl ~= #argml => nil retm := resolve(m, retm) retm = $Category or isCategoryForm(retm,e) => nil -- not handled argTl := [[.,.,e] := comp(x,m,e) or return "failed" for x in argl for m in argml] argTl = "failed" => nil form:= args := [a.expr for a in argTl] ident? T.expr and not (symbolMember?(op,$formalArgList) or symbolMember?(T.expr,$formalArgList)) and null get(T.expr,"value",e) => emitLocalCallInsn(T.expr,args,e) ['%call,['%apply,T.expr],:args] coerce([form, retm, e],resolve(retm,m)) op is 'elt => nil eltForm := ['elt, op, :argl] comp(eltForm, m, e) compToApply(op,argl,m,e) == T := compNoStacking(currentDB e,op,$EmptyMode,e) or return nil T.expr is ['QUOTE, =T.mode] => nil compApplication(op,argl,m,T) ++ `form' is a call to a operation described by the signature `sig'. ++ Massage the call so that homogeneous variable length argument lists ++ are properly tuplified. reshapeArgumentList(form,sig) == [op,:args] := form wantArgumentsAsTuple(args,sig) => [op,["%Comma",:args]] form ++ Attempt to find values for queries variables `vars' so that ++ the category expression `x' equals the category expression `p'. solveEquation(x,p,sl,vars) == ident? p and symbolMember?(p,vars) => z := symbolTarget(p,sl) => x = z => sl 'failed [[p,:x],:sl] x isnt [.,:.] or p isnt [.,:.] => x = p => sl 'failed symbolEq?(x.op,p.op) => #x.args ~= #p.args => 'failed x.args = nil => sl and/[sl := solveEquation(x',p',sl,vars) for x' in x.args for p' in p.args | sl isnt 'failed or leave 'failed] 'failed ++ Attempt to find values for queries variables `vars' so that ++ the category expression `x' subsumes the category expression `p'. solveSubsumption(x,p,sl,vars,typings,e) == x isnt [.,:.] or p isnt [.,:.] => solveEquation(x,p,sl,vars) p = $Type => sl symbolEq?(x.op,p.op) => solveEquation(x,p,sl,vars) x.op is 'Join => x.args = nil => 'failed or/[sl' := solveSubsumption(x',p,sl,vars,typings,e) for x' in x.args | sl' isnt 'failed] or 'failed x is ['CATEGORY,.,:xs] => or/[sl' := solveSubsumption(x',p,sl,vars,typings,e) for x' in xs | sl' isnt 'failed] or 'failed x.op in '(SIGNATURE ATTRIBUTE) => 'failed getConstructorKind x.op isnt 'category => 'failed --FIXME: for now. x := applySubst(constructSubst x,getConstructorCategory x.op) solveSubsumption(x,p,sl,vars,typings,e) ++ Subroutine of bindPredicateExistentials, with similar semantics. ++ `vars' is the list of quantified variables, and `conds' is a ++ of conditions the conjunction of which makes the whole predicate. deduceImplicitArguments(vars,conds,e) == eqs := nil -- equation constraints typings := nil -- typing constraints sl := nil for c in conds while sl isnt 'failed repeat c is ['ofCategory,x,y] => -- subsumption constraint ident? x and symbolMember?(x,vars) => typings := [[x,:y],:typings] eqs := [[x,:y],:eqs] c is ['ofType,x,y] => -- exact type constraints T := comp(x,$EmptyMode,e) T = nil => sl := 'failed sl := solveEquation(T.mode,y,sl,vars) for [x,:y] in eqs while sl isnt 'failed repeat cat := x isnt [.,:.] => getXmode(x,e) applySubst(constructSubst x,getConstructorCategory x.op) sl := solveSubsumption(cat,y,sl,vars,typings,e) sl is 'failed => sl -- Every existential must have a value or/[symbolTarget(v,sl) = nil for v in vars] => 'failed sl --FIXME: check typing constraints ++ Attempt to find values for existentially quantified variables in ++ the predicate `cond' so that it holds in the environment `e'. ++ Return a substitution on success; otherwise fail. bindPredicateExistentials(cond,e) == cond is true => nil -- identity substitution cond is ['%exist,vars,['AND,:conds]] => deduceImplicitArguments(vars,conds,e) 'failed ++ The argument list `argl' is used to instantiate a constructor ++ with `modemap' in environment `e'. Return the resulting ++ modemap is instantiation is legit. evaluateConstructorModemap(argl,modemap is [[dc,:sig],:.],e) == #dc ~= #sig => keyedSystemError("S2GE0016",['"evaluateConstructorModemap", '"Incompatible maps"]) #argl ~= #sig.source => nil -- Get `source-level' subtitution in an attempt to deduce implicits. sl := pairList(dc.args,argl) sl' := bindPredicateExistentials(applySubst(sl,modemap.mmCondition),e) sl' is 'failed => nil -- Subtitute values for implicit in formal modemap. Then substitute -- the `source-level' arguments into the resulting modemap, before -- compiling them. Note the sort of bootstrapping process. signature := applySubst(sl',modemap.mmSignature) args' := [x for a in argl for m in applySubst(sl,signature.source) | [x,.,e] := compOrCroak(a,m,e)] -- Now substitutte elaborations of actual arguments into the formal -- signature to construct the final result. signature := applySubst(pairList(dc.args,args'),signature) -- At this point, the modemap condition was evaluated successfully, -- so we return plain `true' for that part of the modemap. [[[[dc.op,:args'],:signature],[true,dc.op]],e] --% SPECIAL EVALUATION FUNCTIONS compEnumCat(x,m,e) == for arg in x.args repeat ident? arg => nil -- OK stackAndThrow('"all arguments to %1b must be identifiers",[x.op]) [x,resolve($Category,m),e] compConstructorCategory(x,m,e) == x is [ctor,:args] => ctor in '(RecordCategory UnionCategory MappingCategory) => failed := false colons := 0 args' := [] while not failed for y in args repeat y is [":",.,t] => colons := colons + 1 [t',.,e] := compForMode(t,$EmptyMode,e) or return (failed := true) args' := [[y.op,second y,t'],:args'] [t',.,e] := compForMode(y,$EmptyMode,e) or return (failed := true) args' := [t',:args'] failed => nil colons ~= 0 and colons ~= #args and ctor isnt 'MappingCategory => nil [[ctor,:reverse! args'],resolve($Category,m),e] ctor is 'EnumerationCategory => compEnumCat(x,m,e) nil nil --% SUBSET CATEGORY compSubsetCategory: (%Form,%Mode,%Env) -> %Maybe %Triple compSubsetCategory(["SubsetCategory",cat,R],m,e) == --1. put "Subsets" property on R to allow directly coercion to subset; -- allow automatic coercion from subset to R but not vice versa e:= put(R,"Subsets",[[$lhsOfColon,"isFalse"]],e) --2. give the subset domain modemaps of cat plus 3 new functions comp(["Join",cat,C'],m,e) where C'() == substitute($lhsOfColon,"$",C'') where C''() == ["CATEGORY","domain",["SIGNATURE","coerce",[R,"$"]],["SIGNATURE", "lift",[R,"$"]],["SIGNATURE","reduce",["$",R]]] --% CONS compCons: (%Form,%Mode,%Env) -> %Maybe %Triple compCons1: (%Form,%Mode,%Env) -> %Maybe %Triple compCons(form,m,e) == compCons1(form,m,e) or compForm(currentDB e,form,m,e) compCons1(["CONS",x,y],m,e) == [x,mx,e]:= comp(x,$EmptyMode,e) or return nil null y => coerce([['%list,x],["List",mx],e],m) yt:= [y,my,e]:= comp(y,$EmptyMode,e) or return nil T:= my is ["List",m',:.] => mr:= ["List",resolve(m',mx) or return nil] yt':= coerce(yt,mr) or return nil [x,.,e]:= coerce([x,mx,yt'.env],second mr) or return nil yt'.expr is ['%list,:.] => [['%list,x,:rest yt'.expr],mr,e] [['%pair,x,yt'.expr],mr,e] [['%pair,x,y],["Pair",mx,my],e] coerce(T,m) --% SETQ compSetq: (%Instantiation,%Mode,%Env) -> %Maybe %Triple compSetq1: (%Form,%Form,%Mode,%Env) -> %Maybe %Triple compSetq([":=",form,val],m,E) == compSetq1(form,val,m,E) compSetq1(form,val,m,E) == ident? form => setqSingle(form,val,m,E) form is [":",x,y] => [.,.,E']:= compMakeDeclaration(x,y,E) compSetq1(x,val,m,E') form is [op,:l] => op is "CONS" => setqMultiple(uncons form,val,m,E) op is "%Comma" => setqMultiple(l,val,m,E) setqSetelt(form,val,m,E) compMakeDeclaration: (%Form,%Mode,%Env) -> %Maybe %Triple compMakeDeclaration(x,m,e) == $insideExpressionIfTrue: local := false compColon([":",x,m],$EmptyMode,e) setqSetelt([v,:s],val,m,E) == comp(["setelt",v,:s,val],m,E) setqSingle(id,val,m,E) == checkVariableName id db := currentDB 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) T:= eval or return nil where eval() == T:= comp(val,m'',E) => T get(id,"mode",E) = nil and m'' ~= (maxm'':=maximalSuperType m'') 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']:= coerce(T,m) or return nil if $profileCompiler then not ident? id => nil key := symbolMember?(id,$form.args) => "arguments" "locals" profileRecord(key,id,T.mode) newProplist := consProplistOf(id,currentProplist,"value",removeEnv [val,:rest T]) e':= cons? id => e' addBinding(id,newProplist,e') if isDomainForm(val,e') then if isDomainInScope(id,e') then stackWarning('"domain valued variable %1b has been reassigned within its scope",[id]) -- single domains have constant values in their scopes, we might just -- as well take advantage of that at compile-time where appropriate. e' := put(id,'%macro,val,e') e':= augModemapsFromDomain1(db,id,val,e') --all we do now is to allocate a slot number for lhs --e.g. the %LET form below will be changed by putInLocalDomainReferences form := k := assocIndex(db,id) => ['%store,['%tref,'$,k],x] ["%LET",id,x] [form,m',e'] assignError(val,m',form,m) == val => stackMessage('"CANNOT ASSIGN: %1b OF MODE: %2pb TO: %3b OF MODE: %4bp", [val,m',form,m]) stackMessage('"CANNOT ASSIGN: %1b TO: %2b OF MODE: %3pb",[val,form,m]) setqMultiple(nameList,val,m,e) == val is ["CONS",:.] and m=$NoValueMode => setqMultipleExplicit(nameList,uncons val,m,e) val is ["%Comma",: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]:= coerce(T,m) or return nil -- 2. exit if result is a list m1 is ["List",D] => for y in nameList repeat e:= giveVariableSomeValue(y,D,e) coerce([['%seq,x,["%LET",nameList,g],g],m',e],m) -- 3. For a cross, do it by hand here instead of general mm. FIXME. m1 is ['Cross,:.] => n := #m1.args #nameList ~= n => stackMessage('"%1b must decompose into %2 components",[val,n]) stmts := nil for y in nameList for t in m1.args for i in 0.. repeat e := giveVariableSomeValue(y,t,e) stmts := [['%LET,y,['%call,eltRecordFun(n,i),g,i]],:stmts] coerce([['%seq,x,:reverse! stmts,g],m1,e],m) -- 4. 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: %1p",[t]) #nameList~=#selectorModePairs => stackMessage('"%1b must decompose into %2 components",[val,#nameList]) -- 5. 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] assignList="failed" => nil [['%seq,x,:assignList,g],m',e] setqMultipleExplicit(nameList,valList,m,e) == #nameList~=#valList => stackMessage('"Multiple assignment error; # of items in: %1b must = # in: %2",[nameList,valList]) gensymList:= [genVariable() for name in nameList] bindings := --should be fixed to declare genVar when possible [insn.args for g in gensymList for val in valList | [insn,.,e] := compSetq1(g,val,$EmptyMode,e) or leave "failed" ] bindings is "failed" => nil reAssignList := [[.,.,e] := compSetq1(name,g,$EmptyMode,e) or return "failed" for g in gensymList for name in nameList] reAssignList is "failed" => nil [['%bind,bindings,['%seq,:[T.expr for T in reAssignList]]], $NoValueMode, last(reAssignList).env] --% Quasiquotation ++ Compile a quotation `[| form |]'. form is not type-checked, and ++ is returned as is. Note: when get to support splicing, we would ++ need to scan `form' to see whether there is any computation that ++ must be done. ++ ??? Another strategy would be to infer a more accurate domain ++ ??? based on the meta operator, e.g. (DEF ...) would be a ++ DefinitionAst, etc. That however requires that we have a full ++ fledged AST algebra -- which we don't have yet in mainstream. compileQuasiquote: (%Instantiation,%Mode,%Env) -> %Maybe %Triple compileQuasiquote(["[||]",:form],m,e) == null form => nil coerce([['QUOTE, :form],$Syntax,e], m) --% WHERE ++ The form `item' appears in a side condition of a where-expression. ++ Register all declarations it locally introduces. recordDeclarationInSideCondition(item,e,decls) == item is [":",x,t] => t := macroExpand(t,e) ident? x => deref(decls) := [[x,t],:deref decls] x is ['%Comma,:.] => deref(decls) := [:[[x',t] for x' in x.args],:deref decls] item is ['SEQ,:stmts,["exit",.,val]] => for stmt in stmts repeat recordDeclarationInSideCondition(stmt,e,decls) recordDeclarationInSideCondition(val,e,decls) compWhere: (%Form,%Mode,%Env) -> %Maybe %Triple compWhere([.,form,:exprList],m,eInit) == $insideExpressionIfTrue: local:= false $insideWhereIfTrue: local := true e := eInit decls := ref get('%compilerData,'%whereDecls,e) u := for item in exprList repeat recordDeclarationInSideCondition(item,e,decls) [.,.,e]:= comp(item,$EmptyMode,e) or return "failed" u is "failed" => return nil -- Remember side declaration constraints, if any. if deref decls ~= nil then e := put('%compilerData,'%whereDecls,deref decls,e) $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] compConstruct: (%Form,%Mode,%Env) -> %Maybe %Triple compConstruct(form is ["construct",:l],m,e) == db := currentDB e y:= modeIsAggregateOf("List",m,e) => T:= compList(l,["List",second y],e) => coerce(T,m) compForm(db,form,m,e) y:= modeIsAggregateOf("Vector",m,e) => T:= compVector(l,["Vector",second y],e) => coerce(T,m) compForm(db,form,m,e) T:= compForm(db,form,m,e) => T for D in getDomainsInScope e repeat (y:=modeIsAggregateOf("List",D,e)) and (T:= compList(l,["List",second y],e)) and (T':= coerce(T,m)) => return T' (y:=modeIsAggregateOf("Vector",D,e)) and (T:= compVector(l,["Vector",second y],e)) and (T':= coerce(T,m)) => return T' ++ Compile a literal (quoted) symbol. compQuote: (%Form,%Mode,%Env) -> %Maybe %Triple compQuote(expr,m,e) == expr is ['QUOTE,x] and ident? x => -- Ideally, Identifier should be the default type. However, for -- historical reasons we cannot afford that luxury yet. m = $Identifier or listMember?(m,$IOFormDomains) => [expr,m,e] coerce([expr,$Symbol,e],m) stackAndThrow('"%1b is not a literal symbol.",[x]) compList: (%Form,%Mode,%Env) -> %Maybe %Triple compList(l,m is ["List",mUnder],e) == null l => ['%nil,m,e] Tl:= [[.,mUnder,e]:= comp(x,mUnder,e) or return "failed" for x in l] Tl is "failed" => nil T := [['%list,:[T.expr for T in Tl]],["List",mUnder],e] compVector: (%Form,%Mode,%Env) -> %Maybe %Triple compVector(l,m is ["Vector",mUnder],e) == Tl := [[.,mUnder,e]:= comp(x,mUnder,e) or return "failed" for x in l] Tl is "failed" => nil [["MAKE-ARRAY", #Tl, KEYWORD::ELEMENT_-TYPE, quote getVMType mUnder, KEYWORD::INITIAL_-CONTENTS, ['%list, :[T.expr for T in Tl]]],m,e] --% MACROS compMacro(form,m,e) == ["MDEF",lhs,signature,rhs] := form if $verbose then prhs := 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,'" ==> ",:prhs,'"%d"] m=$EmptyMode or m=$NoValueMode => -- Macro names shall be identifiers. (lhs isnt [.,:.] and not ident? lhs) or (lhs is [op,:.] and not ident? op) => stackMessage('"invalid left-hand-side in macro definition",nil) e -- We do not have the means, at this late stage, to make a distinction -- between a niladic functional macro and an identifier that is -- defined as a macro. if lhs is [op] then lhs := op ["/throwAway",$NoValueMode,putMacro(lhs,macroExpand(rhs,e),e)] nil --% %Do compDo: (%Form,%Mode,%Env) -> %Triple compDo(x,m,e) == compOrCroak(first x.args,m,e) --% SEQ compSeq: (%Form,%Mode,%Env) -> %Maybe %Triple compSeq1: (%Form,%List %Thing,%Env) -> %Maybe %Triple compSeqItem: (%Form,%Mode,%Env) -> %Maybe %Triple compSeq(["SEQ",:l],m,e) == compSeq1(l,[m,:$exitModeStack],e) compSeq1(l,$exitModeStack,e) == $insideExpressionIfTrue: local := false $finalEnv: local := nil --used in replaceExitEtc. c := [([.,.,e] := compSeqItem(x,$NoValueMode,e) or leave "failed").expr for x in l] if c is "failed" then return nil catchTag := MKQ gensym() form := ['%seq,:replaceExitEtc(c,catchTag,"TAGGEDexit",first $exitModeStack)] [['%scope,catchTag,form],first $exitModeStack,$finalEnv] compSeqItem(x,m,e) == $insideExpressionIfTrue := false comp(macroExpand(x,e),m,e) replaceExitEtc(x,tag,opFlag,opMode) == (fn(x,tag,opFlag,opMode); x) where fn(x,tag,opFlag,opMode) == atomic? x => nil x is [ =opFlag,n,t] => t.expr := replaceExitEtc(t.expr,tag,opFlag,opMode) n=0 => $finalEnv := $finalEnv ~= nil => intersectionEnvironment($finalEnv,t.env) t.env x.op := opFlag is 'TAGGEDreturn => '%return second(x) := tag '%leave third(x) := convertOrCroak(t,opMode).expr second(x) := n-1 x is [key,n,t] and key in '(TAGGEDreturn TAGGEDexit) => t.expr := replaceExitEtc(t.expr,tag,opFlag,opMode) replaceExitEtc(first x,tag,opFlag,opMode) replaceExitEtc(rest x,tag,opFlag,opMode) --% SUCHTHAT compSuchthat: (%Form,%Mode,%Env) -> %Maybe %Triple compSuchthat([.,x,p],m,e) == [x',m',e]:= comp(x,m,e) or return nil [p',.,e]:= comp(p,$Boolean,e) or return nil e:= put(x',"condition",p',e) [x',m',e] --% exit compExit: (%Form,%Mode,%Env) -> %Maybe %Triple compExit(["exit",level,x],m,e) == index := level-1 $exitModeStack = [] => comp(x,m,e) m1 := $exitModeStack.index [x',m',e']:= u := comp(x,m1,e) or return stackMessageIfNone ["cannot compile exit expression",x,"in mode",m1] modifyModeStack(m',index) [["TAGGEDexit",index,u],m,e] modifyModeStack(m,index) == $reportExitModeStack => SAY("exitModeStack: ",copyTree $exitModeStack," ====> ", ($exitModeStack.index:= resolve(m,$exitModeStack.index); $exitModeStack)) $exitModeStack.index:= resolve(m,$exitModeStack.index) compLeave: (%Form,%Mode,%Env) -> %Maybe %Triple compLeave(["leave",level,x],m,e) == index := #$exitModeStack - 1 - $leaveLevelStack.(level-1) [x',m',e'] := u := comp(x,$exitModeStack.index,e) or return nil modifyModeStack(m',index) [["TAGGEDexit",index,u],m,e] jumpFromLoop(kind,key) == null $exitModeStack or kind ~= $loopKind => stackAndThrow('"You can use %1b only in %2b loop",[key,kind]) false true compBreak: (%Symbol,%Mode,%Env) -> %Maybe %Triple compBreak(x,m,e) == x isnt "break" or not jumpFromLoop("REPEAT",x) => nil index := #$exitModeStack - 1 - $leaveLevelStack.0 $breakCount := $breakCount + 1 u := coerce(["$NoValue",$Void,e],$exitModeStack.index) or return nil u := coerce(u,m) or return nil modifyModeStack(u.mode,index) [["TAGGEDexit",index,u],m,e] compIterate: (%Symbol,%Mode,%Env) -> %Maybe %Triple compIterate(x,m,e) == x isnt "iterate" or not jumpFromLoop("REPEAT",x) => nil index := #$exitModeStack - 1 - ($leaveLevelStack.0 + 1) $iterateCount := $iterateCount + 1 u := coerce(['%nil,'$Void,e],$exitModeStack.index) or return nil u := coerce(u,m) or return nil modifyModeStack(u.mode,index) if $loopBodyTag = nil then -- bound in compRepeatOrCollect $loopBodyTag := MKQ gensym() [['%leave,$loopBodyTag,u.expr],u.mode,e] --% return compReturn: (%Form,%Mode,%Env) -> %Maybe %Triple compReturn(["return",x],m,e) == null $exitModeStack => stackAndThrow('"the return before %1b is unneccessary",[x]) nil index:= MAX(0,#$exitModeStack-1) if index >= 0 then $returnMode:= resolve($exitModeStack.index,$returnMode) [x',m',e']:= u:= comp(x,$returnMode,e) or return nil if index>=0 then $returnMode:= resolve(m',$returnMode) modifyModeStack(m',index) [["TAGGEDreturn",0,u],m,e'] --% throw expressions compThrow: (%Form,%Mode,%Env) -> %Maybe %Triple compThrow(["%Throw",x],m,e) == T := compOrCroak(x,$EmptyMode,e) -- An exception does not use the normal exit/return route, so -- we don't take into account neither $exitModeStack nor $returnMode. [['%throw,T.mode,T.expr],$NoValueMode,T.env] compCatch: (%Form,%Mode,%Env) -> %Maybe %Triple compCatch([x,s],m,e) == [.,m',e] := compMakeDeclaration(second x, third x,e) T := compOrCroak(s,m,e) [['%catch,second x,m',T.expr],T.mode,T.env] compTry: (%Form,%Mode,%Env) -> %Maybe %Triple compTry(['%Try,x,ys,z],m,e) == x' := compOrCroak(x,m,e).expr ys' := [compCatch(y,m,e).expr for y in ys] z' := z = nil => nil ['%finally,compOrCroak(z,$NoValueMode,e).expr] [['%try,x',ys',z'],m,e] --% ELT getModemapListFromDomain(op,numOfArgs,D,e) == [mm for (mm:= [[dc,:sig],:.]) in get(op,'modemap,e) | dc=D and #rest sig= numOfArgs] ++ `op' supposedly designate an external entity with language linkage ++ `lang'. Return the mode of its local declaration (import). getExternalSymbolMode(op,lang,e) == lang is 'Builtin => "%Thing" -- for the time being lang is 'Lisp => "%Thing" -- for the time being lang is "C" => stackAndThrow('"Sorry: %b Foreign %1b %d is invalid at the moment",[lang]) get(op,"%Lang",e) ~= lang => stackAndThrow('"%1bp is not known to have language linkage %2bp",[op,lang]) getmode(op,e) or stackAndThrow('"Operator %1bp is not in scope",[op]) compElt: (%Form,%Mode,%Env) -> %Maybe %Triple compElt(form,m,E) == db := currentDB E form isnt ["elt",aDomain,anOp] => compForm(db,form,m,E) aDomain is "Lisp" or (aDomain is ["Foreign",lang] and lang="Builtin") => [anOp',m,E] where anOp'() == (anOp = $Zero => 0; anOp = $One => 1; anOp) lang ~= nil => opMode := getExternalSymbolMode(anOp,lang,E) op := get(anOp,"%Link",E) or anOp coerce([op,opMode,E],m) isDomainForm(aDomain,E) => E := addDomain(db,aDomain,E) mmList:= getModemapListFromDomain(internalName anOp,0,aDomain,E) modemap:= -- FIXME: do this only for constants. n:=#mmList 1=n => mmList.0 0=n => return stackMessage('"Operation %1b missing from domain: %2p", [anOp,aDomain]) stackWarning('"more than 1 modemap for: %1 with dc = %2p ===> %3", [anOp,aDomain,mmList]) mmList.0 [sig,[pred,val]]:= modemap #sig ~= 2 and val isnt ["CONST",:.] => nil val := genDeltaEntry(db,opOf anOp,modemap,E) coerce([['%call,val],second sig,E], m) compForm(db,form,m,E) --% HAS compHas: (%Form,%Mode,%Env) -> %Maybe %Triple compHas(pred is ["has",a,b],m,e) == e := chaseInferences(pred,e) predCode := compHasFormat(currentDB e,pred,e) coerce([predCode,$Boolean,e],m) --used in various other places to make the discrimination compHasFormat(db,pred is ["has",olda,b],e) == argl := $form.args formals := take(#argl,$FormalMapVariableList) a := applySubst(pairList(formals,argl),olda) [a,.,e] := comp(a,$EmptyMode,e) or return nil a := applySubst(pairList(argl,formals),a) b is ["ATTRIBUTE",c] => ["HasAttribute",a,quote c] b is ["SIGNATURE",op,sig,:.] => ["HasSignature",a, mkList [MKQ op,mkList [mkTypeForm type for type in sig]]] b is ["Join",:l] or b is ["CATEGORY",.,:l] => ["AND",:[compHasFormat(db,["has",olda,c],e) for c in l]] isCategoryForm(b,e) => ["HasCategory",a,optimize! mkTypeForm b] stackAndThrow('"Second argument to %1b must be a category, or a signature or an attribute",["has"]) --% IF compIf: (%Form,%Mode,%Env) -> %Maybe %Triple compPredicate: (%Form,%Env) -> %Code compFromIf: (%Form,%Mode,%Env) -> %Maybe %Triple compIf(["IF",a,b,c],m,E) == [xa,ma,Ea,Einv]:= compPredicate(a,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,xb'.expr,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] canReturn(expr,level,exitCount,ValueFlag) == --SPAD: exit and friends expr isnt [.,:.] => ValueFlag and level=exitCount op := expr.op op in '(QUOTE CLOSEDFN %lambda) => ValueFlag and level=exitCount op is "TAGGEDexit" => expr is [.,count,data] => canReturn(data.expr,level,count,count=level) level=exitCount and not ValueFlag => nil op is '%seq => or/[canReturn(u,level+1,exitCount,false) for u in rest expr] op is "TAGGEDreturn" => nil op is '%scope => [.,gs,data]:= expr (findThrow(gs,data,level,exitCount,ValueFlag) => true) where findThrow(gs,expr,level,exitCount,ValueFlag) == expr isnt [.,:.] => nil expr is ['%leave, =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 is '%when => 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 is "IF" => expr is [.,a,b,c] if not canReturn(a,0,0,true) 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) op in '(LET %bind) => or/[canReturn(init,level,exitCount,false) for [.,init] in second expr] or canReturn(third expr,level,exitCount,ValueFlag) --now we have an ordinary form op isnt [.,:.] => and/[canReturn(u,level,exitCount,ValueFlag) for u in expr] systemErrorHere ['"canReturn",expr] --for the time being ++ We are compiling a conditional expression, type check and generate ++ code for the predicate of the branch as a Boolean expression. compPredicate(p,E) == -- Ideally, we should be first inferring the type of the predicate -- `p'. That would have the virtue of pointing out possible -- ambiguities. Then, on a second phase, implicitly coerce the -- the result to Boolean. However, that would not quite work. The -- being that there are cases, such as equality, that are highgly -- ambiguous (e.g. see the various overloading of `=') for which it -- would be unfortunate to require more type annotation. Note that -- the problem here is many misguided overloading of some operators. -- Consequently, we compile directly with Boolean as target. [p',m,E] := comp(p,$Boolean,E) or return nil [p',m,getSuccessEnvironment(p,E),getInverseEnvironment(p,E)] compFromIf(a,m,E) == a is "%noBranch" => ["%noBranch",m,E] comp(a,m,E) compImport: (%Form,%Mode,%Env) -> %Triple compImport(["import",:doms],m,e) == if not $bootStrapMode then for dom in doms repeat e := addDomain(currentDB e,dom,e) ["/throwAway",$NoValueMode,e] --% Foreign Function Interface bootDenotation: %Symbol -> %Symbol bootDenotation s == makeSymbol(symbolName s,"BOOTTRAN") ++ Return the Boot denotation of a basic FFI type. getBasicFFIType: %Mode -> %Symbol getBasicFFIType t == t = $Byte => bootDenotation "byte" t = $Int16 => bootDenotation "int16" t = $UInt16 => bootDenotation "uint16" t = $Int32 => bootDenotation "int32" t = $UInt32 => bootDenotation "uint32" t = $Int64 => bootDenotation "int64" t = $UInt64 => bootDenotation "uint64" t = $SingleInteger => bootDenotation "int" t = $DoubleFloat => bootDenotation "double" t = $String => bootDenotation "string" t = $SystemPointer => bootDenotation "pointer" nil ++ List of admissible type modifiers in an FFI import declaration. $FFITypeModifier == '(ReadOnly WriteOnly ReadWrite) ++ List of admissible element types of contiguously stored ++ homogeneous FFI aggregate types. $FFIAggregableDataType == [$Byte, $Int16,$UInt16, $Int32,$UInt32, $Int64, $UInt64, $DoubleFloat] ++ Return the Boot denotation of an FFI datatype. This is either ++ a basic VM type, or a simple array of sized integer or floating ++ point type. getFFIDatatype: %Mode -> %Form getFFIDatatype t == x := getBasicFFIType t => x t is [m,["PrimitiveArray",t']] and symbolMember?(m,$FFITypeModifier) and listMember?(t',$FFIAggregableDataType) => m' := m is "ReadOnly" => bootDenotation "readonly" m is "WriteOnly" => bootDenotation "writeonly" bootDenotation "readwrite" [m',[bootDenotation "buffer",getBasicFFIType t']] nil ++ Return the Boot denotation of a type that is valid in a external entity ++ signature. getBootType: %Mode -> %Form getBootType t == x := getFFIDatatype t => x t is ["Mapping",ret,:args] => ret' := ret = $Void => bootDenotation "void" getBasicFFIType ret or return nil args' := [getFFIDatatype arg or return "failed" for arg in args] args' = "failed" => return nil [bootDenotation "%Mapping",ret',args'] nil ++ Verify that mode `t' is admissible in an external entity signature ++ specification, and return its Boot denotation. checkExternalEntityType(t,e) == t isnt [.,:.] => stackAndThrow('"Type variable not allowed in import of external entity",nil) t' := getBootType t => t' stackAndThrow('"Type %1bp is invalid in a foreign signature",[t]) ++ An external entity named `id' is being imported under signature ++ `type' from a foreign language `lang'. Check that the import ++ is valid, and if so return the linkage name of the entity. checkExternalEntity(id,type,lang,e) == checkVariableName id -- An external entity name shall be unique in scope. getmode(id,e) => stackAndThrow('"%1b is already in scope",[id]) -- In particular, an external entity name cannot be overloaded -- with exported operators. get(id,"modemap",e) => stackAndThrow('"%1b already names exported operations in scope",[id]) -- We don't type check builtin declarations at the moment. lang is 'Builtin or lang is 'Lisp => id -- Only functions are accepted at the moment. And all mentioned -- types must be those that are supported by the FFI. type' := checkExternalEntityType(type,e) type' isnt [=bootDenotation "%Mapping",:.] => stackAndThrow('"Signature for external entity must be a Mapping type",nil) id' := encodeLocalFunctionName id [def] := genImportDeclaration(id',[bootDenotation "%Signature",id,type'], ["Foreign", lang]) apply($backend,[def]) id' ++ Remove possible modifiers in the FFI type expression `t'. removeModifiers t == for (ts := [x,:.]) in tails t repeat x is [m,t'] and symbolMember?(m,$FFITypeModifier) => ts.first := t' t ++ Compile external entity signature import. compSignatureImport: (%Form,%Mode,%Env) -> %Maybe %Triple compSignatureImport(["%SignatureImport",id,type,home],m,e) == -- 1. Make sure we have the right syntax. home isnt ["Foreign",:args] => stackAndThrow('"signature import must be from a %1bp domain",["Foreign"]) args isnt [lang] => stackAndThrow('"%1bp takes exactly one argument",["Foreign"]) not ident? lang => stackAndThrow('"Argument to %1bp must be an identifier",["Foreign"]) not (lang in '(Builtin C Lisp)) => stackAndThrow('"Sorry: Only %1bp is valid at the moment",["Foreign C"]) -- 2. Make sure this import is not subverting anything we know id' := checkExternalEntity(id,type,lang,e) -- 3. Make a local declaration for it. T := [.,.,e] := compMakeDeclaration(id,removeModifiers type,e) or return nil e := put(id,"%Lang",lang,e) e := put(id,"%Link",id',e) -- 4. Also make non-function externals self-evaluating so we don't -- complain later for undefined variable references. if T.mode isnt ['Mapping,:.] then e := put(id,"value",[id',T.mode,nil],e) T.env := e coerce(T,m) ++ Compile package call to an external function. ++ `lang' is the language calling convention ++ `op' is the operator name ++ `args' is the list of arguments ++ `m' is the context mode. ++ `e' is the compilation environment in effect. compForeignPackageCall(lang,op,args,m,e) == lang = "Builtin" => -- Note: We don't rename builtin functions. [[op,:[([.,.,e]:= compOrCroak(x,$EmptyMode,e)).expr for x in args]],m,e] getExternalSymbolMode(op,lang,e) is ["Mapping",:argModes] and (#argModes = #args + 1) => applyMapping([op,:args],m,e,argModes) stackAndThrow('"OpenAxiom could not determine the meaning of %1bp",[op]) --% Compilation of logical operators that may have a pre-defined --% meaning, or may need special handling because or short-circuiting --% etc. ++ Compile a logical negation form `(not ...)'. compLogicalNot: (%Form,%Mode,%Env) -> %Maybe %Triple compLogicalNot(x,m,e) == db := currentDB e x isnt ["not", y] => nil -- ??? For the time being compiler values cannot handle operations -- ??? selected through general modemaps, and their semantics -- ??? are quite hardwired with their syntax. -- ??? Eventually, we should not need to do this. yTarget := $normalizeTree and resolve(m,$Boolean) = $Boolean => $Boolean $EmptyMode yT := comp(y,yTarget,e) or return nil yT.mode = $Boolean and yTarget = $Boolean => [["%not",yT.expr],yT.mode,yT.env] compResolveCall(db,"not",[yT],m,yT.env) ++ Compile an exclusive `xor' expression. compExclusiveOr: (%Form,%Mode,%Env) -> %Maybe %Triple compExclusiveOr(x,m,e) == db := currentDB e x isnt ["xor",a,b] => nil aT := comp(a,$EmptyMode,e) or return nil e := aT.mode = $Boolean => getSuccessEnvironment(a,aT.env) aT.env bT := comp(b,$EmptyMode,e) or return nil compResolveCall(db,"xor",[aT,bT],m,bT.env) --% Case compCase: (%Form,%Mode,%Env) -> %Maybe %Triple compCase1: (%Database,%Form,%Mode,%Env) -> %Maybe %Triple getModemapList(op,nargs,e) == op is ['elt,D,op'] => getModemapListFromDomain(internalName op',nargs,D,e) [mm for (mm:= [[.,.,:sigl],:.]) in get(op,'modemap,e) | nargs=#sigl] --Will the jerk who commented out these two functions please NOT do so --again. These functions ARE needed, and case can NOT be done by --modemap alone. The reason is that A case B requires to take A --evaluated, but B unevaluated. Therefore a special function is --required. You may have thought that you had tested this on "failed" --etc., but "failed" evaluates to it's own mode. Try it on x case $ --next time. -- An angry JHD - August 15th., 1984 compCase(["case",x,m'],m,e) == db := currentDB e e:= addDomain(db,m',e) T:= compCase1(db,x,m',e) => coerce(T,m) nil compCase1(db,x,m,e) == [x',m',e'] := comp(x,$EmptyMode,e) or return nil u := [mm for mm in getModemapList("case",2,e') | mm.mmSignature is [=$Boolean,s,t] and modeEqual(maybeSpliceMode t,m) and modeEqual(s,m')] or return nil fn := (or/[mm for mm in u | mm.mmCondition = true]) or return nil fn := genDeltaEntry(db,"case",fn,e) [['%call,fn,x',MKQ m],$Boolean,e'] ++ For `case' operation implemented in library, the second operand ++ (target type) is taken unevaluated. The corresponding parameter ++ type in the modemap was specified as quasiquotation. We ++ want to look at the actual type when comparing with modeEqual. maybeSpliceMode: %Mode -> %Mode maybeSpliceMode m == (m' := isQuasiquote m) => m' m categoryInstance? x == x is [c,:.] and ident? c and categoryConstructor? c compColon: (%Form,%Mode,%Env) -> %Maybe %Triple compColon([":",f,t],m,e) == db := currentDB e $insideExpressionIfTrue => compColonInside(db,f,m,e,t) --if inside an expression, ":" means to convert to m "on faith" $lhsOfColon: local:= f t:= t isnt [.,:.] and (t':= assoc(t,getDomainsInScope e)) => t' t = $Category and categoryInstance? f => t not dbForCategory? db and isDomainForm(t,e) => e := addDomain(db,t,e) t isDomainForm(t,e) or isCategoryForm(t,e) => t t is ["Mapping",m',:r] => t string? t => t -- literal flag types are OK unknownTypeError t t f is ["LISTOF",:l] => z := [T.expr for x in l while ([.,.,e] := T := compColon([":",x,t],m,e))] [['%seq,:z],t,e] e:= f is [op,:argl] => --for MPOLY--replace parameters by formal arguments: RDJ 3/83 --FIXME: why? -- gdr 2011-04-30 newTarget := applySubst(pairList([(x is [":",a,m] => a; x) for x in argl], $FormalMapVariableList),t) signature := ["Mapping",newTarget,: [(x is [":",a,m] => m; getmode(x,e) or systemErrorHere ['"compColon",x]) 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 := giveVariableSomeValue(f,t,e) val := $insideCapsuleFunctionIfTrue => ['%LET,f,'%undefined] "/throwAway" [val,getmode(f,e),e] unknownTypeError name == stackAndThrow('"%1pb is not a known type",[name]) compPretend: (%Form,%Mode,%Env) -> %Maybe %Triple compPretend(["pretend",x,t],m,e) == e:= addDomain(currentDB e,t,e) T:= comp(x,t,e) or comp(x,$EmptyMode,e) or return nil t' := T.mode -- save this, in case we need to make suggestions T:= [T.expr,t,T.env] T':= coerce(T,m) => -- If the `pretend' wasn't necessary, we should advise user to use -- less crude way of selecting expressions of thr `right type'. if t' = t then stackWarning('"pretend %1p -- should replace by @",[t]) T' nil compColonInside(db,x,m,e,m') == e:= addDomain(db,m',e) T:= comp(x,$EmptyMode,e) or return nil if (m'':=T.mode)=m' then warningMessage:= [":",m'," -- should replace by @"] T:= [T.expr,m',T.env] T':= coerce(T,m) => if m'' = m' then stackWarning('": %1p -- should replace by @",[m']) else stackWarning('" : %1p -- replace by pretend", [m']) T' compIs: (%Form,%Mode,%Env) -> %Maybe %Triple compIs(["is",a,b],m,e) == [aval,am,e] := comp(a,$EmptyMode,e) or stackAndThrow('"Cannot determine the type of the expression %1b",[a]) not isCategoryForm(am,e) => stackAndThrow('"Expression %1b does not designate a domain",[a]) [bval,bm,e] := comp(b,$EmptyMode,e) or return nil T:= [["domainEqual",aval,bval],$Boolean,e] coerce(T,m) --% Functions for coercion by the compiler -- The function coerce is used by the old compiler for coercions. -- The function coerceInteractive is used by the interpreter. -- One should always call the correct function, since the represent- -- ation of basic objects may not be the same. tryCourtesyCoercion: (%Triple, %Mode) -> %Maybe %Triple tryCourtesyCoercion(T,m) == $InteractiveMode => keyedSystemError("S2GE0016",['"coerce", '"function coerce called from the interpreter."]) db := currentDB T.env if $useRepresentationHack then T.mode := MSUBST("$",$Rep,second T) T' := coerceEasy(db,T,m) => T' T' := coerceSubset(db,T,m) => T' T' := coerceHard(db,T,m) => T' nil coerce(T,m) == T' := tryCourtesyCoercion(T,m) => T' isSomeDomainVariable m => nil stackMessage('"Cannot coerce %1b of mode %2pb to mode %3pb", [T.expr,T.mode,m]) coerceEasy: (%Maybe %Database,%Triple,%Mode) -> %Maybe %Triple coerceEasy(db,T,m) == m=$EmptyMode => T m=$NoValueMode or m=$Void => [T.expr,m,T.env] T.mode =m => T T.mode =$Exit => [['%seq,T.expr,["userError", '"Did not really exit."]],m,T.env] T.mode=$EmptyMode or modeEqualSubst(T.mode,m,T.env) => [T.expr,m,T.env] -- It is OK to expand current domain in target mode. db ~= nil and substitute(dbConstructorForm db,'$,T.mode) = m => [T.expr,m,T.env] nil ++ Return true if the VM constant form `val' is known to satisfy ++ the predicate `pred'. Note that this is a fairly conservatism ++ approximation in the sense that the retunred value maye be false ++ for some other reasons, such as the predicate not being closed ++ with respect to the parameter `#1'. satisfies(val,pred) == pred=false or pred=true => pred vars := findVMFreeVars pred vars ~= nil and vars isnt ["#1"] => false eval ['%bind,[["#1",val]],pred] ++ If the domain designated by the domain forms `m' and `m'' have ++ a common super domain, return least such super domaon (ordered ++ in terms of sub-domain relationship). Otherwise, return nil. commonSuperType(m,m') == lineage := [m'] while (t := superType m') ~= nil repeat lineage := [t,:lineage] m' := t while m ~= nil repeat listMember?(m,lineage) => return m m := superType m ++ Coerce value `x' of mode `m' to mode `m'', if m is a subset of ++ of m'. A special case is made for cross-subdomain conversion ++ for integral literals. coerceSubset: (%Maybe %Database,%Triple,%Mode) -> %Maybe %Triple coerceSubset(db,[x,m,e],m') == isSubset(m,m',e) => [x,m',e] integer? x and (m'' := commonSuperType(m,m')) => -- obviously this is temporary satisfies(x,isSubDomain(m',m'')) => [x,m',e] nil nil coerceHard: (%Maybe %Database,%Triple,%Mode) -> %Maybe %Triple coerceHard(db,T,m) == $e: local:= T.env m':= T.mode string? m' and modeEqual(m,$String) => [T.expr,m,$e] modeEqual(m',m) or ident? m' and (get(m',"value",$e) is [m'',:.] or getXmode(m',$e) is ["Mapping",m'']) and modeEqual(m'',m) or ident? m and (get(m,"value",$e) is [m'',:.] or getXmode(m,$e) is ["Mapping",m'']) and modeEqual(m'',m') => [T.expr,m,T.env] string? T.expr and T.expr=m => [T.expr,m,$e] isCategoryForm(m,$e) => $bootStrapMode => [T.expr,m,$e] extendsCategoryForm(db,T.expr,T.mode,m) => [T.expr,m,$e] coerceExtraHard(db,T,m) coerceExtraHard(db,T,m) coerceExtraHard: (%Maybe %Database,%Triple,%Mode) -> %Maybe %Triple coerceExtraHard(db,T is [x,m',e],m) == -- Allow implicit injection into Union, if that is -- clear from the context isUnionMode(m,e) is ['Union,:l] and listMember?(m',l) => autoCoerceByModemap(db,T,m) -- For values from domains satisfying Union-like properties, apply -- implicit retraction if clear from context. (t := hasType(x,e)) and unionLike?(m',e) is ['UnionCategory,:l] and listMember?(t,l) => T' := autoCoerceByModemap(db,T,t) => coerce(T',m) nil -- Give it one last chance. -- FIXME: really, we shouldn't. Codes relying on this are -- FIXME: inherently difficult to comprehend and likely broken. T' := autoCoerceByModemap(db,T,m) => T' m' is ['Record,:.] and m = $OutputForm => [['coerceRe2E,x,['ELT,copyTree m',0]],m,e] -- Domain instantiations are first class objects m = $Domain => m' = $Category => nil isCategoryForm(m',e) => [x,m',e] nil nil coerceable(m,m',e) == m=m' => m tryCourtesyCoercion(["$fromCoerceable$",m,e],m') => m' nil coerceExit: (%Triple,%Mode) -> %Maybe %Triple coerceExit([x,m,e],m') == m' := resolve(m,m') x' := replaceExitEtc(x,catchTag := MKQ gensym(),"TAGGEDexit",$exitMode) coerce([['%scope,catchTag,x'],m,e],m') compAtSign: (%Form,%Mode,%Env) -> %Maybe %Triple compAtSign(["@",x,m'],m,e) == e:= addDomain(currentDB e,m',e) T:= comp(x,m',e) or return nil coerce(T,m) compCoerce: (%Form,%Mode,%Env) -> %Maybe %Triple compCoerce1: (%Database,%Form,%Mode,%Env) -> %Maybe %Triple coerceByModemap: (%Database,%Maybe %Triple,%Mode) -> %Maybe %Triple autoCoerceByModemap: (%Database,%Maybe %Triple,%Mode) -> %Maybe %Triple compCoerce(["::",x,m'],m,e) == db := currentDB e e:= addDomain(db,m',e) T:= compCoerce1(db,x,m',e) => coerce(T,m) ident? m' and getXmode(m',e) is ["Mapping",["UnionCategory",:l]] => T:= (or/[compCoerce1(db,x,m1,e) for m1 in l]) or return nil coerce([T.expr,m',T.env],m) ++ Subroutine of compCoerce1. If `T' is a triple whose mode is ++ a super-domain of `sub', then return code that performs the ++ checked courtesy coercion to `sub'. coerceSuperset: (%Triple, %Mode) -> %Maybe %Triple coerceSuperset(T,sub) == sub is "$" => T' := coerceSuperset(T,$functorForm) or return nil T'.mode := "$" T' pred := isSubset(sub,T.mode,T.env) => [["%retract",T.expr,sub,pred],sub,T.env] nil compCoerce1(db,x,m',e) == T:= comp(x,m',e) or comp(x,$EmptyMode,e) or return nil m1:= string? T.mode => $String T.mode m':=resolve(m1,m') T:=[T.expr,m1,T.env] T':= coerce(T,m') => T' T':= coerceByModemap(db,T,m') => T' T' := coerceSuperset(T,m') => T' nil coerceByModemap(db,[x,m,e],m') == u := [mm for mm in getModemapList("coerce",1,e) | mm.mmSignature 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:= (or/[mm for (mm:=[.,[cond,.]]) in u | cond=true]) or return nil mm:=first u -- patch for non-trival conditons fn := genDeltaEntry(db,'coerce,mm,e) [['%call,fn,x],m',e] autoCoerceByModemap(db,[x,source,e],target) == u := [mm for mm in getModemapList("autoCoerce",1,e) | mm.mmSignature is [t,s] and modeEqual(t,target) and modeEqual(s,source)] or return nil fn := (or/[mm for mm in u | mm.mmCondition=true]) or return nil source is ["Union",:l] and listMember?(target,l) => (y:= get(x,"condition",e)) and (or/[u is ["case",., =target] for u in y]) => [['%call,genDeltaEntry(db,"autoCoerce",fn,e),x],target,e] x="$fromCoerceable$" => nil stackMessage('"cannot coerce %1b of mode %2pb to %3pb without a case statement", [x,source,target]) [['%call,genDeltaEntry(db,"autoCoerce",fn,e),x],target,e] ++ Compile a comma separated expression list. These typically are ++ tuple objects, or argument list in a call to a homogeneous ++ vararg operations. compComma: (%Form,%Mode,%Env) -> %Maybe %Triple compComma(form,m,e) == form isnt ["%Comma",:argl] => systemErrorHere ["compComma",form] Tl := [comp(a,$EmptyMode,e) or return "failed" for a in argl] Tl = "failed" => nil -- ??? Ideally, we would like to compile to a Cross type, then -- convert to the target type. However, the current compiler and -- runtime data structures are not regular enough in their interfaces; -- so we make a special rule when compiling with a Tuple as target, -- we do the convertion here (instead of calling convert). Semantically, -- there should be no difference, but it makes the compiler code -- less regular, with duplicated effort. m is ["Tuple",t] => Tl' := [coerce(T,t) or return "failed" for T in Tl] Tl' = "failed" => nil [["asTupleNew0", ["getVMType",t], [T.expr for T in Tl']], m, e] T := [['%call,mkRecordFun #argl,:[T.expr for T in Tl]], ["Cross",:[T.mode for T in Tl]], e] coerce(T,m) --% Very old resolve -- should only be used in the old (preWATT) compiler resolve(din,dout) == din=$NoValueMode or dout=$NoValueMode => $NoValueMode dout=$EmptyMode => din din~=dout and (string? din or string? dout) => modeEqual(dout,$String) => dout modeEqual(din,$String) => nil mkUnion(din,dout) dout modeEqual(x,y) == -- this is the late modeEqual -- orders Unions x isnt [.,:.] or y isnt [.,:.] => x=y #x ~= #y => nil x is ['Union,:xl] and y is ['Union,:yl] => for x1 in xl repeat for y1 in yl repeat modeEqual(x1,y1) => xl := remove(xl,x1) yl := remove(yl,y1) return nil xl or yl => nil true (and/[modeEqual(u,v) for u in x for v in y]) modeEqualSubst(m1,m,e) == modeEqual(m1, m) => true m1 isnt [.,:.] => get(m1,"value",e) is [m',:.] and modeEqual(m',m) m1 is [op,:l1] and m is [=op,:l2] and # l1 = # l2 => -- Above length test inserted JHD 4:47 on 15/8/86 -- Otherwise Records can get fouled up - consider expressIdealElt -- in the DEFAULTS package and/[modeEqualSubst(xm1,xm2,e) for xm1 in l1 for xm2 in l2] nil --% Categories compBuiltinDomain(form is [functorName,:argl],m,e) == fn := property(functorName,"makeFunctionList") or return nil diagnoseUnknownType(form,e) [funList,e]:= apply(fn,[form,form,e]) exports := [cat for x in parentsOfBuiltinInstance form] where cat() == x.rest is true => x.first ['IF,x.rest,['ATTRIBUTE,x.first],'%noBranch] catForm:= ["Join",:exports,["CATEGORY","domain",: [["SIGNATURE",op,sig] for [op,sig,.] in funList | op~="="]]] --RDJ: for coercion purposes, it necessary to know it's a Set; I'm not --sure if it uses any of the other signatures(see extendsCategoryForm) [form,catForm,e] --% APPLY MODEMAPS ++ `op' has been selected as a viable candidate exported operation, ++ for argument triple list `argTl', modemap `mm'. ++ Return the most refined implementation that makes the call successful. compViableModemap(db,op,argTl,mm,e) == [[dc,.,:margl],fnsel] := mm -- 1. Give up if the call is hopeless. argTl := [coerce(x,m) or return "failed" for x in argTl for m in margl] argTl = "failed" => nil -- 2. obtain domain-specific function, if possible f := compMapCond(dc,fnsel,e) or return nil -- 3. Mark `f' as used. -- We can no longer trust what the modemap says for a reference into -- an exterior domain (it is calculating the displacement based on view -- information which is no longer valid; thus ignore this index and -- store the signature instead. f is [op1,.,.] and op1 in '(ELT CONST Subsumed) => [genDeltaEntry(db,op,mm,e),argTl] [f,argTl] compApplyModemap(db,form,modemap,$e) == [op,:argl] := form --form to be compiled [[mc,mr,:margl],fnsel] := modemap --modemap we are testing -- $e is the current environment -- 0. fail immediately if #argl=#margl if #argl~=#margl then return nil -- 1. use modemap to evaluate arguments, returning failed if -- not possible lt:= [[.,.,$e]:= comp(y,m,$e) or return "failed" for y in argl for m in margl] lt="failed" => return nil -- 2. Select viable modemap implementation. compViableModemap(db,op,lt,modemap,$e) compMapCond': (%Form,%Mode,%Env) -> %Boolean compMapCond'(cexpr,dc,env) == cexpr=true => true cexpr is ["AND",:l] => and/[compMapCond'(u,dc,env) for u in l] cexpr is ["OR",:l] => or/[compMapCond'(u,dc,env) for u in l] cexpr is ["not",u] => not compMapCond'(u,dc,env) cexpr is ["has",name,cat] => (knownInfo(cexpr,env) => true; false) --for the time being we'll stop here - shouldn't happen so far --$disregardConditionIfTrue => true --stackSemanticError(("not known that",'"%b",name, -- '"%d","has",'"%b",cat,'"%d"),nil) --now it must be an attribute listMember?(["ATTRIBUTE",dc,cexpr],get("$Information","special",$e)) => true --for the time being we'll stop here - shouldn't happen so far stackMessage('"not known that %1pb has %2pb",[dc,cexpr]) false compMapCond: (%Mode,%List %Code,%Env) -> %Code compMapCond(dc,[cexpr,fnexpr],env) == compMapCond'(cexpr,dc,env) => fnexpr stackMessage('"not known that %1pb has %2pb",[dc,cexpr]) --% compResolveCall(db,op,argTs,m,$e) == outcomes := [t for mm in getModemapList(op,#argTs,$e) | t := tryMM] where tryMM() == not coerceable(mm.mmTarget,m,$e) =>nil compViableModemap(db,op,argTs,mm,$e) isnt [f,Ts] => nil coerce([['%call,f,:[T.expr for T in Ts]],mm.mmTarget,$e],m) #outcomes ~= 1 => nil first outcomes --% %Match ++ Subroutine of compAlternativeGuardItem, responsible of compiling ++ individual alternative of the form ++ x@t => stmt ++ in environment `e'. Here `sn' is the temporary holding the ++ value of the scrutinee, and `sm' is its type. ++ Return a quadruple [init,guard,init',envTrue,envFalse], where ++ `init' is code that intializes the retract intermediate entity. ++ `guard' is code that gates the body of the alternative ++ `init'' is list of possible initializations local to the branch ++ `envTrue' is an environment after the guard evaluates to true ++ `envFalse' is an environment after the guard evaluates to false. compRetractGuard(x,t,sn,sm,e) == -- The retract pattern is compiled by transforming -- x@t => stmt -- into the following program fragment -- sn case t => (x := ; stmt) -- where is code that computes appropriate initialization -- for `x' under the condition that either `sn' may be implicitly -- convertible to t (using only courtesy coercions) or that -- `sn' is retractable to t. -- -- 1. Evaluate the retract condition, and retract. initCode := nil caseCode := nil restrictCode := nil envFalse := e -- 1.1. Try courtesy coercions first. That way we can use -- optimized versions where available. That also -- makes the scheme work for untagged unions. if testT := compPredicate(["case",sn,t],e) then [caseCode,.,e,envFalse] := testT [restrictCode,.,e] := tryCourtesyCoercion([sn,sm,e],t) or comp(["retract",sn],t,e) or return stackAndThrow('"Could not retract from %1bp to %2bp",[sm,t]) -- 1.2. Otherwise try retractIfCan, for those `% has RetractableTo t'. else if retractT := comp(["retractIfCan",sn],["Union",t,'"failed"],e) then [retractCode,.,e] := retractT -- Assign this value to a temporary. That temporary needs to -- have a lifetime that covers both the condition and the body -- of the alternative z := gensym() initCode := [[z,retractCode]] caseCode := ['%ieq,['%head,z],0] restrictCode := ["%tail",z] -- 1.3. Everything else failed; nice try. else return stackAndThrow('"%1bp is not retractable to %2bp",[sm,t]) -- 2. Now declare `x'. [.,.,e] := compMakeDeclaration(x,t,e) or return nil e := giveVariableSomeValue(x,t,e) -- 3. Assemble result. [initCode,caseCode,[[x,restrictCode]],e,envFalse] ++ Subroutine of compRecoverGuard. The parameters and the result ++ have the same meaning as in compRecoverGuard. ++ Note: a value of type Any is a dotted pair (dom . val) where ++ `dom' is a devaluated form of the domain of `val'. compRecoverDomain(x,t,sn,e) == -- 1. We recover domains only. not isDomainForm(t,e) => stackAndThrow('"Form %1b does not designate a domain",[t]) caseCode := ["%equal",["devaluate",t],["%head",sn]] -- 2. Declare `x'. originalEnv := e [.,.,e] := compMakeDeclaration(x,t,e) or return nil e := giveVariableSomeValue(x,t,e) -- 3. Assemble the result [nil,caseCode,[[x,['%tail,sn]]],e,originalEnv] ++ Subroutine of compAlternativeGuardItem, responsible for ++ compiling a guad item of the form ++ x: t ++ in environment `e', where `sn' is the temporary holding ++ the value of the scrutinee, and `sm' is its mode. ++ Return a quadruple [guard,init,envTrue,envFalse], where ++ `guard' is code that gates the body of the alternative ++ `init' is list of possible initializations ++ `envTrue' is an environment after the guard evaluates to true ++ `envFalse' is an environment after the guard environment to false. compRecoverGuard(x,t,sn,sm,e) == -- The retract pattern is compiled by transforming -- x: t => stmt -- into the following program fragment -- domainOf y is t => (x := ; stmt) -- where is code that compute appropriate initialization -- for `x' under the condition that sm is Any, and the -- underlying type is t. -- -- 0. Type recovery is for expressions of type 'Any'. (sm is "$" => get('$,'%dc,e); sm) ~= $Any => stackAndThrow('"Scrutinee must be of type %1pb in type recovery alternative of case pattern",[$Any]) -- 1. Do some preprocessing if this is existential type recovery. t is ["%Exist",var,t'] => var isnt [":",var',cat'] => stackAndThrow('"Sorry: Only univariate type schemes are supported in this context",nil) -- We have a univariate type scheme. At the moment we insist -- that the body of the type scheme be identical to the type -- variable. This restriction should be lifted in future work. not ident? t' or t' ~= var' => stackAndThrow('"Sorry: type %1b too complex",[t']) not isCategoryForm(cat',e) => stackAndThrow('"Expression %1b does not designate a category",[cat']) getmode(var',e) => stackAndThrow('"You cannot redeclare identifier %1b",[var']) -- Extract the type component. varDef := [":=",[":",var',$Type], [["elt",["Foreign","Builtin"],"evalDomain"], [["elt",["Foreign","Builtin"],"%head"], sn]]] [def,.,e] := compOrCroak(varDef,$EmptyMode,e) [hasTest,.,e] := compOrCroak(["has",var',cat'],$EmptyMode,e) [defs',guard,inits,e,envFalse] := compRecoverDomain(x,var',sn,e) [[def.args,:defs'],hasTest,inits,e,envFalse] -- 2. Hand it to whoever is in charge. compRecoverDomain(x,t,sn,e) warnUnreachableAlternative pat == stackWarning('"Alternative with pattern %1b will not be reached",[pat]) warnTooManyOtherwise() == stackWarning('"One too many `otherwise' alternative",nil) ++ Subroutine of compMatch. Perform semantics analysis of the scrutinee ++ in a case-pattern. Return a triple if everything is OK, otherwise nil. compMatchScrutinee(form,e) == form is ["%Comma",:exprs] => Xs := Ms := nil for expr in exprs repeat [x,m,e] := compOrCroak(expr,$EmptyMode,e) Xs := [x,:Xs] Ms := [m,:Ms] [["%Comma",:reverse! Xs], ["%Cross",:reverse! Ms],e] compOrCroak(form,$EmptyMode,e) ++ Subroutine of compMatch. We just finished semantics analysis of ++ the scrutinee. Define temporary to hold the resulting value in store. ++ Returns declared temporaries if everything is fine, otherwise nil. defineMatchScrutinee(m,e) == m is ["%Cross",:.] => [[t for m' in rest m | [t,e] := defTemp(m',e)], e] defTemp(m,e) where defTemp(m,e) == t := gensym() [.,.,e] := compMakeDeclaration(t,m,e) [t,giveVariableSomeValue(t,m,e)] ++ Generate code for guard in a simple pattern where ++ `sn' is the name of the temporary holding the scrutinee value, ++ `sn' is its mode, ++ `pat' is the simple pattern being compiled. ++ On success, return a quintuple of the form [inits,guard,inits',eT,eF] where ++ inits is initialization to perform before the guard test. This ++ iniialization extends to the corresponding branch of the pattern clause. ++ guard is the code for guard alternative ++ inits' is initialization to perform after the pattrn test. ++ eT is the environment for successful guard ++ eF is the environment for unsuccessful guard compAlternativeGuardItem(sn,sm,pat,e) == pat is [op,x,t] and op in '(_: _@) => not ident? x => stackAndThrow('"pattern %1b must declare a variable",[pat]) if $catchAllCount > 0 then warnUnreachableAlternative pat op is ":" => compRecoverGuard(x,t,sn,sm,e) compRetractGuard(x,t,sn,sm,e) or stackAndThrow('"cannot compile %1b",[pat]) stackAndThrow('"invalid pattern %1b",[pat]) ++ Subroutine of compMatchAlternative. The parameters ++ have the same meaning. ++ Return value has same structure and semantics as compAlternativeGuardItem. compAlternativeGuard(sn,sm,pat,e) == pat = "otherwise" => if $catchAllCount > 0 then warnTooManyOtherwise() $catchAllCount := $catchAllCount + 1 [nil,'%otherwise,nil,e,e] cons? sn => pat isnt ["%Comma",:.] => stackAndThrow('"Pattern must be a tuple for a tuple scrutinee",nil) #sn ~= #rest pat => stackAndThrow('"Tuple pattern must match tuple scrutinee in length",nil) inits := nil guards := nil inits' := nil ok := true originalEnv := e for n in sn for m in rest sm for p in rest pat while ok repeat [init,guard,init',e,.] := compAlternativeGuardItem(n,m,p,e) => inits := [init,:inits] guards := [guard,:guards] inits' := [init',:inits'] ok := false ok => [append/reverse! inits, ['%and,:reverse! guards], append/reverse! inits', e,originalEnv] nil compAlternativeGuardItem(sn,sm,pat,e) ++ Subroutine of compMatch. Analyze an alternative in a case-pattern. ++ `sn' is a name or a list of name for temporaries holding the ++ value of the scrutinee. ++ `sm' is the mode of list of modes for the scrutinee. ++ `pat' is the pattern of the alternative we are compiling ++ `stmt' is the body of the alternative we are compiling ++ `m' is the desired mode for the return value. ++ `e' is the environment in effect at the start of the environment. ++ Return a doublet with the first part being a 3-uple with components ++ as follows: ++ 0. initialization code (if any) to run before performing the test ++ 1. code for the guard ++ 2. code to execute when the guard test succeeds. ++ and the second part being an environment to consider when ++ the guard test fails. compMatchAlternative(sn,sm,pat,stmt,m,e) == [inits,guard,inits',e,eF] := compAlternativeGuard(sn,sm,pat,e) or return nil stmtT := compOrCroak(stmt,m,e) body := inits' = nil => stmtT.expr ['%bind,inits',stmtT.expr] [[inits,guard,body],eF] ++ Analyze and generate code for `case is'-pattern where the ++ scrutinee is `subject' and the alternatives are `altBlock'. -- FIXME: Make sure nobody asks for creating matter out of void. compMatch(["%Match",subject,altBlock],m,env) == altBlock isnt ["%Block",:alts] => stackAndThrow('"case pattern must specify block of alternatives",nil) savedEnv := env -- 1. subjectTmp := subject [se,sm,env] := compMatchScrutinee(subject,env) [sn,env] := defineMatchScrutinee(sm,env) -- 2. compile alternatives. $catchAllCount: local := 0 altsCode := nil for alt in alts repeat alt is ["=>",pat,stmt] => [block,env] := compMatchAlternative(sn,sm,pat,stmt,m,env) or return stackAndThrow('"cannot compile pattern %1b",[pat]) altsCode := [block,:altsCode] return stackAndThrow('"invalid alternative %1b",[alt]) body := '%noBranch for [inits,guard,stmt] in altsCode repeat body := ['IF,guard,stmt,body] inits = nil => nil body := ['%bind,inits,body] $catchAllCount = 0 => stackAndThrow('"missing %b otherwise %d alternative in case pattern",nil) inits := ident? sn => [[sn,se]] [[n,e] for n in sn for e in rest se] [['%bind,inits,body],m,savedEnv] ++ Compile the form scheme `x'. compScheme(x,m,e) == stackSemanticError(["Sorry: Expression schemes are not supported in this context"],nil) --% --% Inline Requests --% ++ We are processing a capsule and `t is nominated in an inline ++ directive. This means that the compiler can `bypass' the usual ++ indirect call through domain interface and attempt to resolve ++ modemap references. ++ Concretely, this means that `t is evaluated. processInlineRequest(t,e) == T := compOrCroak(t,$EmptyMode,e) not isCategoryForm(T.mode,e) => stackAndThrow('"%1b does not designate a domain",[t]) T.expr isnt [.,:.] => stackWarning('"inline request for type variable %1bp is meaningless",[t]) registerInlinableDomain T.expr --% --% ITERATORS --% ++ Generate code for collecting values generated by the expression `body' ++ controlled by iterators in `iters' into a list. finishListCollect(iters,body) == val := gensym() -- result of the list comprehension -- Transform the body to build the list as we go. body := ['%store,val,['%pair,body,val]] -- Don't forget we built the result in reverse order. ['%repeat,:iters,['%init,val,'%nil],body,['%lreverse!,val]] ++ Generate code for collecting values generated by the expression `body' ++ controlled by iterators in `iters' into a vector with element ++ type indicated by `eltType'. finishVectorCollect(eltType,iters,body) == fromList := false -- are we drawing from a list? vecSize := nil -- size of vector index := nil -- loop/vector index. for iter in iters while not fromList repeat [op,:.] := iter op in '(_| SUCHTHAT WHILE UNTIL) => fromList := true op in '(IN ON) => vecSize := [['%llength,third iter],:vecSize] op in '(STEP ISTEP) => -- pick a loop variable that we can use as the loop index. [.,var,lo,inc,:etc] := iter if lo = 0 and inc = 1 then index := var is [.,:var'] => var' var if [hi] := etc then sz := inc = 1 => lo = 1 => hi lo = 0 => ['%iinc,hi] ['%iinc,['%isub,hi,lo]] lo = 1 => ['%idiv,hi,inc] lo = 0 => ['%idiv,['%iinc,hi],inc] ['%idiv,['%isub,['%iinc,hi], lo],inc] vecSize := [sz, :vecSize] systemErrorHere ['finishVectorCollect, iter] -- if we draw from a list, then just build a list and convert to vector. fromList => ['homogeneousListToVector,['getVMType,eltType], finishListCollect(iters,body)] vecSize = nil => systemErrorHere ['finishVectorCollect,eltType,iters,body] -- get the actual size of the vector. vecSize := vecSize is [hi] => hi ['%imin,:reverse! vecSize] -- if no suitable loop index was found, introduce one. if index = nil then index := gensym() iters := [:iters,['STEP,index,0,1]] vec := gensym() ['%bind,[[vec,['makeSimpleArray,['getVMType,eltType],vecSize]]], ['%repeat,:iters,['setSimpleArrayEntry,vec,index,body],vec]] compReduce(form,m,e) == compReduce1(form,m,e,$formalArgList) compReduce1(form is ["REDUCE",op,.,collectForm],m,e,$formalArgList) == [collectOp,:itl,body] := collectForm if string? op then op := makeSymbol op collectOp ~= "COLLECT" => systemError ['"illegal reduction form:",form] $until: local := nil oldEnv := e itl := [([.,e]:= compIterator(x,e) or return "failed").0 for x in itl] itl="failed" => return nil b := gensym() -- holds value of the body [bval,bmode,e] := comp([":=",b,body],$EmptyMode,e) or return nil accu := gensym() -- holds value of the accumulator [move,.,e] := comp([":=",accu,b],$EmptyMode,e) or return nil move.op := '%store -- in reality, we are not defining a new variable [update,mode,e] := comp([":=",accu,[op,accu,b]],m,e) or return nil update.op := '%store -- just update the accumulation variable. nval := id := getIdentity(op,e) => u.expr where u() == comp(id,mode,e) or return nil ["IdentityError",MKQ op] if $until then [untilCode,.,e]:= comp($until,$Boolean,e) or return nil itl := substitute(["UNTIL",untilCode],'$until,itl) firstTime := gensym() finalCode := ['%repeat, ['%init,accu,'%nil],['%init,firstTime,'%true],:itl, ['%bind,[[b,third bval]], ['%seq, ['%when,[firstTime,move],['%otherwise,update]], ['%store,firstTime,'%false]]], ['%when,[firstTime,nval],['%otherwise,accu]]] T := coerce([finalCode,mode,e],m) or return nil [T.expr,T.mode,oldEnv] ++ returns the identity element of the `reduction' operation `x' ++ over a list -- a monoid homomorphism. getIdentity(x,e) == property(x,"THETA") is [y] => y = 0 => $Zero y = 1 => $One -- The empty list should be indicated by name, not by its -- object representation. y => y "nil" nil numberize x == x=$Zero => 0 x=$One => 1 x isnt [.,:.] => x [numberize first x,:numberize rest x] ++ If there is a local reference to mode `m', return it. localReferenceIfThere(m,e) == m is "$" => m idx := assocIndex(currentDB e,m) => ['%tref,'$,idx] quote m compRepeatOrCollect(form,m,e) == fn(form,[m,:$exitModeStack],[#$exitModeStack,:$leaveLevelStack],$formalArgList ,e) where fn(form,$exitModeStack,$leaveLevelStack,$formalArgList,e) == $until: local := nil $loopKind: local := nil $iterateCount: local := 0 $loopBodyTag: local := nil $breakCount: local := 0 oldEnv := e aggr := nil [$loopKind,:itl,body]:= form itl':= [([x',e]:= compIterator(x,e) or return "failed"; x') for x in itl] itl'="failed" => nil targetMode:= first $exitModeStack bodyMode:= $loopKind="COLLECT" => targetMode = $EmptyMode => (aggr:=["List",$EmptyMode]; $EmptyMode) [aggr,u] := modeIsAggregateOf('List,targetMode,e) => u [aggr,u] := modeIsAggregateOf('PrimitiveArray,targetMode,e) => $loopKind := "%CollectV" u [aggr,u] := modeIsAggregateOf('Vector,targetMode,e) => $loopKind := "%CollectV" u stackMessage('"Invalid collect bodytype") return nil -- If we're doing a collect, and the type isn't conformable -- then we've boobed. JHD 26.July.1990 -- ??? we hve a plain old loop; the return type should be Void $NoValueMode [body',m',e'] := compOrCroak(body,bodyMode,e) or return nil -- Massage the loop body if we have a structured jump. if $iterateCount > 0 then body' := ['%scope,$loopBodyTag,body'] if $until then [untilCode,.,e']:= comp($until,$Boolean,e') itl':= substitute(["UNTIL",untilCode],'$until,itl') form':= $loopKind = "%CollectV" => finishVectorCollect(localReferenceIfThere(m',e'),itl',body') -- We are phasing out use of LISP macros COLLECT and REPEAT. $loopKind = "COLLECT" => finishListCollect(itl',body') ['%repeat,:itl',body','%nil] m'' := aggr is [c,.] and c in '(List PrimitiveArray Vector) => [c,m'] m' T := coerceExit([form',m'',e'],targetMode) or return nil -- iterator variables and other variables declared in -- in a loop are local to the loop. [T.expr,T.mode,oldEnv] --constructByModemap([x,source,e],target) == -- u:= -- [cexpr -- for (modemap:= [map,cexpr]) in getModemapList("construct",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 -- [['%call,fn,x],target,e] ++ Return the least Integer subdomain that can represent values ++ of both Integer subdomains denoted by the forms `x' and `y. joinIntegerModes(x,y,e) == isSubset(x,y,e) => y isSubset(y,x,e) => x $Integer ++ Given a for-loop iterator `x', return ++ a. its storage class ++ b. its name ++ c. an environment containing its declaration in case a type ++ was specified. classifyIteratorVariable(x,e) == check(main(x,e),x) where main(x,e) == x is [":",var,t] => not ident? var => nil checkVariableName var t is 'local => ['%local,var,e] t is 'free => ['%free,var,e] [.,.,e] := compMakeDeclaration(var,t,e) => ['%local,var,e] nil ident? x => checkVariableName x ['%local,x,e] nil check(x,y) == x ~= nil => x stackAndThrow('"invalid loop variable %1bp",[y]) ++ Subroutine of compStepIterator. ++ We are elaborating the STEP form of a for-iterator, where all ++ bounds and increment are expected to be integer-valued expressions. ++ Compile the expression `x' in the context `e', under those ++ circumstances. When successful we return either the declared ++ mode of the expression, or infer the tightest mode that can ++ represents the resulting value. Note that we do not attempt any ++ SmallInteger optimization at this stage. Such a transformation can ++ be done only when we have all information about the bound. compIntegerValue(x,e) == -- 1. Preliminary transformation. -- The literal values 0 and 1 get transformed by the parser -- into calls Zero() and One(), respectively. Undo that transformation -- locally. Note that this local transformation is OK, because -- it presents semantics. x := x = $Zero => 0 x = $One => 1 x -- 2. Attempt to infer the type of the expression if at all possible. -- The inferred mode is valid only if it is an integer (sub)domain. T := comp(x,$EmptyMode,e) isSubset(T.mode,$Integer,e) => T -- 3. Otherwise, compile in checking mode. comp(x,$PositiveInteger,e) or comp(x,$NonNegativeInteger,e) or compOrCroak(x,$Integer,e) ++ Attempt to compile a `for' iterator of the form ++ for index in start..final by inc ++ where the bound `final' may be missing. compStepIterator(index,start,final,inc,e) == [sc,index,e] := classifyIteratorVariable(index,e) if sc = '%local then $formalArgList := [index,:$formalArgList] [start,startMode,e] := compIntegerValue(start,e) or return stackMessage('"start value of index: %1b must be an integer",[start]) [inc,incMode,e] := compIntegerValue(inc,e) or return stackMessage('"index increment: %1b must be an integer",[inc]) if final ~= nil then [final,finalMode,e] := compIntegerValue(first final,e) or return stackMessage('"final value of index: %1b must be an integer",[final]) final := [final] indexMode := final = nil or isSubset(incMode,$NonNegativeInteger,e) => startMode joinIntegerModes(startMode,finalMode,e) if get(index,"mode",e) = nil then [.,.,e] := compMakeDeclaration(index,indexMode,e) or return nil e := giveVariableSomeValue(index,indexMode,e) [["STEP",[sc,:index],start,inc,:final],e] compINIterator(x,y,e) == [sc,x,e] := classifyIteratorVariable(x,e) --these two lines must be in this order, to get "for f in list f" --to give an error message if f is undefined [y',m,e]:= comp(y,$EmptyMode,e) or return nil if sc = '%local then $formalArgList := [x,:$formalArgList] [mOver,mUnder]:= modeIsAggregateOf("List",m,e) or return stackMessage('"mode: %1pb must be a list of some mode",[m]) if null get(x,"mode",e) then [.,.,e]:= compMakeDeclaration(x,mUnder,e) or return nil e:= giveVariableSomeValue(x,mUnder,e) [y'',m'',e] := coerce([y',m,e], mOver) or return nil [["IN",[sc,:x],y''],e] compONIterator(x,y,e) == [sc,x,e] := classifyIteratorVariable(x,e) if sc = '%local then $formalArgList := [x,:$formalArgList] [y',m,e]:= comp(y,$EmptyMode,e) or return nil [mOver,mUnder]:= modeIsAggregateOf("List",m,e) or return stackMessage('"mode: %1pb must be a list of other modes",[m]) if null get(x,"mode",e) then [.,.,e]:= compMakeDeclaration(x,m,e) or return nil e:= giveVariableSomeValue(x,m,e) [y'',m'',e] := coerce([y',m,e], mOver) or return nil [["ON",[sc,:x],y''],e] compIterator(it,e) == -- ??? Allow for declared iterator variable. it is ["IN",x,y] => compINIterator(x,y,e) it is ["ON",x,y] => compONIterator(x,y,e) it is ["STEP",index,start,inc,:optFinal] => compStepIterator(index,start,optFinal,inc,e) it is ["WHILE",p] => [p',m,e] := compOrCroak(p,$Boolean,e) [["WHILE",p'],e] it is ["UNTIL",p] => ($until:= p; ['$until,e]) it is ["|",x] => u := compOrCroak(x,$Boolean,e) [["|",u.expr],u.env] nil --isAggregateMode(m,e) == -- m is [c,R] and c in '(Vector List) => R -- name:= -- m is [fn,:.] => fn -- m="$" => "Rep" -- m -- get(name,"value",e) is [c,R] and c in '(Vector List) => R modeIsAggregateOf(agg,m,e) == m is [ =agg,R] => [m,R] m is ["Union",:l] => mList:= [pair for m' in l | (pair:= modeIsAggregateOf(agg,m',e))] 1=#mList => first mList name:= m is [fn,:.] => fn RepIfRepHack m get(name,"value",e) is [[ =agg,R],:.] => [m,R] --% rep/per morphisms ++ Compile the form `per x' under the mode `m'. ++ The `per' operator is active only for new-style definition for ++ representation domain. compPer(["per",x],m,e) == $useRepresentationHack => nil inType := getRepresentation e or return nil T := comp(x,inType,e) or return nil if $subdomain then T := integer? T.expr and satisfies(T.expr,domainVMPredicate "$") => [T.expr,"$",e] coerceSuperset(T,"$") or return nil else T.mode := "$" coerce(T,m) ++ Compile the form `rep x' under the mode `m'. ++ Like `per', the `rep' operator is active only for new-style ++ definition for representation domain. compRep(["rep",x],m,e) == $useRepresentationHack => nil T := comp(x,"$",e) or return nil T.mode := getRepresentation e or return nil coerce(T,m) --% Lambda expressions compUnnamedMapping(parms,source,target,body,env) == savedEnv := env for p in parms for s in source repeat [.,.,env] := compMakeDeclaration(p,s,env) env := giveVariableSomeValue(p,get(p,'mode,env),env) T := comp(body,target,env) or return nil fun := ['%closure,['%function,['%lambda,[:parms,'$],T.expr]],'$] [fun,["Mapping",T.mode,:source],savedEnv] gatherParameterList vars == main(vars,nil,nil) where main(vars,parms,source) == vars = nil => [reverse! parms,reverse! source] vars isnt [.,:.] or vars is [":",:.] => [[x] for x in check vars] [v,s] := check first vars main(rest vars,[v,:parms],[s,:source]) check var == var isnt [.,:.] => not ident? var => stackAndThrow('"invalid parameter %1b in lambda expression",[var]) [checkVariableName var,nil] var is [":",p,t] => not ident? p => stackAndThrow('"invalid parameter %1b in lambda expression",[p]) [checkVariableName p,t] stackAndThrow('"invalid parameter for mapping",nil) compLambda(x is ["+->",vars,body],m,e) == -- 1. Gather parameters and their types. if vars is ["%Comma",:vars'] then vars := vars' [parms,source] := gatherParameterList vars -- 2. Compile the form T := -- 2.1. No parameter is declared and/[s = nil for s in source] => -- Guess from context m is ["Mapping",dst,:src] => #src ~= #parms => stackAndThrow('"inappropriate function type for unnamed mapping",nil) compUnnamedMapping(parms,src,dst,body,e) or return nil -- Otherwise, assumes this is just purely syntactic code block. [quote ["+->",parms,body],$AnonymousFunction,e] -- 2.2. If all parameters are declared, then compile as a mapping. and/[s ~= nil for s in source] => compUnnamedMapping(parms,source,$EmptyMode,body,e) or return nil -- 2.3. Well, give up for now. stackAndThrow('"parameters in a lambda expression must be all declared or none declared",nil) coerce(T,m) --% --% Entry point to the compiler --% preprocessParseTree pt == $postStack := [] pf := parseTransform postTransform pt $postStack = nil => pf displayPreCompilationErrors() nil ++ Mutate parse form `pf' so that references to niladic constructors ++ appear in instantiation form. instantiateNiladics! pf == ident? pf and niladicConstructor? pf => [pf] do pf isnt [.,:.] or pf.op is 'QUOTE => nil pf.op in '(DEF MDEF) => -- Note: Normally, we wouldn't want to touch the definiendum; -- except that some operators such as 'case' take flags, -- so we want to solve them if they are types. definiendum := first pf.args if definiendum is ['case,:.] then third(definiendum) := instantiateNiladics! third definiendum third(pf) := instantiateNiladicsInList! third pf fourth(pf) := instantiateNiladics! fourth pf pf.op is 'SIGNATURE => third(pf) := instantiateNiladicsInList! third pf pf.op isnt [.,:.] => pf.args := instantiateNiladicsInList! pf.args instantiateNiladicsInList! pf pf instantiateNiladicsInList! l == for xs in tails l repeat xs.first := instantiateNiladics! first xs l ++ Takes a parse tree `pt', typecheck it and compile it down ++ to VM instructions. compileParseTree pt == $topOp: local := nil pt = nil => nil pf := preprocessParseTree pt pf = nil => nil -- stop if preprocessing was a disaster. -- Don't go further if only preprocessing was requested. $PrintOnly => formatToStdout('"~S =====>~%",$currentLine) PRETTYPRINT pf -- Now start actual compilation. $x: local := nil -- ??? $m: local := nil -- ??? $s: local := nil -- ??? $returnMode: local := $EmptyMode $exitModeStack: local := [] -- Used by the compiler proper $leaveLevelStack: local := [] pf := instantiateNiladics! pf if T := compTopLevel(pf,$EmptyMode,$InteractiveFrame) then $InteractiveFrame := T.env finishLine $OutputStream --% --% Register compilers for special forms. -- Those compilers are on the `SPECIAL' property of the corresponding -- special form operator symbol. for x in [["|", :"compSuchthat"],_ ["@", :"compAtSign"],_ [":", :"compColon"],_ ["::", :"compCoerce"],_ ["+->", :"compLambda"],_ ["QUOTE", :"compQuote"],_ ["add", :"compAdd"],_ ["CAPSULE", :"compCapsule"],_ ["case", :"compCase"],_ ["CATEGORY", :"compCategory"],_ ["COLLECT", :"compRepeatOrCollect"],_ ["CONS", :"compCons"],_ ["construct", :"compConstruct"],_ ["elt", :"compElt"],_ ["Enumeration", :"compBuiltinDomain"],_ ["EnumerationCategory", :"compEnumCat"],_ ["exit", :"compExit"],_ ["has", :"compHas"],_ ["IF", : "compIf"],_ ["xor",: "compExclusiveOr"],_ ["import", :"compImport"],_ ["is", :"compIs"],_ ["Join", :"compJoin"],_ ["leave", :"compLeave"],_ [":=", :"compSetq"],_ ["MDEF", :"compMacro"],_ ["not", :"compLogicalNot"],_ ["pretend", :"compPretend"],_ ["Record", :"compBuiltinDomain"],_ ["RecordCategory", :"compConstructorCategory"],_ ["REDUCE", :"compReduce"],_ ["REPEAT", :"compRepeatOrCollect"],_ ["return", :"compReturn"],_ ["SEQ", :"compSeq"],_ ["SubDomain", :"compSubDomain"],_ ["SubsetCategory", :"compSubsetCategory"],_ ["Mapping", :"compBuiltinDomain"],_ ["MappingCategory", :"compConstructorCategory"],_ ["Union", :"compBuiltinDomain"],_ ["UnionCategory", :"compConstructorCategory"],_ ["where", :"compWhere"],_ ["per",:"compPer"],_ ["rep",:"compRep"],_ ["%Comma",:"compComma"],_ ["%Exist", : "compScheme"] , _ ["%Forall", : "compSceheme"] , _ ["%Match",:"compMatch"],_ ["%SignatureImport",:"compSignatureImport"],_ ['%Throw,:'compThrow], ['%Try, :'compTry], ['%Do, : 'compDo], ["[||]", :"compileQuasiquote"]] repeat property(first x, 'SPECIAL) := rest x