-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd. -- All rights reserved. -- Copyright (C) 2007-2009, 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 nruncomp import g_-error import database import modemap namespace BOOT module define where compDefine: (%Form,%Mode,%Env) -> %Maybe %Triple compSubDomain: (%Form,%Mode,%Env) -> %Maybe %Triple compCapsule: (%Form, %Mode, %Env) -> %Maybe %Triple compJoin: (%Form,%Mode,%Env) -> %Maybe %Triple compAdd: (%Form, %Mode, %Env) -> %Maybe %Triple compCategory: (%Form,%Mode,%Env) -> %Maybe %Triple --% NRTPARSE := false $newCompCompare := false ++ List of mutable domains. $mutableDomains := nil ++ True if the current constructor being compiled instantiates ++ mutable domains or packages. Default is `false'. $mutableDomain := false ++ when non nil, holds the declaration number of a function in a capsule. $suffix := nil $doNotCompileJustPrint := false ++ stack of pending capsule function definitions. $capsuleFunctionStack := [] $functionStats := nil $functorStats := nil $lisplibCategory := nil $lisplibAncestors := nil $lisplibAbbreviation := nil $CheckVectorList := [] $setelt := nil $pairlis := [] $functorTarget := nil $condAlist := [] $uncondAlist := [] $NRTslot1PredicateList := [] $NRTattributeAlist := [] $NRTslot1Info := nil $NRTdeltaListComp := [] $NRTdomainFormList := [] $template := nil $signature := nil $isOpPackageName := false $lisplibCategoriesExtended := [] $lookupFunction := nil $byteAddress := nil $byteVec := nil $lisplibSlot1 := nil $sigAlist := [] $predAlist := [] $argumentConditionList := [] $finalEnv := nil $initCapsuleErrorCount := nil $CapsuleModemapFrame := nil $CapsuleDomainsInScope := nil $signatureOfForm := nil $addFormLhs := nil $lisplibSuperDomain := nil $sigList := [] $atList := [] --% compDefineAddSignature: (%Form,%Signature,%Env) -> %Env DomainSubstitutionFunction: (%List,%Form) -> %Form --% ++ List of operations defined in a given capsule ++ Each item on this list is of the form ++ (op sig pred) ++ where ++ op: name of the operation ++ sig: signature of the operation ++ pred: scope predicate of the operation. $capsuleFunctions := nil ++ record that the operation `op' with signature `sig' and predicate ++ `pred' is defined in the current capsule of the current domain ++ being compiled. noteCapsuleFunctionDefinition(op,sig,pred) == member([op,sig,pred],$capsuleFunctions) => stackAndThrow('"redefinition of %1b: %2 %3", [op,formatUnabbreviated ["Mapping",:sig],formatIf pred]) $capsuleFunctions := [[op,sig,pred],:$capsuleFunctions] ++ Clear the list of functions defined in the last domain capsule. clearCapsuleFunctionTable() == $capsuleFunctions := nil ++ List of exports (paireed with scope predicate) declared in ++ the category of the currend domain or package. ++ Note: for category packages, this list is nil. $exports := nil noteExport(form,pred) == -- don't recheck category package exports; we just check -- them when defining the category. Plus, we might actually -- get indirect duplicates, which is OK. $insideCategoryPackageIfTrue => nil member([form,pred],$exports) => stackAndThrow('"redeclaration of %1 %2", [form,formatIf pred]) $exports := [[form,pred],:$exports] clearExportsTable() == $exports := nil makePredicate l == null l => true MKPF(l,"and") --% FUNCTIONS WHICH MUNCH ON == STATEMENTS compDefine(form,m,e) == $macroIfTrue: local := false compDefine1(form,m,e) ++ Activate synthetized pair concretization and abstraction ++ view morphisms for domains. insertViewMorphisms: (%Mode,$Env) -> %Env insertViewMorphisms(t,e) == $useRepresentationHack => e g := GENSYM() repType := ["Mapping",t,"$"] perType := ["Mapping","$",t] e := put("rep","value",[["XLAM",[g],g],repType,nil],e) put("per","value",[["XLAM",[g],g],perType,nil],e) ++ We are about to process the body of a capsule. Check the form of ++ `Rep' definition, and whether it is appropriate to activate the ++ implicitly generated morphisms ++ per: Rep -> % ++ rep: % -> Rep ++ as local inline functions. checkRepresentation: (%Form,%List,%Env) -> %Env checkRepresentation(addForm,body,env) == domainRep := nil hasAssignRep := false -- assume code does not assign to Rep. viewFuns := nil null body => env -- Don't be too hard on nothing. -- Locate possible Rep definition for [stmt,:.] in tails body repeat stmt is ["%LET","Rep",val] => domainRep ^= nil => stackAndThrow('"You cannot assign to constant domain %1b",["Rep"]) if addForm = val then stackWarning('"OpenAxiom suggests removing assignment to %1b",["Rep"]) else if addForm ^= nil then stackWarning('"%1b differs from the base domain",["Rep"]) return hasAssignRep := true stmt is ["MDEF",["Rep",:.],:.] => stackWarning('"Consider using == definition for %1b",["Rep"]) return hasAssignRep := true stmt is ["IF",.,:l] or stmt is ["SEQ",:l] or stmt is ["exit",:l] => checkRepresentation(nil,l,env) stmt isnt ["DEF",[op,:args],sig,.,val] => nil -- skip for now. op in '(rep per) => domainRep ^= nil => stackAndThrow('"You cannot define implicitly generated %1b",[op]) viewFuns := [op,:viewFuns] op ^= "Rep" => nil -- we are only interested in Rep definition domainRep := val viewFuns ^= nil => stackAndThrow('"You cannot define both %1b and %2b",["Rep",:viewFuns]) -- A package has no "%". $functorKind = "package" => stackAndThrow('"You cannot define %1b in a package",["Rep"]) -- It is a mistake to define Rep in category defaults $insideCategoryPackageIfTrue => stackAndThrow('"You cannot define %1b in category defaults",["Rep"]) if args ^= nil then stackAndThrow('"%1b does take arguments",["Rep"]) if first sig ^= nil then stackAndThrow('"You cannot specify type for %1b",["Rep"]) -- Now, trick the rest of the compiler into believing that -- `Rep' was defined the Old Way, for lookup purpose. rplac(first stmt,"%LET") rplac(rest stmt,["Rep",domainRep]) $useRepresentationHack := false -- Don't confuse `Rep' and `%'. -- Shall we perform the dirty tricks? if hasAssignRep then $useRepresentationHack := true -- Domain extensions with no explicit Rep definition have the -- the base domain as representation (at least operationally). else if null domainRep and addForm ^= nil then if $functorKind = "domain" and addForm isnt ["%Comma",:.] then domainRep := addForm is ["SubDomain",dom,.] => dom addForm base := compForMode(domainRep,$EmptyMode,env) or stackAndThrow('"1b is not a domain",[domainRep]) $useRepresentationHack := false env := insertViewMorphisms(base.expr,env) -- ??? Maybe we should also make Rep available as macro. env compDefine1: (%Form,%Mode,%Env) -> %Maybe %Triple compDefine1(form,m,e) == $insideExpressionIfTrue: local:= false --1. decompose after macro-expanding form ['DEF,lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e) $insideWhereIfTrue and isMacro(form,e) and (m=$EmptyMode or m=$NoValueMode) => [lhs,m,put(first lhs,'macro,rhs,e)] null signature.target and not MEMQ(KAR rhs,$BuiltinConstructorNames) and (sig:= getSignatureFromMode(lhs,e)) => -- here signature of lhs is determined by a previous declaration compDefine1(['DEF,lhs,[first sig,:rest signature],specialCases,rhs],m,e) if signature.target=$Category then $insideCategoryIfTrue:= true --?? following 3 lines seem bogus, BMT 6/23/93 --? if signature.target is ['Mapping,:map] then --? signature:= map --? form:= ['DEF,lhs,signature,specialCases,rhs] -- RDJ (11/83): when argument and return types are all declared, -- or arguments have types declared in the environment, -- and there is no existing modemap for this signature, add -- the modemap by a declaration, then strip off declarations and recurse e := compDefineAddSignature(lhs,signature,e) -- 2. if signature list for arguments is not empty, replace ('DEF,..) by -- ('where,('DEF,..),..) with an empty signature list; -- otherwise, fill in all NILs in the signature or/[x ^= nil for x in rest signature] => compDefWhereClause(form,m,e) signature.target=$Category => compDefineCategory(form,m,e,nil,$formalArgList) isDomainForm(rhs,e) and not $insideFunctorIfTrue => if null signature.target then signature:= [getTargetFromRhs(lhs,rhs,giveFormalParametersValues(rest lhs,e)),: rest signature] rhs:= addEmptyCapsuleIfNecessary(signature.target,rhs) compDefineFunctor(['DEF,lhs,signature,specialCases,rhs],m,e,nil, $formalArgList) null $form => stackAndThrow ['"bad == form ",form] newPrefix:= $prefix => INTERN STRCONC(encodeItem $prefix,'",",encodeItem $op) getAbbreviation($op,#rest $form) compDefineCapsuleFunction(form,m,e,newPrefix,$formalArgList) compDefineAddSignature([op,:argl],signature,e) == (sig:= hasFullSignature(argl,signature,e)) and not assoc(['$,:sig],LASSOC('modemap,getProplist(op,e))) => declForm:= [":",[op,:[[":",x,m] for x in argl for m in rest sig]],first signature] [.,.,e]:= comp(declForm,$EmptyMode,e) e e hasFullSignature(argl,[target,:ml],e) == target => u:= [m or get(x,"mode",e) or return 'failed for x in argl for m in ml] u^='failed => [target,:u] addEmptyCapsuleIfNecessary: (%Form,%Form) -> %Form addEmptyCapsuleIfNecessary(target,rhs) == MEMQ(KAR rhs,$SpecialDomainNames) => rhs ['add,rhs,['CAPSULE]] getTargetFromRhs: (%Form, %Form, %Env) -> %Form getTargetFromRhs(lhs,rhs,e) == --undeclared target mode obtained from rhs expression rhs is ['CAPSULE,:.] => stackSemanticError(['"target category of ",lhs, '" cannot be determined from definition"],nil) rhs is ['SubDomain,D,:.] => getTargetFromRhs(lhs,D,e) rhs is ['add,D,['CAPSULE,:.]] => getTargetFromRhs(lhs,D,e) rhs is ['Record,:l] => ['RecordCategory,:l] rhs is ['Union,:l] => ['UnionCategory,:l] rhs is ['List,:l] => ['ListCategory,:l] rhs is ['Vector,:l] => ['VectorCategory,:l] [.,target,.]:= compOrCroak(rhs,$EmptyMode,e) target giveFormalParametersValues(argl,e) == for x in argl repeat e:= put(x,'value,[genSomeVariable(),get(x,'mode,e),nil],e) e macroExpandInPlace: (%Form,%Env) -> %Form macroExpandInPlace(x,e) == y:= macroExpand(x,e) atom x or atom y => y RPLACA(x,first y) RPLACD(x,rest y) x macroExpand: (%Form,%Env) -> %Form macroExpand(x,e) == --not worked out yet atom x => (u:= get(x,'macro,e) => macroExpand(u,e); x) x is ['DEF,lhs,sig,spCases,rhs] => ['DEF,macroExpand(lhs,e),macroExpandList(sig,e),macroExpandList(spCases,e), macroExpand(rhs,e)] macroExpandList(x,e) macroExpandList(l,e) == -- macros should override niladic props (l is [name]) and IDENTP name and niladicConstructorFromDB name and (u := get(name, 'macro, e)) => macroExpand(u,e) [macroExpand(x,e) for x in l] --% constructor evaluation -- The following functions are used by the compiler but are modified -- here for use with new LISPLIB scheme mkEvalableCategoryForm c == c is [op,:argl] => op="Join" => ["Join",:[mkEvalableCategoryForm x for x in argl]] op is "DomainSubstitutionMacro" => --$extraParms :local --catobj := EVAL c -- DomainSubstitutionFunction makes $extraParms --mkEvalableCategoryForm sublisV($extraParms, catobj) mkEvalableCategoryForm CADR argl op is "mkCategory" => c MEMQ(op,$CategoryNames) => ([x,m,$e]:= compOrCroak(c,$EmptyMode,$e); m=$Category => x) --loadIfNecessary op getConstructorKindFromDB op = 'category or get(op,"isCategory",$CategoryFrame) => [op,:[MKQ x for x in argl]] [x,m,$e]:= compOrCroak(c,$EmptyMode,$e) m=$Category => x MKQ c ++ Return true if we should skip compilation of category package. ++ This situation happens either when there is no default, of we are in ++ bootstrap mode, or we are compiling only for exports. skipCategoryPackage? capsule == null capsule or $bootStrapMode or $compileExportsOnly compDefineCategory1(df is ['DEF,form,sig,sc,body],m,e,prefix,fal) == categoryCapsule := body is ['add,cat,capsule] => body := cat capsule nil [d,m,e]:= compDefineCategory2(form,sig,sc,body,m,e,prefix,fal) if not skipCategoryPackage? categoryCapsule then [.,.,e] := $insideCategoryPackageIfTrue: local := true $categoryPredicateList: local := makeCategoryPredicates(form,$lisplibCategory) T := compDefine1(mkCategoryPackage(form,cat,categoryCapsule),$EmptyMode,e) or return stackSemanticError( ['"cannot compile defaults of",:bright opOf form],nil) if $compileDefaultsOnly then [d,m,e] := T [d,m,e] $tvl := [] $mvl := [] makeCategoryPredicates(form,u) == $tvl: local := TAKE(#rest form,$TriangleVariableList) $mvl: local := TAKE(#rest form,rest $FormalMapVariableList) fn(u,nil) where fn(u,pl) == u is ['Join,:.,a] => fn(a,pl) u is ['has,:.] => insert(EQSUBSTLIST($mvl,$tvl,u),pl) u is [op,:.] and MEMQ(op,'(SIGNATURE ATTRIBUTE)) => pl atom u => pl fnl(u,pl) fnl(u,pl) == for x in u repeat pl := fn(x,pl) pl mkCategoryPackage(form is [op,:argl],cat,def) == packageName:= INTERN(STRCONC(PNAME op,'"&")) packageAbb := INTERN(STRCONC(getConstructorAbbreviationFromDB op,'"-")) $options:local := [] -- This stops the next line from becoming confused abbreviationsSpad2Cmd ['domain,packageAbb,packageName] -- This is a little odd, but the parser insists on calling -- domains, rather than packages nameForDollar := first SETDIFFERENCE('(S A B C D E F G H I),argl) packageArgl := [nameForDollar,:argl] capsuleDefAlist := fn(def,nil) where fn(x,oplist) == atom x => oplist x is ['DEF,y,:.] => [y,:oplist] fn(rest x,fn(first x,oplist)) explicitCatPart := gn cat where gn cat == cat is ['CATEGORY,:.] => rest rest cat cat is ['Join,:u] => gn last u nil catvec := eval mkEvalableCategoryForm form fullCatOpList:=(JoinInner([catvec],$e)).1 catOpList := [['SIGNATURE,op1,sig] for [[op1,sig],:.] in fullCatOpList --above line calls the category constructor just compiled | assoc(op1,capsuleDefAlist)] null catOpList => nil packageCategory := ['CATEGORY,'domain, :SUBLISLIS(argl,$FormalMapVariableList,catOpList)] nils:= [nil for x in argl] packageSig := [packageCategory,form,:nils] $categoryPredicateList := substitute(nameForDollar,'$,$categoryPredicateList) substitute(nameForDollar,'$, ['DEF,[packageName,:packageArgl],packageSig,[nil,:nils],def]) compDefineCategory2(form,signature,specialCases,body,m,e, $prefix,$formalArgList) == --1. bind global variables $insideCategoryIfTrue: local:= true $definition: local := form --used by DomainSubstitutionFunction $form: local := nil $op: local := nil $extraParms: local := nil --Set in DomainSubstitutionFunction, used further down -- 1.1 augment e to add declaration $: