-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd. -- All rights reserved. -- Copyright (C) 2007-2015, 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 g_-util import g_-opt namespace BOOT module c_-util where makeWorkerName: %Symbol -> %Symbol clearReplacement: %Symbol -> %Thing replaceSimpleFunctions: %Form -> %Form foldExportedFunctionReferences: (%Database,%List %Code) -> %List %Code diagnoseUnknownType: (%Mode,%Env) -> %Form declareUnusedParameters: %Code -> %Code registerFunctionReplacement: (%Database,%Symbol,%Form) -> %Thing getSuccessEnvironment: (%Form,%Env) -> %Env getInverseEnvironment: (%Form,%Env) -> %Env giveVariableSomeValue: (%Symbol,%Mode,%Env) -> %Env registerConstructor: (%Symbol,%Env) -> %Env currentDB: %Env -> %Maybe %Database -- functor data manipulation dbInfovec: %Symbol -> %Maybe %FunctorData --% Accessors of domain and category objects ++ Return thr i-th part of a category object macro categoryRef(c,i) == vectorRef(c,i) ++ Return the i-th part of a domain object. macro domainRef(d,i) == vectorRef(d,i) ++ Return the canonical form for a domain or category object macro canonicalForm d == vectorRef(d,0) ++ Return the constructor that instantiates to the domain ++ or category object macro instantiationCtor d == canonicalForm(d).op ++ Return the canonical forms of the arguments used to instantiate ++ a domain or a category object. macro instantiationArgs d == canonicalForm(d).args ++ Return the number of arguments used to instantiate a domain object. macro instantiationArity d == # instantiationArgs d ++ Return the list of operations exported by a category object macro categoryExports d == categoryRef(d,1) ++ Return the attribute alist of a category object. macro categoryAttributes d == categoryRef(d,2) ++ Return a 3-list of data describing the hierarchy of category `c'. macro categoryAssociatedTypes c == categoryRef(c,4) ++ Return the list of principal ancestors of category `c'. macro categoryPrincipals c == first categoryAssociatedTypes c ++ Return the list of [ancestor,predicate,index] data of catagory `c', ++ where `ancestor' is a fundamental ancestor, `index' its sequence number. macro categoryAncestors c == second categoryAssociatedTypes c macro categoryLocals c == third categoryAssociatedTypes c macro categoryParameters c == categoryRef(c,5) ++ Reference a 3-list ++ [lookupFunction,thisDomain,optable] ++ necessary for function lookup in a domain: macro domainDirectory d == domainRef(d,1) ++ Reference the lookup function of a domain object macro domainLookupFunction d == first domainDirectory d ++ Reference the operator-code table of a domain object. macro domainOperatorTable d == third domainDirectory d ++ Reference the list of (attribute, predIndex) pairs for this domain. macro domainAttributes d == domainRef(d,2) ++ Return the predicate values associated with the domain object. ++ This is an integer interpreted as bit vector macro domainPredicates d == domainRef(d,3) ++ Return a 3-element dotted list of address data for a domain. macro domainData d == domainRef(d,4) --% structure %CompilationData == Record(subst: %Substitution,idata: %Substitution,bytes: List %Fixnum, shell: %Vector %Thing, items: %Buffer %Pair(%SourceEntity,%Code), lib: %Libstream,outpath: %Pathname) with cdSubstitution == (.subst) cdImplicits == (.idata) cdBytes == (.bytes) cdShell == (.shell) cdItems == (.items) cdLib == (.lib) cdOutput == (.outpath) ++ Make a fresh compilation data structure. makeCompilationData() == mk%CompilationData(nil,nil,nil,nil,[nil,:0],nil,nil) ++ Subsitution that replaces parameters with formals. macro dbFormalSubst db == cdSubstitution dbCompilerData db ++ Return source-level parameters of this constructor. dbParameters db == dbConstructorForm(db).args ++ Return implicit parameter data associated to `db'. This ++ information is active only during the elaboration of the ++ constructor associated with `db'. macro dbImplicitData db == cdImplicits dbCompilerData db ++ Return the list of encoding bytes for a function during elaboration. ++ Transcient data. macro dbByteList db == cdBytes dbCompilerData db ++ Return the domain shell of the category object (or the category object ++ of the domain) being elaborated. macro dbDomainShell db == cdShell dbCompilerData db ++ Return a buffer of entities referenced during elaboration ++ of current functor. macro dbEntityBuffer db == cdItems dbCompilerData db ++ List (in reverse order) of used entities during elaboration of ++ current functor. macro dbUsedEntities db == first dbEntityBuffer db ++ Number of used entities during elaboration of current functor. macro dbEntityCount db == rest dbEntityBuffer db macro dbLibstream db == cdLib dbCompilerData db macro dbCodeStream db == libCodeStream dbLibstream db macro dbInsnStream db == libInsnStream dbLibstream db macro dbOutputPath db == cdOutput dbCompilerData db ++ Return the existential substitution of `db'. dbQuerySubst db == x := dbImplicitData db => first x nil ++ List of implicit parameters to the constructor. dbImplicitParameters db == ASSOCLEFT dbQuerySubst db dbImplicitConstraints db == x := dbImplicitData db => second x ++ Apply the formal substitution or `db'to the form `x'. macro dbSubstituteFormals(db,x) == applySubst(dbFormalSubst db,x) ++ Apply the query substitution of `db' to the form `x'. macro dbSubstituteQueries(db,x) == applySubst(dbQuerySubst db,x) ++ Apply both query and formal variable substitutions of `db' to `x'. dbSubstituteAllQuantified(db,x) == applySubst([:dbQuerySubst db,:dbFormalSubst db],x) --% $SetCategory == '(SetCategory) --% dbInfovec name == getConstructorKindFromDB name is "category" => nil loadLibIfNotLoaded(name) u := property(name,'infovec) => u nil ++ Access to the shell template associated with an infovec. macro ivDomainShell iv == first iv ++ Access to the operation table associated with an infovec. macro ivOptable iv == second iv ++ Access the alist mapping an attribute to the predicate index ++ associated with an infovec. macro ivAttributePredicateIndexDirectory iv == third iv ++ Access to additional data in the infovec macro ivAdditionalData iv == fourth iv ++ Access to predicate bitvector as associated with an infovec. macro ivPredicateBitvector iv == first ivAdditionalData iv ++ Access to the vector of category default package functors ++ associated with an infovec. macro ivCategoryDefaults iv == second ivAdditionalData iv ++ Access to the principal ancestors of a domain shell associated ++ with an infovec. macro ivPrincipalAncestors iv == third ivAdditionalData iv ++ Return the exported operation descriptors bytecode vector ++ associated with an infovec. ivExportBytecodes iv == [.,.,.,:vec] := ivAdditionalData iv vec --% ++ Token to indicate that a function body should be ignored. $ClearBodyToken == KEYWORD::OpenAxiomClearBodyToken ++ $ConstructorCache := hashTable 'EQ ++ $instantRecord := hashTable 'EQ ++ if true continue compiling after errors $scanIfTrue := false ++ If within a loop, which kind? (list comprehension or plain old loop) $loopKind := nil ++ If within a loop, the program point for the start of the body. $repeatBodyLabel := nil ++ The number of occurrance of `iterate' in a (plain old) loop. $iterateCount := nil ++ The number of occurrance of `break' in a (plain old) loop. $breakCount := 0 +++ If non nil, holds compiled value of 'Rep' of the current domain. $Representation := nil $formalArgList := [] ++ The formal body of the category being currently compiled. $currentCategoryBody := nil $compErrorMessageStack := nil --% Optimization control ++ true if we have to proclaim function signatures in the generated Lisp. $optProclaim := false ++ true if we have to inline simple functions before codegen. $optReplaceSimpleFunctions := false ++ true if we have to resolve references to exported operations. $optExportedFunctionReference := false --% ++ Quote form, if not a basic value. quoteMinimally form == integer? form or string? form or form = nil or form = true => form quote form ++ If using old `Rep' definition semantics, return `$' when m is `Rep'. ++ Otherwise, return `m'. dollarIfRepHack m == m = "Rep" and $useRepresentationHack => "$" m ++ The inverse of the above. RepIfRepHack m == m = "$" and $useRepresentationHack => "Rep" m ++ If using old `Rep' definition semantics, return `$' is m is `Rep'. -- ??? Eventually this and the above should be merged and/or removed. substituteDollarIfRepHack m == $useRepresentationHack => substitute("$","Rep",m) m ++ Return the triple for the representation domain for the ++ current functor, if any. getRepresentation: %Env -> %Maybe %Mode getRepresentation e == u := get('Rep,'value,e) => u.expr get('Rep,"macro",e) ++ Returns true if the form `t' is an instance of the Tuple constructor. isTupleInstance: %Form -> %Boolean isTupleInstance t == t is ["Tuple",.] ++ Returns true if the signature `sig' describes a function that can ++ accept a homogeneous variable length argument list. isHomoegenousVarargSignature: %Sig -> %Boolean isHomoegenousVarargSignature sig == #sig = 1 and isTupleInstance first sig ++ Returns true if the arguments list `args' match in shape the ++ parameter type list `sig'. This means that either the number ++ of arguments is exactly the number of parameters, or that the ++ signature describes a homogeneous vararg operation. enoughArguments: (%List %Form,%Sig) -> %Boolean enoughArguments(args,sig) == #args = #sig or isHomoegenousVarargSignature sig ++ Returns true if the operation described by the signature `sig' ++ wants its arguments as a Tuple object. wantArgumentsAsTuple: (%List %Form,%Sig) -> %Boolean wantArgumentsAsTuple(args,sig) == isHomoegenousVarargSignature sig and #args ~= #sig abstractionOperator? x == symbol? x and symbolMember?(x,$AbstractionOperator) ++ We are about to seal the (Lisp) definition of a function. ++ Augment the body of any function definition in the form `x' ++ with declarations for unused parameters. ++ that are unused. declareUnusedParameters x == (augment x; x) where augment x == atomic? x => nil x is [op,parms,body] and abstractionOperator? op => augment body unused := [p for p in parms | not usesVariable?(body,p)] null unused => [body] x.rest.rest := [["DECLARE",["IGNORE",:unused]],body] for x' in x repeat augment x' devaluate d == not vector? d => d categoryObject? d => canonicalForm d #d > 0 => d' := canonicalForm d isFunctor d' => d' d d devaluateList l == [devaluate d for d in l] devaluateDeeply x == vector? x => devaluate x x isnt [.,:.] => x [devaluateDeeply y for y in x] --% Debugging Functions --CONTINUE() == continue() continue() == FIN comp($x,$m,$f) LEVEL(:l) == apply('level,l) level(:l) == null l => same() l is [n] and integer? n => displayComp ($level:= n) SAY '"Correct format: (level n) where n is the level you want to go to" UP() == up() up() == displayComp ($level:= $level-1) SAME() == same() same() == displayComp $level DOWN() == down() down() == displayComp ($level:= $level+1) displaySemanticErrors() == n:= #($semanticErrorStack:= removeDuplicates $semanticErrorStack) n=0 => nil l:= reverse! $semanticErrorStack $semanticErrorStack:= nil sayBrightly bright '" Semantic Errors:" displaySemanticError(l,$OutputStream) sayBrightly '" " displayWarnings() displaySemanticError(l,stream) == for x in l for i in 1.. repeat sayBrightly(['" [",i,'"] ",:first x],stream) displayWarnings() == n:= #($warningStack:= removeDuplicates $warningStack) n=0 => nil sayBrightly bright '" Warnings:" l := reverse! $warningStack displayWarning(l,$OutputStream) $warningStack:= nil sayBrightly '" " displayWarning(l,stream) == for x in l for i in 1.. repeat sayBrightly(['" [",i,'"] ",:x],stream) displayComp level == $bright:= " << " $dim:= " >> " if $insideCapsuleFunctionIfTrue then sayBrightly ['"error in function",:bright $op,'"%l"] --mathprint removeZeroOne mkErrorExpr level pp removeZeroOne mkErrorExpr level sayBrightly ['"****** level",:bright level,'" ******"] [$x,$m,$f,$exitModeStack]:= ELEM($s,level) SAY("$x:= ",$x) sayBrightly ['"$m := ",:listify form2String $m] --SAY "$f:=" --F_,PRINT_-ONE $f nil mkErrorExpr level == bracket ASSOCLEFT drop(level-#$s,$s) where bracket l == #l<2 => l l is [a,b] => highlight(b,a) where highlight(b,a) == b isnt [.,:.] => substitute(var,b,a) where var:= makeSymbol strconc(STRINGIMAGE $bright,STRINGIMAGE b,STRINGIMAGE $dim) highlight1(b,a) where highlight1(b,a) == a isnt [.,:.] => a a is [ =b,:c] => [$bright,b,$dim,:c] [highlight1(b,first a),:highlight1(b,rest a)] substitute(bracket rest l,second l,first l) compAndTrace [x,m,e] == SAY("tracing comp, compFormWithModemap of: ",x) TRACE_,1(["comp","compFormWithModemap"],nil) T:= comp(x,m,e) UNTRACE_,1 "comp" UNTRACE_,1 "compFormWithModemap" T errorRef s == stackWarning('"%1b has no value", [s]) unErrorRef s == unStackWarning('"'%1b has no value",[s]) --% ENVIRONMENT FUNCTIONS consProplistOf(var,proplist,prop,val) == semchkProplist(var,proplist,prop,val) $InteractiveMode and (u:= assoc(prop,proplist)) => u.rest := val proplist [[prop,:val],:proplist] warnLiteral x == stackWarning('"%1b is BOTH a variable a literal",[x]) intersectionEnvironment(e,e') == ce:= makeCommonEnvironment(e,e') ic := intersectionContour(deltaContour(e,ce),deltaContour(e',ce)) => addContour(ic,ce) ce deltaContour([[c,:cl],:el],[[c',:cl'],:el']) == not sameObject?(el,el') => systemError '"deltaContour" --a cop out for now eliminateDuplicatePropertyLists contourDifference(c,c') where contourDifference(c,c') == [first x for x in tails c while not sameObject?(x,c')] eliminateDuplicatePropertyLists contour == contour is [[x,:.],:contour'] => LASSOC(x,contour') => --save some CONSing if possible [first contour,:DELLASOS(x,eliminateDuplicatePropertyLists contour')] [first contour,:eliminateDuplicatePropertyLists contour'] nil intersectionContour(c,c') == $var: local := nil computeIntersection(c,c') where computeIntersection(c,c') == varlist:= removeDuplicates ASSOCLEFT c varlist':= removeDuplicates ASSOCLEFT c' interVars := setIntersection(varlist,varlist') unionVars := setUnion(varlist,varlist') diffVars := setDifference(unionVars,interVars) modeAssoc:= buildModeAssoc(diffVars,c,c') [:modeAssoc,: [[x,:proplist] for [x,:y] in c | member(x,interVars) and (proplist:= interProplist(y,LASSOC($var:= x,c')))]] interProplist(p,p') == --p is new proplist; p' is old one [:modeCompare(p,p'),:[pair' for pair in p | (pair':= compare(pair,p'))]] buildModeAssoc(varlist,c,c') == [[x,:mp] for x in varlist | (mp:= modeCompare(LASSOC(x,c),LASSOC(x,c')))] compare(pair is [prop,:val],p') == --1. if the property-value pair are identical, accept it immediately pair=(pair':= assoc(prop,p')) => pair --2. if property="value" and modes are unifiable, give intersection -- property="value" but value=genSomeVariable)() (val':= KDR pair') and prop="value" and (m:= unifiable(val.mode,val'.mode)) => ["value",genSomeVariable(),m,nil] --this tells us that an undeclared variable received --two different values but with identical modes --3. property="mode" is covered by modeCompare prop="mode" => nil modeCompare(p,p') == pair := symbolAssoc("mode",p) => pair' := symbolAssoc("mode",p') => m'':= unifiable(rest pair,rest pair') => [["mode",:m'']] stackSemanticError(['"%b",$var,'"%d","has two modes: "],nil) --stackWarning ("mode for",'"%b",$var,'"%d","introduced conditionally") [["conditionalmode",:rest pair]] --LIST pair --stackWarning ("mode for",'"%b",$var,'"%d","introduced conditionally") pair' := symbolAssoc("mode",p') => [["conditionalmode",:rest pair']] --LIST pair' unifiable(m1,m2) == m1=m2 => m1 --we may need to add code to coerce up to tagged unions --but this can not be done here, but should be done by compIf m:= m1 is ["Union",:.] => m2 is ["Union",:.] => ["Union",:S_+(rest m1,rest m2)] ["Union",:S_+(rest m1,[m2])] m2 is ["Union",:.] => ["Union",:S_+(rest m2,[m1])] ["Union",m1,m2] for u in getDomainsInScope $e repeat if u is ["Union",:u'] and (and/[listMember?(v,u') for v in rest m]) then return m --this loop will return nil if not satisfied addContour(c,E is [cur,:tail]) == [append!(fn(c,E),cur),:tail] where fn(c,e) == for [x,:proplist] in c repeat fn1(x,proplist,getProplist(x,e)) where fn1(x,p,ee) == for pv in p repeat fn3(x,pv,ee) where fn3(x,pv,e) == [p,:v]:=pv if p="conditionalmode" then pv.first := "mode" --check for conflicts with earlier mode if vv := symbolTarget("mode",e) then if v ~=vv then stackWarning('"The conditional modes %1p and %2p conflict", [v,vv]) [c] ++ Return the common root of the environments e and e'. ++ Note: we use cell pointer comparison instead of general object ++ equality comparison because both are expected to build from ++ a commont cell node. makeCommonEnvironment(e,e') == interE makeSameLength(e,e') where interE [e,e'] == sameObject?(rest e,rest e') => [interLocalE makeSameLength(first e,first e'),:rest e] interE [rest e,rest e'] interLocalE [le,le'] == sameObject?(rest le,rest le') => [interC makeSameLength(first le,first le'),:rest le] interLocalE [rest le,rest le'] interC [c,c'] == sameObject?(c,c') => c interC [rest c,rest c'] makeSameLength(x,y) == fn(x,y,#x,#y) where fn(x,y,nx,ny) == nx>ny => fn(rest x,y,nx-1,ny) nx fn(x,rest y,nx,ny-1) [x,y] ++ Return the lexically leftmost location in an assignment for. lhsOfAssignment x == x is [":=",lhs,:.] => lhsOfAssignment lhs x getSuccessEnvironment(a,e) == a is ["is",id,m] => id := lhsOfAssignment id ident? id and isDomainForm(m,$EmptyEnvironment) => e:=put(id,"specialCase",m,e) currentProplist:= getProplist(id,e) [.,.,e] := T := comp(m,$EmptyMode,e) or return nil -- duplicates compIs newProplist:= consProplistOf(id,currentProplist,"value",[m,:rest removeEnv T]) addBinding(id,newProplist,e) e a is ["case",x,m] and (x := lhsOfAssignment x) and ident? x => put(x,"condition",[a,:get(x,"condition",e)],e) a is ["and",:args] => for form in args repeat e := getSuccessEnvironment(form,e) e a is ["not",a'] => getInverseEnvironment(a',e) -- Follow temporaries in complex conditionals symbol? a and (T := get(a,"value",e)) => getSuccessEnvironment(T.expr,e) e isUnionMode(m,e) == m is ["Union",:.] => m v := get(RepIfRepHack m,"value",e) => (v.expr is ["Union",:.] => v.expr; nil) nil ++ Return the UnionCategory of `m' in the environment `e', if known. unionLike?(m,e) == isUnionMode(m,e) is ['Union,:branches] => ['UnionCategory,:branches] -- Take a cheap approximation at domains with Union-like flavour. T := compForMode(m,$EmptyMode,e) or return nil T.expr is ['Union,:branches] => ['UnionCategory,:T.expr.args] T.mode is ['UnionCategory,:.] => T.mode T.mode is ['UnionType] => ['UnionCategory] T.mode isnt ['Join,:cats,['CATEGORY,.,:sigs]] => nil listMember?(['UnionType],cats) => ['UnionCategory, :[b for ['SIGNATURE,"case",[=$Boolean,'$,["[||]",b]]] in sigs]] nil ++ If `x' designates a store with multiple views, e.g. Union, return ++ the collection of those modes. unionProperty(x,e) == x isnt [.,:.] => unionLike?(getmode(x,e),e) nil getInverseEnvironment(a,e) == a is ["case",x,m] and (x := lhsOfAssignment x) and ident? x => --the next two lines are necessary to get 3-branched Unions to work -- old-style unions, that is (get(x,"condition",e) is [["OR",:oldpred]]) and listMember?(a,oldpred) => put(x,"condition",[MKPF(remove(oldpred,a),"OR")],e) unionProperty(x,e) is ['UnionCategory,:l] => l' := remove(l,m) for u in l' repeat if u is ['_:,=m,:.] then l' := remove(l',u) newpred:= MKPF([["case",x,m'] for m' in l'],"OR") put(x,"condition",[newpred,:get(x,"condition",e)],e) e a is ["not",a'] => getSuccessEnvironment(a',e) -- Follow temporaries in complex conditionals symbol? a and (T := get(a,"value",e)) => getInverseEnvironment(T.expr,e) e ++ Give some abstract value to the variable `v' of mode `m' in `e'. ++ Return the resulting environment. giveVariableSomeValue(x,m,e) == put(x,'value,[genSomeVariable(),m,nil],e) printEnv E == for x in E for i in 1.. repeat for y in x for j in 1.. repeat SAY('"******CONTOUR ",j,'", LEVEL ",i,'":******") for z in y repeat finishLine $OutputStream SAY("Properties Of: ",first z) for u in rest z repeat PRIN1 first u printString ": " PRETTYPRINT tran(rest u,first u) where tran(val,prop) == prop="value" => drop(-1,val) val prEnv E == for x in E for i in 1.. repeat for y in x for j in 1.. repeat SAY('"******CONTOUR ",j,'", LEVEL ",i,'":******") for z in y | null symbolTarget("modemap",rest z) repeat finishLine $OutputStream SAY("Properties Of: ",first z) for u in rest z repeat PRIN1 first u printString ": " PRETTYPRINT tran(rest u,first u) where tran(val,prop) == prop="value" => drop(-1,val) val prModemaps E == listOfOperatorsSeenSoFar:= nil for x in E for i in 1.. repeat for y in x for j in 1.. repeat for z in y | not member(first z,listOfOperatorsSeenSoFar) and (modemap := symbolTarget("modemap",rest z)) repeat listOfOperatorsSeenSoFar:= [first z,:listOfOperatorsSeenSoFar] finishLine $OutputStream PRIN1 first z printString ": " PRETTYPRINT modemap prTriple T == SAY '"Code:" pp T.0 SAY '"Mode:" pp T.1 TrimCF() == new:= nil old:= CAAR $CategoryFrame for u in old repeat if objectAssoc(first u,new) = nil then uold:= rest u unew:= nil for v in uold repeat if objectAssoc(first v,unew) = nil then unew:= [v,:unew] new:= [[first u,:reverse! unew],:new] $CategoryFrame:= [[reverse! new]] nil --% ++ Returns non-nil if `t' is a known type in the environement `e'. diagnoseUnknownType(t,e) == t isnt [.,:.] => t in '($ constant) => t t' := assoc(t,getDomainsInScope e) => t' (m := getmode(t,e)) and isCategoryForm(m,$CategoryFrame) => t string? t => t -- ??? We should not to check for $$ at this stage. -- ??? This is a bug in the compiler that needs to be fixed. t = "$$" => t stackSemanticError(['"The identifier", :bright t, '"is not known to name a type"],nil) [ctor,:args] := t ctor is "Mapping" => for t' in args repeat diagnoseUnknownType(t',e) t ctor is "Record" => for [[.,n,t'],:fields] in tails args repeat diagnoseUnknownType(t',e) for [.,=n,.] in fields repeat stackSemanticError(['"Field", :bright n, '"declared more than once."], nil) t ctor is "Union" => if args is [[":",:.],:.] then for [[.,n,t'],:fields] in tails args repeat diagnoseUnknownType(t',e) for [.,=n,.] in fields repeat stackSemanticError(['"Field", :bright n, '"declared more than once."], nil) else for t' in args repeat diagnoseUnknownType(t',e) t ctor is "Enumeration" => for t' in args repeat ident? t' => nil stackSemanticError(['"Enumerators must be symbols."], nil) -- Make sure we don't have repeated symbolic values for [sym,:syms] in tails args repeat symbolMember?(sym,syms) => stackSemanticError(['"Symbolic value ", :bright sym, '"is listed twice"], nil) t ctor is "[||]" => t builtinConstructor? ctor => t -- ??? Ideally `e' should be a local extension of $CategoryFrame -- ??? so that we don't have to access it here as a global state. get(ctor,"isFunctor",$CategoryFrame) or get(ctor,"isCategory",$CategoryFrame) => t -- ctor maybe a constructor, but user forgot to import. Warn. getConstructorAbbreviationFromDB ctor => stackWarning('"Type %1pb is not in scope. Import it",[t]) t stackSemanticError(['"Identifier", :bright ctor, '"is not known to name a constructor"],nil) --% PREDICATES isConstantId(name,e) == ident? name => pl:= getProplist(name,e) => (symbolTarget("value",pl) or symbolTarget("mode",pl) => false; true) true false isFalse() == nil isFluid s == s isnt [.,:.] and char "$" = stringChar(PNAME s,0) isFunction(x,e) == get(x,"modemap",e) or GETL(x,"SPECIAL") or x="case" or getmode(x,e) is [ "Mapping",:.] isLiteral: (%Symbol,%Env) -> %Boolean isLiteral(x,e) == get(x,"isLiteral",e) => true false ++ Remember the name of the constructor definition being processed. registerConstructor(x,e) == put('%compilerData,'%ctor,x,e) ++ Retrieve the DB of the constructor definition being processed. currentDB e == ctor := get('%compilerData,'%ctor,e) => constructorDB ctor nil makeLiteral: (%Symbol,%Env) -> %Thing makeLiteral(x,e) == put(x,"isLiteral","true",e) isSomeDomainVariable s == ident? s and #(x:= symbolName s) > 2 and stringChar(x,0) = char "#" and stringChar(x,1) = char "#" ++ Return non-nil is the domain form `x' is a `subset' of domain ++ form `y' in the environment `e'. The relation of subdomain ++ is understood as equivalent to the fact that all values of ++ the domain designated by `x' are also values of the domain ++ designated by `y'. Examples include declaration of domain `x' ++ as satisfying SubsetCategory(SomeCategory, y). Or, when ++ x is defined as SubDomain(y,pred). In that case, the predicate ++ is returned and its parameter is `#1'. isSubset(x,y,e) == x = y => true -- Every domain or catgory is a subset of Type. y = $Type => true -- When using the old style definition, the current domain -- is considered a subset of its representation domain x is '$ and y is 'Rep => $useRepresentationHack -- Expand domain representation form x is 'Rep and not $useRepresentationHack => isSubset(getRepresentation e,y,e) y is '$ and get(y,'%dc,e) = x => true -- Or, if x has the Subsets property set by SubsetCategory. pred := LASSOC(opOf x,get(opOf y,"Subsets",e)) => pred -- Or, they are related by subdomain chain. isDomainForm(x,e) and isSubDomain(x,y) isDomainInScope(domain,e) == domainList:= getDomainsInScope e domain isnt [.,:.] => symbolMember?(domain,domainList) => true not ident? domain or isSomeDomainVariable domain => true false (name:= first domain)="Category" => true objectAssoc(name,domainList) => true -- null rest domain or domainMember(domain,domainList) => true -- false isFunctor name => false true --is not a functor isSimple x == atomic? x => true isSideEffectFree x.op and (and/[isSimple y for y in x.args]) isSideEffectFree op == op is ["elt",.,op'] => isSideEffectFree op' not ident? op => false listMember?(op,$SideEffectFreeFunctionList) or constructor? op isAlmostSimple x == --returns ( . ) or nil $assignmentList: local := nil --$assigmentList is only used in this function transform:= fn x where fn x == x isnt [.,:.] or null rest x => x [op,y,:l]:= x op="has" => x op="is" => x op=":=" => ident? y => (setAssignment [x]; y) (setAssignment [[":=",g:= genVariable(),:l],[":=",y,g]]; g) op = "case" and ident? y => x isSideEffectFree op => [op,:mapInto(rest x, function fn)] $assignmentList:= "failed" setAssignment x == $assignmentList="failed" => nil $assignmentList:= [:$assignmentList,:x] $assignmentList="failed" => nil wrapSEQExit [:$assignmentList,transform] incExitLevel u == adjExitLevel(u,1,1) u decExitLevel u == (adjExitLevel(u,1,-1); removeExit0 u) where removeExit0 x == x isnt [.,:.] => x x is ["exit",0,u] => removeExit0 u [removeExit0 first x,:removeExit0 rest x] adjExitLevel(x,seqnum,inc) == x isnt [.,:.] => x x is [op,:l] and op in '(SEQ REPEAT COLLECT) => for u in l repeat adjExitLevel(u,seqnum+1,inc) x is ["exit",n,u] => (adjExitLevel(u,seqnum,inc); seqnum>n => x; x.rest.first := n+inc) x is [op,:l] => for u in l repeat adjExitLevel(u,seqnum,inc) wrapSEQExit l == null rest l => first l [:c,x]:= [incExitLevel u for u in l] ["SEQ",:c,["exit",1,x]] --% UTILITY FUNCTIONS makeWorkerName op == makeSymbol strconc(symbolName op,'";") removeEnv t == [t.expr,t.mode,$EmptyEnvironment] -- t is a triple -- This function seems no longer used --ordinsert(x,l) == -- null l => [x] -- x=first l => l -- _?ORDER(x,first l) => [x,:l] -- [first l,:ordinsert(x,rest l)] makeNonAtomic x == x isnt [.,:.] => [x] x flatten(l,key) == null l => nil first l is [k,:r] and k=key => [:r,:flatten(rest l,key)] [first l,:flatten(rest l,key)] genDomainVar() == $Index:= $Index+1 makeSymbol strconc('"#D",toString $Index) genVariable() == makeSymbol strconc('"#G",toString ($genSDVar:= $genSDVar+1)) genSomeVariable() == makeSymbol strconc('"##",toString ($genSDVar:= $genSDVar+1)) listOfIdentifiersIn x == ident? x => [x] x is [op,:l] => removeDuplicates ("append"/[listOfIdentifiersIn y for y in l]) nil mapInto(x,fn) == [apply(fn,[y]) for y in x] numOfOccurencesOf(x,y) == fn(x,y,0) where fn(x,y,n) == null y => 0 x=y => n+1 atomic? y => n symbol? x and abstraction? y => symbolMember?(x,y.absParms) => n fn(x,y.absBody,n) fn(x,first y,n)+fn(x,rest y,n) compilerMessage(msg,args) == $PrintCompilerMessageIfTrue => sayPatternMsg(msg,args) printDashedLine() == SAY '"--------------------------------------------------------------------------" stackSemanticError(msg,expr) == BUMPERRORCOUNT "semantic" if $insideCapsuleFunctionIfTrue then msg:= [$op,": ",:msg] if msg isnt [.,:.] then msg:= [msg] entry:= [msg,expr] if not listMember?(entry,$semanticErrorStack) then $semanticErrorStack:= [entry,:$semanticErrorStack] $scanIfTrue and $insideCapsuleFunctionIfTrue=true and #$semanticErrorStack- $initCapsuleErrorCount>3 => THROW("compCapsuleBody",nil) nil stackWarning(msg,args == nil) == msg := buildMessage(msg, args) if $insideCapsuleFunctionIfTrue then msg:= [$op,": ",:msg] if not listMember?(msg,$warningStack) then $warningStack:= [msg,:$warningStack] nil unStackWarning(msg,args) == msg := buildMessage(msg,args) if $insideCapsuleFunctionIfTrue then msg:= [$op,": ",:msg] $warningStack := remove!($warningStack,msg) nil stackMessage(msg,args == nil) == if args ~= nil then msg := buildMessage(msg,args) $compErrorMessageStack:= [msg,:$compErrorMessageStack] nil stackMessageIfNone msg == --used in situations such as compForm where the earliest message is wanted if null $compErrorMessageStack then $compErrorMessageStack:= [msg,:$compErrorMessageStack] nil stackAndThrow(msg, args == nil) == if args ~= nil then msg := buildMessage(msg,args) $compErrorMessageStack:= [msg,:$compErrorMessageStack] THROW("compOrCroak",nil) printString x == PRINC (string? x => x; PNAME x) printAny x == if x isnt [.,:.] then printString x else PRIN1 x printSignature(before,op,[target,:argSigList]) == printString before printString op printString ": _(" if argSigList then printAny first argSigList for m in rest argSigList repeat (printString ","; printAny m) printString "_) -> " printAny target finishLine $OutputStream elapsedTime() == currentTime:= TEMPUS_-FUGIT() elapsedSeconds:= (currentTime-$previousTime)*QUOTIENT(1.0,$timerTicksPerSecond) $previousTime:= currentTime elapsedSeconds addStats([a,b],[c,d]) == [a+c,b+d] printStats [byteCount,elapsedSeconds] == timeString := normalizeStatAndStringify elapsedSeconds if byteCount = 0 then SAY('"Time: ",timeString,'" SEC.") else SAY('"Size: ",byteCount,'" BYTES Time: ",timeString,'" SEC.") finishLine $OutputStream nil ++is domain of category form also of category form'? ++domain is only used for SubsetCategory resolution. ++ `db', if non-nil, is the DB for the constructor being compiled. ++Ensuring that X being a Ring means that it satisfies (Algebra X) extendsCategoryForm(db,domain,form,form') == form=form' => true form=$Category => nil form' is ["Join",:l] => and/[extendsCategoryForm(db,domain,form,x) for x in l] form' is ["CATEGORY",.,:l] => and/[extendsCategoryForm(db,domain,form,x) for x in l] form' is ["SubsetCategory",cat,dom] => extendsCategoryForm(db,domain,form,cat) and isSubset(domain,dom,$e) form is ["Join",:l] => or/[extendsCategoryForm(db,domain,x,form') for x in l] form is ["CATEGORY",.,:l] => listMember?(form',l) or stackWarning('"not known that %1 is of mode %2p",[form',form]) or true -- if we are compiling the category `form', then we should look at -- the body as provided in the current definition, not a version -- possibly compiled previously that may have changed. -- FIXME: should not we go all the way down and implement -- polynormic recursion? domain = "$" and form = dbConstructorForm db => extendsCategoryForm(db,domain, $currentCategoryBody, form') isCategoryForm(form,$EmptyEnvironment) => -- -- If we have an existing definition for this category, use it. -- (db := constructorDB form.op) and loadDB db => -- form' is ['SIGNATURE,op,types,:.] => assoc([op,args],dbOperations db) -- form' is ['ATTRIBUTE,a] => assoc(a,dbAttributes db) -- subst := pairList(dbConstructorForm(db).args,form.args) -- or/[extendsCategoryForm(db,domain,applySubst(subst,cat),form') -- for [cat,:.] in dbAncestors db] -- Otherwise constructs the associated domain shell formVec:=(compMakeCategoryObject(form,$e)).expr --Must be $e to pick up locally bound domains form' is ["SIGNATURE",op,args,:.] => assoc([op,args],categoryExports formVec) or assoc(substitute(domain,"$",[op,args]), substitute(domain,"$",categoryExports formVec)) form' is ["ATTRIBUTE",at] => assoc(at,categoryAttributes formVec) or assoc(substitute(domain,"$",at),substitute(domain,"$",categoryAttributes formVec)) form' is ["IF",:.] => true --temporary hack so comp won't fail listMember?(form',categoryPrincipals formVec) or listMember?(form',substitute(domain,"$",categoryPrincipals formVec)) or (or/ [extendsCategoryForm(db,domain,substitute(domain,"$",cat),form') for [cat,:.] in categoryAncestors formVec]) nil getmode(x,e) == prop:=getProplist(x,e) u := symbolTarget("value",prop) => u.mode symbolTarget("mode",prop) getmodeOrMapping(x,e) == u:= getmode(x,e) => u (u:= get(x,"modemap",e)) is [[[.,:map],.],:.] => ["Mapping",:map] nil outerProduct l == --of a list of lists null l => [nil] "append"/[[[x,:y] for y in outerProduct rest l] for x in first l] sublisR(al,u) == u isnt [.,:.] => u y:= rassoc(t:= [sublisR(al,x) for x in u],al) => y true => t substituteOp(op',op,x) == x isnt [.,:.] => x [(op=(f:= first x) => op'; f),:[substituteOp(op',op,y) for y in rest x]] --substituteForFormalArguments(argl,expr) == -- applySubst([[v,:a] for a in argl for v in $FormalMapVariableList],expr) -- following is only intended for substituting in domains slots 1 and 4 -- signatures and categories sublisV(p,e) == (p isnt [.,:.] => e; suba(p,e)) where suba(p,e) == string? e => e -- no need to descend vectors unless they are categories categoryObject? e => vector [suba(p,e.i) for i in 0..maxIndex e] e isnt [.,:.] => (y := objectAssoc(e,p) => rest y; e) u:= suba(p,first e) v:= suba(p,rest e) sameObject?(first e,u) and sameObject?(rest e,v) => e [u,:v] --% DEBUGGING PRINT ROUTINES used in breaks old2NewModemaps x == -- [[dcSig,pred] for [dcSig,[pred,:.],:.] in x] x is [dcSig,[pred,:.],:.] => [dcSig,pred] x traceUp() == $x isnt [.,:.] => sayBrightly "$x is an atom" for y in rest $x repeat u:= comp(y,$EmptyMode,$f) => sayBrightly [y,'" ==> mode",'"%b",u.mode,'"%d"] sayBrightly [y,'" does not compile"] traceDown() == mmList:= getFormModemaps($x,$f) => for mm in mmList repeat if u:= qModemap mm then return u sayBrightly "no modemaps for $x" qModemap mm == sayBrightly ['"%b","modemap",'"%d",:formatModemap mm] [[dc,target,:sl],[pred,:.]]:= mm and/[qArg(a,m) for a in rest $x for m in sl] => target sayBrightly ['"%b","fails",'"%d",'"%l"] qArg(a,m) == yesOrNo:= u:= comp(a,m,$f) => "yes" "no" sayBrightly [a," --> ",m,'"%b",yesOrNo,'"%d"] yesOrNo="yes" displayProplist(x,alist) == sayBrightly ["properties of",'"%b",x,'"%d",":"] fn alist where fn alist == alist is [[prop,:val],:l] => if prop="value" then val:= [val.expr,val.mode,'"..."] sayBrightly [" ",'"%b",prop,'"%d",": ",val] fn deleteAssoc(prop,l) displayModemaps E == listOfOperatorsSeenSoFar:= nil for x in E for i in 1.. repeat for y in x for j in 1.. repeat for z in y | not member(first z,listOfOperatorsSeenSoFar) and (modemaps := symbolTarget("modemap",rest z)) repeat listOfOperatorsSeenSoFar:= [first z,:listOfOperatorsSeenSoFar] displayOpModemaps(first z,modemaps) --% General object traversal functions GCOPY ob == copyTree ob -- for now --% ++ format the set of candidate operations. displayAmbiguousSignatures(op,sigs) == [:showCandidate(op, sig) for sig in sigs] where showCandidate(op,sig) == ["%l", " ", op, '": ", :bright formatUnabbreviated ["Mapping",:sig]] ++ Display diagnostic message about ambiguous operation `op', with ++ possible resolutions given by the list `sigs'. ambiguousSignatureError(op, sigs) == stackSemanticError(['"signature of lhs not unique. Candidates are:", :displayAmbiguousSignatures($op,sigs)],nil) --% Capsule Directory Management ++ Holds the list of slot number-export function pairs of ++ the current functor. $capsuleDirectory := nil clearCapsuleDirectory() == $capsuleDirectory := nil $capsuleFunctionStack := nil ++ Return the linkage name of the exported operation associated with ++ slot number `slot'. A nil entry means that either the operation ++ is not defined, or it is conditional. getCapsuleDirectoryEntry slot == scalarTarget(slot,$capsuleDirectory) ++ Update the current capsule directory with entry controlled by ++ predicate `pred'. updateCapsuleDirectory(entry,pred) == pred isnt true => nil $capsuleDirectory := [entry,:$capsuleDirectory] --% Tree walkers ++ Walk VM conditional forms mutating sub-forms with the unary ++ function `fun' mutateConditionalFormWithUnaryFunction(form,fun) == form isnt ['%when,:body] => form for clauses in tails body repeat -- a clause is a list of forms for subForms in tails first clauses repeat subForms.first := apply(fun,[first subForms]) form ++ Walk VM a binding-form mutating enclosed expression forms with ++ the unary function `fun'. Every sub-form is visited except ++ local variable declarations, though their initializers ++ are visited. mutateBindingFormWithUnaryFunction(form,fun) == form isnt [op,inits,:body] and op in '(LET %bind) => form for defs in tails inits repeat def := first defs def isnt [.,:.] => nil -- no initializer def.rest.first := apply(fun,[second def]) for stmts in tails body repeat stmts.first := apply(fun,[first stmts]) form --% --middleEndExpand: %Form -> %Code middleEndExpand x == x is '%void => '"" -- NIL would have caused havoc elsewhere x is '%false or x is '%nil => 'NIL ident? x and (x' := x has %Rename) => x' atomic? x => x [op,:args] := x ident? op and (fun := getOpcodeExpander op) => middleEndExpand apply(fun,[x]) a := middleEndExpand op b := middleEndExpand args sameObject?(a,op) and sameObject?(b,args) => x [a,:b] --% A function is simple if it looks like a super combinator, and it --% does not use its environment argument. They can be safely replaced --% by more efficient (hopefully) functions. compileTimeBindingOf u == symbol? u => u null(name:= BPINAME u) => keyedSystemError("S2OO0001",[u]) name="Undef" => MOAN "optimiser found unknown function" name getFunctionReplacement name == property(compileTimeBindingOf name,'SPADreplace) ++ remove any replacement info possibly associated with `name'. clearReplacement name == property(name,"SPADreplace") := nil property(name,'%redex) := nil evalAndPrintBackendStmt(lib,stmt) == eval stmt printBackendStmt(lib,stmt) ++ Register the inlinable form of a function. registerFunctionReplacement(db,name,body) == evalAndPrintBackendStmt(dbLibstream db, ["PUT",MKQ name,MKQ "SPADreplace",quoteMinimally body]) ++ Remember the redex form of this function registerRedexForm(db,name,parms,body) == evalAndPrintBackendStmt(dbLibstream db, ["PUT",quote name,quote '%redex,quote ['ILAM,parms,body]]) ++ Retrieve the redex form of the function `name'. redexForm name == property(name,'%redex) ++ Attempt to resolve the indirect reference to a constant form ++ `[spadConstant,$,n]' to a simpler expression resolveConstantForm form == fun := getCapsuleDirectoryEntry third form or return form -- Conservatively preserve object identity and storage -- consumption by not folding non-atomic constant forms. getFunctionReplacement fun isnt ['XLAM,=nil,body] => form atomic? body or isVMConstantForm body => body form mutateArgumentList(args,fun) == for x in tails args repeat arg := first x atomic? arg => nil x.first := apply(fun,[arg]) args inlineDirectCall call == x := redexForm call.op => doInlineCall(call.args,x.absParms,x.absBody) fun := getFunctionReplacement call.op or return call -- the renaming case symbol? fun => call.op := fun NBUTLAST call -- the substitution case. fun is ["XLAM",parms,body] => -- almost constant function parms = nil => body -- identity function too parms is [=body] => first call.args -- conservatively approximate eager semantics every?(function sideEffectFree?,call.args) => -- alpha rename before substitution. newparms := [gensym() for p in parms] body := applySubst(pairList(parms,newparms),body) applySubst!(pairList(newparms,call.args),body) -- a non-side effect free argument used exactly once is OK. parms is [p] and numOfOccurencesOf(p,body) = 1 => substitute(first call.args,p,body) -- get cute later. call call resolveIndirectCall form == fun := lastNode form fun isnt [['%tref,'$,n]] => form op := getCapsuleDirectoryEntry n or return form form.op := op fun.first := '$ inlineDirectCall form ++ Walk `form' and replace simple functions as appropriate. replaceSimpleFunctions form == atomic? form => form form.op is 'DECLARE => form form.op is '%when => mutateConditionalFormWithUnaryFunction(form,function replaceSimpleFunctions) form.op in '(LET %bind) => mutateBindingFormWithUnaryFunction(form,function replaceSimpleFunctions) form is ['spadConstant,'$,.] => resolveConstantForm form -- process argument first. mutateArgumentList(form.args,function replaceSimpleFunctions) form.op is 'SPADCALL => resolveIndirectCall form -- see if we know something about this function. [fun,:args] := form symbol? fun => inlineDirectCall form not cons? fun => form form.first := replaceSimpleFunctions fun form ++ We are processing a function definition with parameter list `vars' ++ and body given by `body'. If `body' is a forwarding function call, ++ return the target function. Otherwise, return nil. forwardingCall?(vars,body) == vars is [:vars',.] and body is [fun,: =vars'] and ident? fun => fun nil ++ Return true if `form' has a linear usage of all variables in `vars'. usesVariablesLinearly?(form,vars) == atomic? form => true form.op is '%when => and/[sideEffectFree? p and usesVariablesLinearly?(c,vars) for [p,c] in form.args] and/[numOfOccurencesOf(var,form) < 2 for var in vars] ++ List of builtin operators we should not attempt to promote ++ to inlinable status. $NonExpandableOperators == '(%store %LET SPADCALL %bind LET) ++ We are processing a function definition with parameter list `vars' ++ and body given by `body'. If `body' is a form that can be inlined, ++ then return the inline form. Otherwise, return nil. expandableDefinition?(vars,body) == expand? := -- We definitely don't want to expand a form that uses -- the domain of computation environment. vars isnt [:vars',env] or usesVariable?(body,env) => false -- Constants are currently implemented as niladic functions, and -- we want to avoid disturbing object identity, so we rule -- out use of side-effect full operators. -- FIXME: This should be done only for constant creators. null vars' => sideEffectFree? body atomic? body => true [op,:args] := body not ident? op or symbolMember?(op,$NonExpandableOperators) => false every?(function atomic?,args) or semiSimpleRelativeTo?(body,$simpleVMoperators) => usesVariablesLinearly?(body,vars') false expand? => body is [fun,: =vars'] and symbol? fun => fun ['XLAM,vars',body] nil ++ A list of routines for diagnostic reports. These functions, in an ++ abstract sense, have type: forall T: Type . String -> T, so they ++ can be used in T-returning functions, for any T. $coreDiagnosticFunctions == '(error userError systemError) almostPure? x == ops := [:$coreDiagnosticFunctions,:$VMsideEffectFreeOperators] semiSimpleRelativeTo?(x,ops) ++ `defs' is a list of function definitions from the current domain. ++ Walk that list and replace references to unconditional operations ++ with their corresponding linkage names. foldExportedFunctionReferences(db,defs) == for fun in defs repeat fun isnt [name,lamex] => nil getFunctionReplacement name => nil lamex isnt ['%lambda,vars,body] => nil body := replaceSimpleFunctions body form := expandableDefinition?(vars,body) => registerFunctionReplacement(db,name,form) second(fun) := ["LAMBDA",vars,["DECLARE",["IGNORE",last vars]],body] if almostPure? body then registerRedexForm(db,name,vars,body) lamex.absBody := body defs ++ record optimizations permitted at level `level'. setCompilerOptimizations level == level = nil => nil integer? level => if level = 0 then -- explicit request for no optimization. $optProclaim := false $optReplaceSimpleFunctions := false if level > 0 then $optProclaim := true $optReplaceSimpleFunctions := true if level > 1 then $optExportedFunctionReference := true if level > 2 then $optimizeRep := true coreError '"unknown optimization level request" --% Lisp backend support. ++ Proclaim the type of the capsule function `op' with signature `sig'. ++ Note that all capsule functions take an additional argument ++ standing for the domain of computation object. proclaimCapsuleFunction(db,op,sig) == printBackendStmt(dbLibstream db, ["DECLAIM",["FTYPE", ["FUNCTION",[:[vmType first d for d in tails rest sig],"%Shell"], vmType first sig],op]]) where vmType d == $subdomain and d = "$" => -- We want accurate approximation for subdomains/superdomains -- that are specialized and known to the VM. (m := getVMType normalize $functorForm) = "%Thing" => getVMType normalize "$" m getVMType normalize d normalize(d,top? == true) == d = "$" => not top? => "*" -- If the representation is explicitly stated, use it. That way -- we optimize abstractions just as well as builtins. r := getRepresentation $e => normalize(r,top?) -- Cope with old-style constructor definition $functorForm isnt [.,:.] => [$functorForm] normalize($functorForm,top?) d isnt [.,:.] => top? => "%Thing" getmode(d,$e) => "*" d [first d, :[normalize(first args,false) for args in tails rest d]] ++ Lisp back end compiler for %slam forms [namd,args,:body]. ++ A %slam form is one that is `functional' in the sense that ++ its values are cached, so that equal lists of argument values ++ yield equal values. The arguments-value pairs are stored ++ in a hash table. This backend compiler is used to compile constructors. backendCompileSPADSLAM: (%Database,%Symbol,%List %Symbol,%Code) -> %Symbol backendCompileSPADSLAM(db,name,args,body) == al := mkCacheName name -- global name for the cache hash table. auxfn := makeWorkerName name -- name of the worker function. g2 := gensym() -- local name for the cache value. u := args = nil => [nil,[auxfn]] args is [g] => [g,[auxfn,g]] [gensym(),[auxfn,:args]] key := first u -- key into the instantiation table cache app := second u -- code to compute value code := args = nil => ["COND",[al],[true,["SETQ",al,app]]] [binder,:inits] := args is [.] => ["LET",[g2,["assoc",key,al]]] ["LET*",[key,["LIST",:args]],[g2,["assoc",key,al]]] [binder,inits, ["COND", [g2,["CDR",g2]], [true, ["PROGN",["SETQ",g2,app], ["SETQ",al,["cons5",["CONS",key,g2],al]],g2]]]] -- define the global cache. evalAndPrintBackendStmt(dbLibstream db,['DEFPARAMETER,al,nil]) assembleCode [auxfn,["LAMBDA",args,:body]] assembleCode [name,["LAMBDA",args,code]] backendCompile2: (%Maybe %Database,%Code) -> %Symbol backendCompile2 (db,code) == code isnt [name,[type,args,:body]] => systemError ['"parenthesis error in: ", code] type = '%slam => backendCompileSPADSLAM(db,name,args,body) assembleCode [name,[type,args,:body]] ++ returns all fuild variables contained in `x'. Fuild variables are ++ identifiers starting with '$', except domain variable names. backendFluidize x == ident? x and x ~= "$" and x ~= "$$" and stringChar(symbolName x,0) = char "$" and not digit? stringChar(symbolName x,1) => x atomic? x => nil first x is "FLUID" => second x a := backendFluidize first x b := backendFluidize rest x a = nil => b [a,:b] $FluidVars := [] $LocalVars := [] $SpecialVars := [] ++ push `x' into the list of local variables. pushLocalVariable: %Symbol -> %List %Symbol pushLocalVariable x == p := symbolName x x ~= "$" and stringChar(p,0) = char "$" and stringChar(p,1) ~= char "," and not digit? stringChar(p,1) => nil PUSH(x,$LocalVars) isLispSpecialVariable x == s := symbolName x stringChar(s,0) = char "$" and #s > 1 and alphabetic? stringChar(s,1) and not readOnly? x noteSpecialVariable x == $SpecialVars := insert(x,$SpecialVars) --% --% Compile Time operation lookup for the benefit of domain inlining. --% ++ If `x' is a formal map variable, returns its position. ++ Otherwise return nil. formal?: %Symbol -> %Maybe %Short formal? x == or/[i for i in 0.. for y in $FormalMapVariableList | symbolEq?(x,y)] ++ Expand the form at position `slot' in the domain template `shell' ++ with argument list `args'. expandFormTemplate(shell,args,slot) == integer? slot => slot = 0 => "$" slot = 2 => "$$" expandFormTemplate(shell,args,vectorRef(shell,slot)) slot isnt [.,:.] => slot slot is ["local",parm] and (n := formal? parm) => args.n -- FIXME: we should probably expand with dual signature slot is ['%eval,val] => val slot is ['QUOTE,val] => string? val => val slot [expandFormTemplate(shell,args,i) for i in slot] ++ Compare the form at `slot' in the domain templare `shell' ++ for equality with `form'. equalFormTemplate(shell,args,slot,form) == integer? slot => slot = 0 => form = "$" slot = 2 => form = "$$" equalFormTemplate(shell,args,vectorRef(shell,slot),form) slot is ["local",parm] and (n := formal? parm) => equalFormTemplate(shell,args,args.n,form) slot is ['%eval,val] => form = val slot is ['QUOTE,val] => string? val or symbol? val or integer? val => val = form slot = form slot isnt [.,:.] or form isnt [.,:.] => form = slot #slot ~= #form => false and/[equalFormTemplate(shell,args,i,x) for i in slot for x in form] ++ Subroutine of lookupDefiningFunction. ++ Return the location of function templates with signature `sig', ++ descriptor address in the range [start,end), in the domain ++ template `shell' whose local reference vector is `funDesc'. ++ Return value: ++ nil => function not defined by `shell'. ++ "ambiguous" => too many candidates ++ => slot number of unique matching function. getFunctionTemplate(sig,start,end,shell,args,funDesc) == nargs := #rest sig loc := nil -- candidate locations while loc ~= "ambiguous" and start < end repeat n := arrayRef(funDesc,start) -- arity of current operator PROGN -- Skip if arity mismatch i := start n ~= nargs => nil -- We are not interested in predicates, at this point. -- Skip if this operator's signature does not match i := i + 2 or/[not equalFormTemplate(shell,args,funDesc.k,t) for k in i.. for t in sig] => nil -- Grab the location of this match loc := integer? loc => "ambiguous" arrayRef(funDesc,i + n + 1) start := start + n + 4 loc ++ Subroutine of lookupDefiningFunction. lookupInheritedDefiningFunction(op,sig,shell,args,slot) == dom := expandFormTemplate(shell,args,slot) dom isnt [.,:.] or dom is ["local",:.] => nil lookupDefiningFunction(op,sig,dom) ++ Return the name of the function definition that explicitly implements ++ the operation `op' with signature `sig' in the domain of ++ computation `dc'. Otherwise, return nil. ++ Note: Only a function defined by the domain template, or its add-chains, ++ and that is unambiguous is returned. In particular, this ++ function defaulting packages. lookupDefiningFunction(op,sig,dc) == -- 1. Read domain information, if available. Silently give up if -- the constructor is just not there [ctor,:args] := dc db := constructorDB ctor or return nil -- we only deal with instantiations loadDBIfCan db dbTemplate db = nil => nil -- incomplete functor -- 1.1. Niladic constructors don't need approximation. -- FIXME: However, there may be cylic dependencies -- such as AN ~> IAN ~> EXPR INT ~> AN that prevents -- us from full evaluation. args = nil and symbolMember?(ctor,$SystemInlinableConstructorNames) => compiledLookup(op,sig,dc) -- 1.2. Don't look into defaulting package isDefaultPackageName ctor => nil infovec := property(ctor,'infovec) or return nil -- 1.3. We need information about the original domain template shell := dbTemplate db -- domain template opTable := second infovec -- operator-code table opTableLength := #opTable forgetful := dbLookupFunction db is 'lookupIncomplete -- 2. Get the address range of op's descriptor set [.,.,.,:funDesc] := fourth infovec index := getOpCode(op, opTable, opTableLength - 1) -- 2.1. For a forgetful functor, try the add chain index = nil => forgetful and lookupInheritedDefiningFunction(op,sig,shell,args,5) -- 2.2. The operation is either defined here, or is available -- from category package defaults. limit := index + 2 < opTableLength => vectorRef(opTable,index + 2) #funDesc -- 3. Locate the descriptor with matching signature loc := getFunctionTemplate(sig,opTable.index,limit,shell,args,funDesc) -- 4. Look into the add-chain if necessary loc = nil => lookupInheritedDefiningFunction(op,sig,shell,args,domainRef(shell,5)) -- 5. Give up if the operation is overloaded on semantics predicates. loc is 'ambiguous => nil -- 6. We have a location to a function descriptor. fun := domainRef(shell,loc) -- 6.1. A constant producing functions? fun is [.,'%constant,[.,['%function,fun'],.]] => fun' -- 6.2. An inherited function? fun is [idx,:.] => not integer? idx => nil -- a UFO? loc := arrayRef(funDesc,idx + 1) if loc = 0 then loc := 5 domainRef(shell,loc) = nil => nil lookupInheritedDefiningFunction(op,sig,shell,args,shell.loc) -- 6.3. Whatever. fun ++ flag parameters needs to be made atomic, otherwise Lisp is confused. ++ We try our best to preserve ++ Note that we don't need substitution in the body because flag ++ parameters are never used in the body. cleanParameterList! parms == count := 0 for vars in tails parms repeat v := first vars ident? v => nil t := nil until not symbolMember?(t,parms) repeat count := count + 1 t := makeSymbol strconc('"T",toString count) vars.first := t parms --% --% Other compiler artifact support --% moveLibdirByCopy lib == checkMkdir libDirname lib for src in directoryEntries libStationaryDirname lib repeat dst := makeFilePath(directory <- relativeDirname libDirname lib, name <- filePathName src, type <- filePathType src) copyFile(filePathString src,filePathString dst) removeFile libStationaryDirname lib = 0 => libDirname lib systemError ['"Could not remove stationary directory", :bright libStationaryDirname lib]