-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -- All rights reserved. -- Copyright (C) 2007-2008, 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 '"c-util" import '"cattable" import '"category" )package "BOOT" NRTPARSE := false $newCompCompare := false --% FUNCTIONS WHICH MUNCH ON == STATEMENTS compDefine(form,m,e) == $tripleHits: local:= 0 $macroIfTrue: local $packagesUsed: local result:= compDefine1(form,m,e) result ++ We are about to process the body of a capsule. If the capsule defines ++ `Rep' as a constant, then implicitly insert the view morphisms ++ per: Rep -> % ++ rep: % -> Rep ++ as local functions. Note that we do not declare them as macros. maybeInsertViewMorphisms body == domainRep := nil before := nil while null domainRep for [stmt,:after] in tails body repeat stmt isnt ["DEF",["Rep",:args],sig,nils,domainRep] => before := [stmt,:before] if args then userError [:bright '"Rep",'"cannot take arguments"] if first sig then userError [:bright '"Rep", "cannot have type sepcification"] null domainRep => body -- Make sure we don't implicitly convert from `Rep' to `%'. $useRepresentationHack := false -- Reject user-defined view morphisms for stmt in after repeat stmt is ["DEF",["rep",:.],:.] or stmt is ["DEF",["per",:.],:.] => -- ??? We may actually want to stop processing now. stackSemanticError(['"Cannot define",:bright per],nil) -- OK, insert synthetized view morphisms g := GENSYM() repMorphism := ["DEF",["rep",g],[domainRep,"$"],[nil,nil], ["pretend",g,domainRep]] perMorphism := ["DEF",["per",g],["$",domainRep],[nil,nil], ["pretend",g,"$"]] -- Trick the rest of the compiler into believing that -- that `Rep' was defined the old way, for the purpose of lookup. [:reverse before, ["LET","Rep",domainRep], :[repMorphism,perMorphism],:after] compDefine1(form,m,e) == $insideExpressionIfTrue: local:= false --1. decompose after macro-expanding form ['DEF,lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e) $insideWhereIfTrue and isMacro(form,e) and (m=$EmptyMode or m=$NoValueMode) => [lhs,m,put(first lhs,'macro,rhs,e)] null signature.target and not MEMQ(KAR rhs,$ConstructorNames) and (sig:= getSignatureFromMode(lhs,e)) => -- here signature of lhs is determined by a previous declaration compDefine1(['DEF,lhs,[first sig,:rest signature],specialCases,rhs],m,e) if signature.target=$Category then $insideCategoryIfTrue:= true --?? 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 not (and/[null x for x in rest signature]) => compDefWhereClause(form,m,e) signature.target=$Category => compDefineCategory(form,m,e,nil,$formalArgList) isDomainForm(rhs,e) and not $insideFunctorIfTrue => if null signature.target then signature:= [getTargetFromRhs(lhs,rhs,giveFormalParametersValues(rest lhs,e)),: rest signature] rhs:= addEmptyCapsuleIfNecessary(signature.target,rhs) compDefineFunctor(['DEF,lhs,signature,specialCases,rhs],m,e,nil, $formalArgList) null $form => stackAndThrow ['"bad == form ",form] newPrefix:= $prefix => INTERN STRCONC(encodeItem $prefix,'",",encodeItem $op) getAbbreviation($op,#rest $form) compDefineCapsuleFunction(form,m,e,newPrefix,$formalArgList) 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(target,rhs) == MEMQ(KAR rhs,$SpecialDomainNames) => rhs ['add,rhs,['CAPSULE]] 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(x,e) == y:= macroExpand(x,e) atom x or atom y => y RPLACA(x,first y) RPLACD(x,rest y) x 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 GETDATABASE(name, 'NILADIC) and (u := get(name, 'macro, e)) => macroExpand(u,e) [macroExpand(x,e) for x in l] 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) --+ next two lines if categoryCapsule and not $bootStrapMode then [.,.,e] := $insideCategoryPackageIfTrue: local := true --see NRTmakeSlot1 --> $categoryPredicateList: local := makeCategoryPredicates(form,$lisplibCategory) compDefine1(mkCategoryPackage(form,cat,categoryCapsule),$EmptyMode,e) [d,m,e] makeCategoryPredicates(form,u) == $tvl := TAKE(#rest form,$TriangleVariableList) $mvl := 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 --+ the following function mkCategoryPackage(form is [op,:argl],cat,def) == packageName:= INTERN(STRCONC(PNAME op,'"&")) packageAbb := INTERN(STRCONC(GETDATABASE(op,'ABBREVIATION),'"-")) $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 := --note: this gets too many modemaps in general -- this is cut down in NRTmakeSlot1 [['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 := SUBST(nameForDollar,'$,$categoryPredicateList) SUBST(nameForDollar,'$, ['DEF,[packageName,:packageArgl],packageSig,[nil,:nils],def]) compDefineCategory2(form,signature,specialCases,body,m,e, $prefix,$formalArgList) == --1. bind global variables $insideCategoryIfTrue: local:= true $TOP__LEVEL: local $definition: local --used by DomainSubstitutionFunction $form: local $op: local $extraParms: local --Set in DomainSubstitutionFunction, used further down -- 1.1 augment e to add declaration $: