-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd. -- All rights reserved. -- Copyright (C) 2007-2011, 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 clearReplacement: %Symbol -> %Thing replaceSimpleFunctions: %Form -> %Form foldExportedFunctionReferences: %List %Form -> %List %Form diagnoseUnknownType: (%Mode,%Env) -> %Form declareUnusedParameters: %Code -> %Code registerFunctionReplacement: (%Symbol,%Form) -> %Thing getSuccessEnvironment: (%Form,%Env) -> %Env getInverseEnvironment: (%Form,%Env) -> %Env giveVariableSomeValue: (%Symbol,%Mode,%Env) -> %Env -- functor data manipulation dbInfovec: %Constructor -> %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) --% $SetCategory == '(SetCategory) --% dbInfovec name == getConstructorKindFromDB name is "category" => nil loadLibIfNotLoaded(name) u := property(name,'infovec) => u nil --% ++ 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 usedSymbol?(p,body)] 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 QVSIZE 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) SAY("$m:= ",$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 := symbolLassoc("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 ["%LET",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 TERPRI() 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 symbolLassoc("modemap",rest z) repeat TERPRI() 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 := symbolLassoc("modemap",rest z)) repeat listOfOperatorsSeenSoFar:= [first z,:listOfOperatorsSeenSoFar] TERPRI() 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) => (symbolLassoc("value",pl) or symbolLassoc("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 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,'%form,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 --$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="%LET" => ident? y => (setAssignment [x]; y) (setAssignment [["%LET",g:= genVariable(),:l],["%LET",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 --appendOver x == "append"/x 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 INTERNL strconc('"#D",STRINGIMAGE $Index) genVariable() == INTERNL strconc('"#G",STRINGIMAGE ($genSDVar:= $genSDVar+1)) genSomeVariable() == INTERNL strconc('"##",STRINGIMAGE ($genSDVar:= $genSDVar+1)) listOfIdentifiersIn x == ident? x => [x] x is [op,:l] => removeDuplicates ("append"/[listOfIdentifiersIn y for y in l]) nil mapInto(x,fn) == [FUNCALL(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 y isnt [.,:.] => 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 TERPRI() 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.") TERPRI() nil extendsCategoryForm(domain,form,form') == --is domain of category form also of category form'? --domain is only used for SubsetCategory resolution. --and ensuring that X being a Ring means that it --satisfies (Algebra X) form=form' => true form=$Category => nil form' is ["Join",:l] => and/[extendsCategoryForm(domain,form,x) for x in l] form' is ["CATEGORY",.,:l] => and/[extendsCategoryForm(domain,form,x) for x in l] form' is ["SubsetCategory",cat,dom] => extendsCategoryForm(domain,form,cat) and isSubset(domain,dom,$e) form is ["Join",:l] => or/[extendsCategoryForm(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 = $definition => extendsCategoryForm(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(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 -- Are we dealing with an Aldor category? If so use the "has" function ... # formVec = 1 => newHasTest(form,form') listMember?(form',categoryPrincipals formVec) or listMember?(form',substitute(domain,"$",categoryPrincipals formVec)) or (or/ [extendsCategoryForm(domain,substitute(domain,"$",cat),form') for [cat,:.] in categoryAncestors formVec]) nil getmode(x,e) == prop:=getProplist(x,e) u := QLASSQ("value",prop) => u.mode QLASSQ("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 := symbolLassoc("modemap",rest z)) repeat listOfOperatorsSeenSoFar:= [first z,:listOfOperatorsSeenSoFar] displayOpModemaps(first z,modemaps) --% General object traversal functions GCOPY ob == COPY 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 == rest ASSOC(slot,$capsuleDirectory) ++ Update the current capsule directory with entry controlled by ++ predicate `pred'. updateCapsuleDirectory(item,pred) == pred ~= true => nil entry := item is [['$,slot],['CONS,['dispatchFunction,fun],:.],:.] => [slot,:fun] item is [['$,slot],['CONS,'IDENTITY, ['FUNCALL,['dispatchFunction,fun],'$]]] => [slot,:fun] nil entry = nil => 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 := FUNCALL(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 := FUNCALL(fun, second def) for stmts in tails body repeat stmts.first := FUNCALL(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,nil) 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 ++ Register the inlinable form of a function. registerFunctionReplacement(name,body) == LAM_,EVALANDFILEACTQ ["PUT",MKQ name,MKQ "SPADreplace",quoteMinimally body] ++ 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 == 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 and/[sideEffectFree? arg for arg in call.args] => -- alpha rename before substitution. newparms := [gensym() for p in parms] body := applySubst(pairList(parms,newparms),body) applySubst!(pairList(newparms,call.args),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 CONTAINED(env,body) => 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 and/[atomic? x for x in args] or semiSimpleRelativeTo?(body,$simpleVMoperators) => usesVariablesLinearly?(body,vars') false expand? => body is [fun,: =vars'] and symbol? fun => fun ['XLAM,vars',body] nil ++ `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 defs == for fun in defs repeat fun isnt [name,lamex] => nil lamex isnt ["LAM",vars,body] => nil body := replaceSimpleFunctions body form := expandableDefinition?(vars,body) => registerFunctionReplacement(name,form) fun.rest.first := ["LAM",vars,["DECLARE",["IGNORE",last vars]],body] lamex.rest.rest.first := 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(op,sig) == LAM_,EVALANDFILEACTQ ["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 ILAM with `name', formal `args', and `body'. backendCompileILAM: (%Symbol,%List %Symbol, %Code) -> %Symbol backendCompileILAM(name,args,body) == args' := [gensym() for . in 1..#args] body' := applySubst!(pairList(args,args'),body) property(name,'ILAM) := true symbolValue(name) := ["LAMBDA",args',:body'] name $CLOSEDFNS := nil MAKE_-CLOSEDFN_-NAME() == INTERNL($FUNNAME,'"!", STRINGIMAGE # $CLOSEDFNS) backendCompileNEWNAM: %Form -> %Void backendCompileNEWNAM x == atomic? x => nil y := first x y isnt [.,:.] => backendCompileNEWNAM rest x if y is "CLOSEDFN" then u := MAKE_-CLOSEDFN_-NAME() PUSH([u,second x], $CLOSEDFNS) x.first := "FUNCTION" x.rest.first := u backendCompileNEWNAM first x backendCompileNEWNAM rest x ++ 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 ++ as alists. backendCompileSLAM: (%Symbol,%List %Symbol,%Code) -> %Symbol backendCompileSLAM(name,args,body) == al := mkCacheName name -- name of the cache alist. auxfn := INTERNL(name,'";") -- name of the worker function. g1 := gensym() -- name for the parameter. g2 := gensym() -- name for the cache value u := -- body of the stub function null args => [nil,[auxfn]] null rest args => [[g1],[auxfn,g1]] [g1,["APPLX", ["FUNCTION",auxfn], g1]] arg := first u app := second u codePart1 := -- look up the value if it is already there args ~= nil => [["SETQ", g2, ["assoc",g1,al]], ["CDR",g2]] [al] codePart2 := -- otherwise, compute it. args ~= nil => [true,["SETQ",g2,app],["SETQ",al,[[g1,:g2],:al]],g2] [true,["SETQ",al,app]] lamex := ["LAM",arg,["PROG",[g2], ["RETURN",["COND",codePart1,codePart2]]]] symbolValue(al) := nil -- clear the cache -- compile the worker function, first. u := [auxfn,["LAMBDA",args,:body]] COMP370 [u] -- then compile the original function. u := [name,lamex] if $PrettyPrint then PRETTYPRINT u COMP370 [u] name ++ Same as backendCompileSLAM, except that the cache is a hash ++ table. This backend compiler is used to compile constructors. backendCompileSPADSLAM: (%Symbol,%List %Symbol,%Code) -> %Symbol backendCompileSPADSLAM(name,args,body) == al := mkCacheName name -- name of the cache hash table. auxfn := INTERNL(name,'";") -- name of the worker function. g1 := gensym() -- name of the worker function parameter g2 := gensym() -- name for the cache value. u := null args => [nil,nil,[auxfn]] null rest args => [[g1],["devaluate",g1],[auxfn,g1]] [g1,["devaluateList",g1],["APPLY",["FUNCTION",auxfn],g1]] arg := first u -- parameter list argtran := second u -- devaluate argument app := third u -- code to compute value code := args = nil => ["COND",[al],[true,["SETQ",al,app]]] ["LET",[[g2,["assoc",argtran,al]]], ["COND", [g2,["CDR",g2]], [true, ["PROGN",["SETQ",g2,app], ["SETQ",al,["cons5",["CONS",argtran, g2],al]],g2]]]] lamex := ["LAM",arg,code] SETANDFILE(al,nil) -- define the global cache. -- compile the worker function first. u := [auxfn,["LAMBDA",args,:body]] if $PrettyPrint then PRETTYPRINT u COMP370 [u] -- then compiler the stub (which is the user-visible constructor). u := [name,lamex] if $PrettyPrint then PRETTYPRINT u COMP370 [u] name backendCompile2: %Code -> %Symbol backendCompile2 code == code isnt [name,[type,args,:body],:junk] or junk ~= nil => systemError ['"parenthesis error in: ", code] type = "SLAM" => backendCompileSLAM(name,args,body) QLASSQ(name,$clamList) => compClam(name,args,body,$clamList) type = "SPADSLAM" => backendCompileSPADSLAM(name,args,body) type = "ILAM" => backendCompileILAM(name,args,body) body := [name,[type,args,:body]] if $PrettyPrint then PRETTYPRINT body if not $COMPILE then SAY '"No Compilation" else COMP370 [body] name ++ 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) --% ++ Replace every middle end sub-forms in `x' with Lisp code. massageBackendCode: %Code -> %Void massageBackendCode x == ident? x and isLispSpecialVariable x => noteSpecialVariable x atomic? x => nil -- temporarily have TRACELET report MAKEPROPs. if (u := first x) = "MAKEPROP" and $TRACELETFLAG then x.first := "MAKEPROP-SAY" u in '(DCQ RELET PRELET SPADLET SETQ %LET) => if u isnt 'DCQ and u isnt 'SETQ then append!(x,$FUNNAME__TAIL) x.first := "LETT" massageBackendCode CDDR x if not (u in '(SETQ RELET)) then ident? second x => pushLocalVariable second x second x is ["FLUID",:.] => PUSH(CADADR x, $FluidVars) x.rest.first := CADADR x for v in LISTOFATOMS second x repeat pushLocalVariable v -- Even if user used Lisp-level instructions to assign to -- this variable, we still want to note that it is a Lisp-level -- special variable. u is 'SETQ and isLispSpecialVariable second x => noteSpecialVariable second x ident? u and GET(u,"ILAM") ~= nil => x.first := eval u massageBackendCode x u in '(LET LET_*) => oldVars := $LocalVars vars := nil for [var,init] in second x repeat massageBackendCode init $LocalVars := [var,:$LocalVars] vars := [var,:vars] massageBackendCode x.rest.rest newVars := setDifference($LocalVars,setUnion(vars,oldVars)) $LocalVars := setUnion(oldVars,newVars) u in '(PROG LAMBDA) => newBindings := [] for y in second x repeat not symbolMember?(y,$LocalVars) => $LocalVars := [y,:$LocalVars] newBindings := [y,:newBindings] res := massageBackendCode CDDR x $LocalVars := REMOVE_-IF(function (y +-> y in newBindings), $LocalVars) [u,second x,:res] u = "DECLARE" => nil -- there is nothing to do convert there massageBackendCode u massageBackendCode rest x skipDeclarations: %List %Code -> %List %Code skipDeclarations form == while first form is ["DECLARE",:.] repeat form := rest form form ++ return the last node containing a declaration in form, otherwise nil. lastDeclarationNode: %List %Code -> %List %Code lastDeclarationNode form == while second form is ["DECLARE",:.] repeat form := rest form first form is ["DECLARE",:.] => form nil declareGlobalVariables: %List %Symbol -> %Code declareGlobalVariables vars == ["DECLARE",["SPECIAL",:vars]] ++ Return true if `form' contains an EXIT-form that matches ++ the parent node of `form'. matchingEXIT form == atomic? form or form.op is 'SEQ => false form.op is 'EXIT => true or/[matchingEXIT x for x in form] simplifySEQ form == atomic? form => form form is ["SEQ",[op,a]] and op in '(EXIT RETURN) => simplifySEQ a form is ['SEQ,s] and not matchingEXIT s => simplifySEQ s for stmts in tails form repeat stmts.first := simplifySEQ first stmts form ++ Return true if the Lisp `form' has a `RETURN' form ++ that needs to be enclosed in a `PROG' form. needsPROG? form == atomic? form => false op := form.op op is 'RETURN => true op in '(LOOP PROG) => false form is ['BLOCK,=nil,:.] => false or/[needsPROG? x for x in form] ++ We are processing the complete `body' of a function definition. ++ If this body is a multiway test, there is no need to have ++ a RETURN-FROM operator in the immediate consequence of a branch. removeToplevelRETURN_-FROM body == if body is [['COND,:stmts]] then for stmt in stmts repeat stmt is [.,['RETURN_-FROM,.,expr]] => second(stmt) := expr body ++ Generate Lisp code by lowering middle end defining form `x'. ++ x has the strucrure: transformToBackendCode: %Form -> %Code transformToBackendCode x == $FluidVars: local := nil $LocalVars: local := nil $SpecialVars: local := nil x := middleEndExpand x massageBackendCode CDDR x body := skipDeclarations CDDR x -- Make it explicitly a sequence of statements if it is not a one liner. body := body is [stmt] and (stmt isnt [.,:.] or stmt.op in '(SEQ LET LET_*) or not CONTAINED("EXIT",stmt)) => body [simplifySEQ ["SEQ",:body]] $FluidVars := removeDuplicates reverse! $FluidVars $LocalVars := S_-(S_-(removeDuplicates reverse! $LocalVars,$FluidVars), LISTOFATOMS second x) lvars := [:$FluidVars,:$LocalVars] fluids := S_+($FluidVars,$SpecialVars) body := fluids ~= nil => lvars ~= nil or needsPROG? body => [["PROG",lvars,declareGlobalVariables fluids, ["RETURN",:body]]] body is [[op,inits,:body']] and op in '(LET LET_*) and $FluidVars ~= nil => [declareGlobalVariables $SpecialVars, [op,inits,declareGlobalVariables fluids,:body']] [declareGlobalVariables fluids,:body] lvars ~= nil or needsPROG? body => [["PROG",lvars,["RETURN",:body]]] removeToplevelRETURN_-FROM body -- add reference parameters to the list of special variables. fluids := S_+(backendFluidize second x, $SpecialVars) lastdecl := lastDeclarationNode rest x if lastdecl = nil then x.rest.rest := body else null fluids => lastdecl.rest := body lastdecl.rest := [declareGlobalVariables fluids,:body] x backendCompile1 x == fname := first x $FUNNAME: local := fname $FUNNAME__TAIL: local := [fname] lamex := second x $CLOSEDFNS: local := [] lamex := transformToBackendCode lamex backendCompileNEWNAM lamex -- Note that category constructors are evaluated before they -- their compiled, so this noise is not very helpful. if $verbose and FBOUNDP fname then FORMAT(true,'"~&~%;;; *** ~S REDEFINED~%",fname) [[fname,lamex],:$CLOSEDFNS] backendCompile l == [backendCompile2 f2 for f2 in [:backendCompile1(f1) for f1 in l]] compileFileQuietly path == quietlyIfInteractive COMPILE_-FILE path ++ Subroutine of compileConstructor1. Called to compile the body ++ of a category constructor definition. compAndDefine l == _*COMP370_-APPLY_* := "PRINT-AND-EVAL-DEFUN" backendCompile l ++ Subroutine of compileInteractive. compQuietly fn == _*COMP370_-APPLY_* := $InteractiveMode => $compileDontDefineFunctions => "COMPILE-DEFUN" "EVAL-DEFUN" "PRINT-DEFUN" quietlyIfInteractive backendCompile fn compileQuietly fn == _*COMP370_-APPLY_* := $InteractiveMode => $compileDontDefineFunctions => "COMPILE-DEFUN" "EVAL-DEFUN" "PRINT-DEFUN" quietlyIfInteractive COMP370 fn --% --% Compile Time operation lookup for the benefit of domain inlining. --% ++ If `x' is a formal map variable, returns its position. ++ Otherwise return nil. isFormal: %Symbol -> %Maybe %Short isFormal x == POSITION(x,$FormalMapVariableList,KEYWORD::TEST, function EQ) ++ 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 := isFormal parm) => args.n -- FIXME: we should probably expand with dual signature slot is ["NRTEVAL",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 := isFormal parm) => equalFormTemplate(shell,args,args.n,form) slot is ["NTREVAL",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 := 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" 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 loadLibIfNotLoaded ctor property(ctor,'%incomplete) => nil -- 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 := first infovec -- domain template opTable := second infovec -- operator-code table opTableLength := #opTable forgetful := infovec.4 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 => 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,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 := shell.loc -- 6.1. A constant producing functions? fun is [.,.,[.,['dispatchFunction,fun'],.]] => fun' -- 6.2. An inherited function? fun is [idx,:.] => not integer? idx => nil -- a UFO? loc := funDesc.(idx + 1) if loc = 0 then loc := 5 shell.loc = nil => nil lookupInheritedDefiningFunction(op,sig,shell,args,shell.loc) -- 6.3. Whatever. fun