---- To be run on Maude 2.5
---- author: Francisco Duran
---- printSyntaxError functionality by Peter Olveczky
---- narrowing search by Santiago Escobar
set show loop stats off .
set show loop timing off .
set show advisories off .
fmod BANNER is
pr STRING .
op banner : -> String .
eq banner = "Full Maude 2.5b January 14th 2011" .
endfm
***(
This file is part of the Maude 2 interpreter.
Copyright 1997-2003 SRI International, Menlo Park, CA 94025, USA.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 inclof the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNSS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public Leicense
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
)
---- to do:
---- - use of upView to use Core Maude views (empty views and default sort maps)
---- To use the upView metalevel function I'll have to be able to complete views.
---- In Full Maude, sort maps need to be completely specified.
---- - bug reported by Min Zhang (see People/Zhang/rand.fm)
---- - continue .
---- - show search path .
---- - show path labels <number> .
---- - show components .
---- Main changes and bugs fixed:
----
---- - December 5th, 2009
---- - New command (remove id attributes [<module-expr.>] .) that shows the
---- module with the id attributes removed using variants.
---- - New command (remove assoc attributes [<module-expr.>] .) that shows the
---- module with the assoc (if not with comm) attributes removed using variants.
---- - November 22nd, 2009
---- - A new version of the narrowing/unification stuff by S. Escobar fixing a bug in the
---- getVariants function and incorporating some other changes.
---- To integrate it into Full Maude:
---- - The TERMSET module is moved, so that now Full Maude uses it instead of its
---- definition of term sets. In the original module by Santiago this module imported
---- the SUBSTITUTION-HANDLING module; this importation is now commented out.
---- - October 4th, 2009
---- - New (acu coherence completion .) / (acu coherence completion <Module> .) command.
---- It shows result of completing the flatten version of the module for acu coherence.
---- - Setember 11th, 2009
---- - sort Set<List<Type>> replaced by the TypeListSet sort from META-MODULE
---- - sort List<Set<Type>> renamed as TypeSetList
---- - MAYBE removed, DEFAULT-VALUE used instead. MAYBE{TERM} replaced by DEFAULT-VALUE{Term}
---- - July 28th, 2009
---- - Some cleaning up. Some of the changes may break other applications.
---- - April 18th, 2009
---- - The metadata attribute is now available for operation declarations. Reported by A. Riesco.
---- - Fixed bug in the handling of ditto. ctor and metadata attributes were copied.
---- - March 9th, 2009
---- - Bug in the search command. The number of solutions argument was used as depth bound. Reported by P. Olveczky.
---- - New (remove id attributes .) / (remove id attributes <Module> .) command
---- It shows an equivalent version of the flatten module without ids using variants.
---- - March 9th, 2009
---- - Bug in the handling of mbs/cmbs. Sorts in bubbles were not handled correctly. Reported by T. Serbanuta.
---- - February 12th, 2009
---- - The summation module expression now generates a module
---- fmod A + B + C is
---- inc A .
---- inc B .
---- inc C .
---- endfm
---- for a module expression A + B + C.
---- - February 6th, 2009
---- - Fixed a bug in the id-unify command. Fixed by Santiago Escobar
---- - February 3rd, 2009
---- - Missing equation for downAttr, for the case of nonexec
---- - Missing declaration in the CONFIGURATION+ module to handle class declarations with no attributes
---- - January 29th, 2009
---- - The downModule operation has been extended to be able to handle oo metamodules.
---- Note that omod metamodules are defined in the UNIT Full Maude module. Therefore,
---- to be able to do things like
---- (load omod ... endm .)
---- the current module must be the FM UNIT module or one extending it.
---- - January 28th, 2009
---- - A bug in downAttr. Found thanks to a problem with metamodule load. Reported by Peter Olveczky.
---- - January 8th, 2009
---- - A bug in the narrowing functionality. It was narrowing on frozen positions.
---- (fixed by Santiago Escobar)
---- - December 20th, 2008
---- - Fixed a bug in the handling of the such-that part of search commands.
---- Reported by Enrique Martin.
---- - December 17th, 2008
---- - A new search_~>_ family of commands (as for search_=>_) is now available.
---- The commands are implemented by Santiago Escobar.
---- - December 8th, 2008
---- - A new meta-module load command is available.
---- It enters a metamodule into Full Maude's database of modules.
---- Asked by Peter Olveczky and Jose Meseguer.
---- The syntax for the new command is (load <meta-module> .), where <meta-module is any term of sort
---- Module, either a term of the form fmod...endfm or any other expression reducing to a module.
---- Thus, you can write things like
----
---- (select META-LEVEL .)
----
---- (load fmod 'FOO is
---- including 'BOOL .
---- sorts 'Foo .
---- none
---- op 'f : nil -> 'Foo [none] .
---- op 'g : nil -> 'Foo [none] .
---- none
---- endfm .)
----
---- or
----
---- (load upModule('NAT, true) .)
----
---- - September 18th, 2008
---- The search command now supports its complete generality (maximum depth couln't be given). Bug reported by Zhang Min.
---- The unify command is now supported.
---- Bug in the renaming of partial operations fixed. Reported by Edu Rivera.
---- - April 2nd, 2008
---- Bug in the application of views (and renamings) with kinds in the specification
---- of op renamings. It appears in an example in which the sort was coming from a theory.
---- Reported by A. Boronat.
---- - March 24th, 2008
---- Bug in the application of renamings to op hooks. Reported by A. Boronat
---- - March 17th, 2008
---- Bug in the instantiation of parameterized sorts in sort memberships.
---- Reported by A. Boronat
---- - March 14th, 2008
---- Bug in the handling of parameterized module expressions. When the parameterers
---- are not right, the system hangs. Reported by A. Verdejo.
---- - March 9th, 2008
---- Statement attributes of membership axioms were not correctly handled.
---- Reported by A. Riesco & A. Verdejo
---- - Feb 18th, 2008
---- Bug in the renaming of operators
---- - Feb 14th, 2008
---- Statement attributes of membership axioms were not correctly handled.
---- Reported by A. Riesco & A. Verdejo
---- - Dec 17th, 2007
---- Rule in CONFIGURATION+ was causing non-termination
---- - Dec 13th, 2007
---- Change in the specification of the transform function to allow new types of modules
---- - Nov 23rd, 2007
---- Bug in the evaluation of expressions in commands (red in FOO + BAR : ...)
---- - Oct 5th, 2007
---- Bug in down of modules (reported by Pedro Ojeda)
---- - July 31st, 2007
---- bug in the application of maps to terms
---- - July 31st, 2007
---- bug in getThClasses
---- (reported by Marisol)
---- - (october 17th, 2006)
---- Changes in Alpha88a's prelude are now correctly handled
---- - (july 22nd, 2006)
---- Bug in the meta-pretty-print of types.
---- - (july 21st, 2006)
---- Object-oriented messages where not given the attribute msg
---- (from a comment by Peter).
---- - (reported by Radestock)
---- getSort was not handling parameterized sorts appropriately.
---- - the set protect/extend/include off commands didn't work if the
---- module not importing was not among the imported ones
----
---- Last changes:
----
---- - May 21st, 2007
---- GRAMMAR now extends a module BUBBLES with all bubble delcarations.
---- This BUBBLES module is also used to define the GRAMMAR-RED, GRAMMAR-REW, ...
---- modules.
----
---- - May 19th, 2007
---- procCommand changed. It now returns a Tuple{Database, QidList} instead of
---- just a QidList. Since some modules may need to be compiled for the
---- execution of a command, the resulting database is returned and used as
---- new database.
----
---- - May 19th, 2007
---- proRew takes now one argument less. The Bound (4th arg.) was unnecessary.
----
---- - BOOL is included, instead of protected, into any entered module.
----
---- - A new module expression POWER[n] is now available. A module expression
---- POWER[n]{Nat} produces a module
----
---- fmod POWER[n]{X :: TRIV} is
---- inc TUPLE[n]{X, X, ..., X} .
---- endfm
----
---- which is then instantiated by the Nat view.
---- - (July 18th, 2006)
---- The summation module expression now generates a module
---- that includes (instead of protect) its summands.
----
---- - All sorts declared in modules used for parsing have been renamed.
---- Any sort S in one of these modules is nos called @S@.
---- Since some of these modules where added to the user defined modules
---- for dealing with ups, conditions, etc., he was getting error when
---- using sorts like Token or OpDecl in his specs.
----
---- - Syntax for parameterization has been changed (again) !!! :
---- - module definition: FOO{X :: TRIV, Y :: TRIV}
---- - module instantiation: FOO{Bar,Baz}
---- - parameterized sorts: Foo{Bar,Baz}
----
---- - Any module loaded in Core Maude can be used in Full Maude.
---- This may be particularly useful in the case of using the model checker.
----
---- (mod CHECK-RESP is
---- protecting MODEL-CHECKER .
---- ...
---- endm)
----
---- (red p(0) |= (<> Qstate) .)
----
---- - Module renaming and summation consistent with Core Maude's. Built-ins
---- are now handled at the metalevel, instead of leaving the inclusions to
---- Core Maude. In this way, they can be renamed and redefined, as in
---- Core Maude. This makes Full Maude slower.
----
---- - The lazy evaluation of modules is working. When a module is redefined
---- its dependent modules are removed only if generated internally. Those
---- introduced by the user save their term representation, from which the
---- whole processing can take place. They will be recompiled by need.
----
---- - The form of qualifying sorts coming from the parameters in
---- parameterized modules has changed AGAIN: The sort Elt coming from
---- X :: TRIV is now written as X$Elt (Note that sort names cannot contain
---- dots anymore).
----
---- - Tuples are built with the syntax
---- TUPLE[size]{comma_separated_list_of_views}
---- For example, given a view Nat from TRIV to NAT we can define pairs of
---- nats with TUPLE[2]{Nat, Nat}.
----
---- - The model-checker is loaded before the full maude modules, so that
---- it can be used.
----
---- - Object-oriented modules include a module CONFIGURATION+, which
---- imports CONFIGURATION, defines a function
---- op class : Object -> Cid .
---- returning the actual class of the given object, and add syntax
---- for objects with no attributes <_:_| >. Classes without attributes
---- are defined with syntax class CLASS-NAME .
----
---- Things to come:
----
---- - Commands missing: continue ...
----
---- - On parameterized theories and views: linked parameters, composed and
---- lifted views, and default views.
----
---- - ops names in op declarations
----
---- known bugs:
----
---- - error messages could be given in down commands
----
---- - Check: perhaps we need to convert constants back into vbles in
---- procViewAux
----
---- - Parameterized sorts don't work in sort constraints (nor by themselves,
---- nor in the conditions of axioms. They are accepted in their equivalent
---- single token form but do not get instantiated
---- cmb (A, B) S : PFun(X, Y) if not(A in dom(S)) /\ S : PFun`(X`,Y`) .
----
set include BOOL off .
set include TRUTH-VALUE on .
set show advisories off .
mod CONFIGURATION is
sorts Attribute AttributeSet .
subsort Attribute < AttributeSet .
op none : -> AttributeSet [ctor] .
op _,_ : AttributeSet AttributeSet -> AttributeSet [ctor assoc comm id: none] .
sorts Oid Cid Object Msg Portal Configuration .
subsort Object Msg Portal < Configuration .
op <_:_|_> : Oid Cid AttributeSet -> Object [ctor object] .
op none : -> Configuration [ctor] .
op __ : Configuration Configuration -> Configuration [ctor config assoc comm id: none] .
op <> : -> Portal [ctor] .
endm
mod CONFIGURATION+ is
including CONFIGURATION .
op <_:_|`> : Oid Cid -> Object .
op class : Object -> Cid .
---- eq < O:Oid : C:Cid | > = < O:Oid : C:Cid | none > .
eq class(< O:Oid : C:Cid | A:AttributeSet >) = C:Cid .
endm
set include BOOL on .
set include TRUTH-VALUE off .
*******************************************************************************
*******************************************************************************
***
*** Narrowing and Equational Unification
*** by Santiago Escobar
***
fmod UNIFICATIONTRIPLE is
protecting META-LEVEL .
protecting INT .
--- UnificationPair --------------------------------------------
---sorts UnificationPair UnificationPair? .
---op {_,_} : Substitution Nat -> UnificationPair [ctor] .
---subsort UnificationPair < UnificationPair? .
---op noUnifier : -> UnificationPair? [ctor] .
op getSubst : UnificationPair -> Substitution .
eq getSubst({S1:Substitution, N:Nat}) = S1:Substitution .
op getNextVar : UnificationPair -> Nat .
eq getNextVar({S1:Substitution, N:Nat}) = N:Nat .
--- UnificationTriple --------------------------------------------
---sorts UnificationTriple UnificationTriple? .
---op {_,_,_} : Substitution Substitution Nat -> UnificationTriple [ctor] .
---subsort UnificationTriple < UnificationTriple? .
---op noUnifier : -> UnificationTriple? [ctor] .
op getLSubst : UnificationTriple -> Substitution .
eq getLSubst({S1:Substitution, S2:Substitution, N:Nat}) = S1:Substitution .
op getRSubst : UnificationTriple -> Substitution .
eq getRSubst({S1:Substitution, S2:Substitution, N:Nat}) = S2:Substitution .
op getNextVar : UnificationTriple -> Nat .
eq getNextVar({S1:Substitution, S2:Substitution, N:Nat}) = N:Nat .
endfm
fmod TERM-HANDLING is
protecting META-TERM .
protecting META-LEVEL .
protecting EXT-BOOL . *** For and-then
var T T' T'' : Term .
var C C' : Constant .
var QIL : QidList .
var N N' : Nat .
var NL NL' : NatList .
var Q F F' : Qid .
var AtS : AttrSet .
var EqS : EquationSet .
var Eq : Equation .
var Cond : Condition .
var TP : Type .
var TPL TPL' : TypeList .
var TL TL' TL'' : TermList .
var B : Bool .
var V V' : Variable .
var Ct : Context .
var CtL : NeCTermList .
var NeTL : NeTermList .
var M : Module .
*** root ******************************
op root : Term -> Qid .
eq root(V) = V .
eq root(C) = C .
eq root(F[TL]) = F .
*** elem_of_ *****************************************************
op elem_of_ : Nat TermList ~> Term .
eq elem 1 of (T,TL) = T .
eq elem s(s(N)) of (T,TL) = elem s(N) of TL .
*** subTerm_of_ *****************************************************
op subTerm_of_ : NatList Term ~> Term .
eq subTerm NL of T = subTerm* NL of T .
op subTerm*_of_ : NatList Term ~> Term .
eq subTerm* nil of T = T .
eq subTerm* N NL of (F[TL]) = subTerm* NL of (elem N of TL) .
*** ToDo: UPGRADE THIS NOTION TO MODULO AC *********************
*** is_subTermOf_ *****************************************************
op is_subTermOf_ : Term TermList -> Bool .
eq is T subTermOf T = true .
eq is T subTermOf (F[TL]) = is T subTermOf TL .
eq is T subTermOf (T',NeTL)
= is T subTermOf T' or-else is T subTermOf NeTL .
eq is T subTermOf T' = false [owise] .
*** noVarOfSort_In_ *****************************************************
op noVarOfSort_In_ : Type TermList -> Bool .
eq noVarOfSort T:Type In V = getType(V) =/= T:Type .
eq noVarOfSort T:Type In (F[TL]) = noVarOfSort T:Type In TL .
eq noVarOfSort T:Type In (T',NeTL)
= noVarOfSort T:Type In T' and noVarOfSort T:Type In NeTL .
eq noVarOfSort T:Type In X:TermList = true [owise] .
*** findSubTermOf_In_ ***********************************************
op findSubTermOf_In_ : NeCTermList TermList ~> Term .
eq findSubTermOf (TL, [], TL') In (TL, T, TL') = T .
eq findSubTermOf (TL, F[CtL], TL'') In (TL, F[TL'], TL'')
= findSubTermOf CtL In TL' .
*** replaceElem_of_by_ ****************************************************
op replaceElem_of_by_ : Nat TermList Term ~> TermList .
eq replaceElem 1 of (T,TL) by T' = (T',TL) .
eq replaceElem s(s(N)) of (T,TL) by T' = (T,replaceElem s(N) of TL by T') .
*** replaceSubTerm_of_by_ *************************************************
op replaceSubTerm_of_by_ : NatList TermList Term ~> TermList .
eq replaceSubTerm nil of T by T' = T' .
eq replaceSubTerm N NL of (F[TL]) by T'
= F[replaceSubTermL N NL of TL by T'] .
op replaceSubTermL_of_by_ : NatList TermList Term ~> TermList .
eq replaceSubTermL 1 NL of (T,TL) by T'
= (replaceSubTerm NL of T by T', TL) .
eq replaceSubTermL s(s(N)) NL of (T,TL) by T'
= (T,replaceSubTermL s(N) NL of TL by T') .
op replaceTerm_by_in_ : Term Term TermList ~> TermList .
eq replaceTerm T by T' in T = T' .
eq replaceTerm T by T' in (F[TL]) = F[replaceTerm T by T' in TL] .
eq replaceTerm T by T' in T'' = T'' [owise] .
eq replaceTerm T by T' in (T'',NeTL)
= (replaceTerm T by T' in T'',replaceTerm T by T' in NeTL) .
*** context replacement **************************************************
op _[_] : Context Context -> Context .
op _[_] : NeCTermList Context -> NeCTermList .
eq [] [ Ct ] = Ct .
eq (F[CtL])[ Ct ] = F[ CtL [ Ct ] ] .
eq (CtL,NeTL) [Ct] = (CtL [Ct] ), NeTL .
eq (NeTL,CtL) [Ct] = NeTL, (CtL [Ct] ) .
op _[_] : Context Term -> Term .
op _[_] : NeCTermList Term -> TermList .
eq [] [ T ] = T .
eq (F[CtL])[ T ] = F[ CtL [ T ] ] .
eq (CtL,NeTL) [T] = (CtL [T] ), NeTL .
eq (NeTL,CtL) [T] = NeTL, (CtL [T] ) .
*** is_substring_ *****************************************
op is_substring_ : Qid Qid -> Bool [memo] .
eq is F:Qid substring F':Qid
= rfind(string(F':Qid), string(F:Qid), length(string(F':Qid))) =/= notFound .
*** addprefix_To_ addsufix_To_ *****************************************
op addprefix_To_ : Qid Variable -> Variable [memo] .
eq addprefix Q To V
= qid(string(Q) + string(getName(V)) + ":" + string(getType(V))) .
op addprefix_To_ : Qid Constant -> Constant [ditto] .
eq addprefix Q To F
= if noUnderBar(F) and getName(F) :: Qid then
if getType(F) :: Type then
qid(string(Q) + string(getName(F)) + "." + string(getType(F)))
else
qid(string(Q) + string(getName(F)))
fi
else
qid(string(Q) + string(F))
fi .
op addsufix_To_ : Qid Variable -> Variable [memo] .
eq addsufix Q To V
= qid(string(getName(V)) + string(Q) + ":" + string(getType(V))) .
op addsufix_To_ : Qid Constant -> Constant [ditto] .
eq addsufix Q To F
= if noUnderBar(F) and getName(F) :: Qid then
if getType(F) :: Type then
qid(string(getName(F)) + string(Q) + "." + string(getType(F)))
else
qid(string(getName(F)) + string(Q))
fi
else
qid(string(F) + string(Q))
fi .
op addType_ToVar_ : Type Qid -> Variable [memo] .
eq addType TP:Qid ToVar V:Qid
= qid(string(V:Qid) + ":" + string(TP:Qid)) .
*** noUnderBar (auxiliary) ****************************
op noUnderBar : Qid -> Bool .
eq noUnderBar(F)
= rfind(string(F), "_", length(string(F))) == notFound .
*** addType ******************************
op addType : Qid Type -> Qid .
eq addType(F,TP)
= if noUnderBar(F) and getName(F) :: Qid then
qid( string(getName(F)) + "." + string(TP) )
else
qid( string(F) + "." + string(TP) )
fi .
*** addTypeVar ******************************
op addTypeVar : Qid Type -> Qid .
eq addTypeVar(F,TP)
= qid( string(F) + ":" + string(TP) ) .
*** createTerm ******************************
op createTerm : Qid TypeList -> Term .
endfm
fmod SUBSTITUTION-HANDLING is
protecting META-TERM .
protecting META-LEVEL .
protecting TERM-HANDLING .
var S S' Subst Subst' : Substitution .
var V V' : Variable .
var C C' : Constant .
var Ct : Context .
var T T' T1 T2 T1' T2' T1'' T2'' : Term .
var F F' : Qid .
var TL TL' TL1 TL2 TL1' TL2' : TermList .
var Att : AttrSet .
var RLS : RuleSet .
var Rl : Rule .
var TP : Type .
var N : Nat .
var NeTL : NeTermList .
var CtL : NeCTermList .
--- Apply Substitution to Term --------------------------------------------
op _<<_ : Term Substitution -> Term .
eq TL << none = TL .
eq C << Subst = C .
eq V << ((V <- T) ; Subst) = T .
eq V << Subst = V [owise] .
eq F[TL] << Subst = F[TL << Subst] .
op _<<_ : TermList Substitution -> TermList .
eq (T, NeTL) << Subst = (T << Subst, NeTL << Subst) .
eq empty << Subst = empty .
op _<<_ : Context Substitution -> Context .
eq Ct << none = Ct .
eq [] << Subst = [] .
eq F[CtL,NeTL] << Subst = F[CtL << Subst,NeTL << Subst] .
eq F[NeTL,CtL] << Subst = F[NeTL << Subst, CtL << Subst] .
eq F[Ct] << Subst = F[Ct << Subst] .
op _<<_ : Substitution Substitution -> Substitution .
eq S << (none).Substitution = S .
eq (none).Substitution << S = (none).Substitution .
eq ((V' <- T) ; S') << S
= (V' <- (T << S))
;
(S' << S) .
--- Combine Substitutions -------------------------------------------------
op _.._ : Substitution Substitution -> Substitution .
eq S .. S' = (S << S') ; S' .
--- Restrict Assignments to Variables in a Term ----------------------
op _|>_ : Substitution TermList -> Substitution .
eq Subst |> TL = Subst |>* Vars(TL) .
op _|>*_ : Substitution TermList -> Substitution .
--- eq noMatch |>* TL = noMatch .
eq Subst |>* TL = Subst |>** TL [none] .
op _|>**_[_] : Substitution TermList
Substitution -> Substitution .
eq none |>** TL [Subst']
= Subst' .
eq ((V <- V) ; Subst) |>** TL [Subst']
= Subst |>** TL [Subst'] .
eq ((V <- T') ; Subst) |>** TL [Subst']
= Subst |>** TL
[Subst' ; if any V in TL then (V <- T') else none fi] .
--- Remove Variables from list ----------------------
op _intersect_ : TermList TermList -> TermList .
eq (TL1,T,TL2) intersect (TL1',T,TL2')
= (T,((TL1,TL2) intersect (TL1',TL2'))) .
eq TL intersect TL' = empty [owise] .
op _intersectVar_ : TermList TermList -> TermList .
eq TL1 intersectVar TL2
= TL1 intersectVar* Vars(TL2) .
op _intersectVar*_ : TermList TermList -> TermList .
eq (T,TL1) intersectVar* TL2
= (if any Vars(T) in TL2 then T else empty fi,TL1 intersectVar* TL2) .
eq empty intersectVar* TL2
= empty .
--- Variables ---
op Vars : GTermList -> TermList .
eq Vars((T,TL:GTermList)) = VarsTerm(T),Vars(TL:GTermList) .
eq Vars((Ct,TL:GTermList)) = VarsTerm(Ct),Vars(TL:GTermList) .
eq Vars(empty) = empty .
op VarsTerm : Term -> TermList . ---warning memo
eq VarsTerm(V) = V .
eq VarsTerm(F[TL:TermList]) = Vars(TL:TermList) .
eq VarsTerm(C) = empty .
op VarsTerm : Context -> TermList . ---warning memo
eq VarsTerm(F[TL:GTermList]) = Vars(TL:GTermList) .
--- membership ---
op _in_ : Term TermList -> Bool .
eq T in (TL,T,TL') = true .
eq T in TL = false [owise] .
--- membership ---
op any_in_ : TermList TermList -> Bool . --- [memo] .
eq any empty in TL = false .
eq any (TL1,T,TL2) in (TL1',T,TL2') = true .
eq any TL in TL' = false [owise] .
--- membership ---
op all_in_ : TermList TermList -> Bool . --- [memo] .
eq all empty in TL = true .
eq all (TL1,T,TL2) in (TL1',T,TL2') = all (TL1,TL2) in (TL1',T,TL2') .
eq all TL in TL' = false [owise] .
--- Occur check ---
op allVars_inVars_ : GTermList GTermList -> Bool .
eq allVars TL:GTermList inVars TL':GTermList
= all Vars(TL:GTermList) in Vars(TL':GTermList) .
op anyVars_inVars_ : GTermList GTermList -> Bool .
eq anyVars TL:GTermList inVars TL':GTermList
= any Vars(TL:GTermList) in Vars(TL':GTermList) .
--- op dom : Substitution -> TermList .
--- eq dom(V <- T ; Subst) = (V,dom(Subst)) .
--- eq dom(none) = empty .
--- op range : Substitution -> TermList .
--- eq range(V <- T ; Subst) = (T,range(Subst)) .
--- eq range(none) = empty .
op rangeVars : Substitution -> TermList .
eq rangeVars(V <- T ; Subst) = (Vars(T),rangeVars(Subst)) .
eq rangeVars(none) = empty .
op dom_inVars_ : Substitution TermList -> Bool .
eq dom Subst inVars TL = dom Subst in Vars(TL) .
op dom_in_ : Substitution TermList -> Bool .
eq dom (V <- T ; Subst) in (TL1,V,TL2) = true .
eq dom Subst in TL = false [owise] .
op range_inVars_ : Substitution TermList -> Bool .
eq range Subst inVars TL = range Subst in Vars(TL) .
op range_in_ : Substitution TermList -> Bool .
eq range (V <- T ; Subst) in TL
= any Vars(T) in TL or-else range Subst in TL .
eq range none in TL
= false .
endfm
fmod TERMSET is
protecting META-LEVEL .
protecting SUBSTITUTION-HANDLING .
sort TermSet .
subsort Term < TermSet .
op emptyTermSet : -> TermSet [ctor] .
op _|_ : TermSet TermSet -> TermSet
[ctor assoc comm id: emptyTermSet format (d n d d)] .
eq X:Term | X:Term = X:Term .
op _in_ : Term TermSet -> Bool .
eq T:Term in (T:Term | TS:TermSet) = true .
eq T:Term in TS:TermSet = false [owise] .
op TermSet : TermList -> TermSet .
eq TermSet(empty)
= emptyTermSet .
eq TermSet((T:Term,TL:TermList))
= T:Term | TermSet(TL:TermList) .
endfm
fmod RENAMING is
protecting META-TERM .
protecting META-LEVEL .
protecting TERM-HANDLING .
protecting SUBSTITUTION-HANDLING .
protecting TERMSET .
protecting CONVERSION .
protecting QID .
protecting INT .
protecting UNIFICATIONTRIPLE .
var S S' Subst Subst' : Substitution .
var V V' : Variable .
var C C' : Constant .
var CtL : NeCTermList .
var Ct : Context .
var T T' T1 T2 T1' T2' T1'' T2'' : Term .
var F F' : Qid .
var TL TL' TL'' TL''' : TermList .
var Att : AttrSet .
var RLS : RuleSet .
var Rl : Rule .
var TP : Type .
var N N' : Nat .
var NeTL : NeTermList .
var Q Q' : Qid .
var IL : ImportList .
var SS : SortSet .
var SSDS : SubsortDeclSet .
var OPDS : OpDeclSet .
var MAS : MembAxSet .
var EQS : EquationSet .
var TPL : TypeList .
--- Extra filter for substitutions ------
op _|>_ : Substitution Nat -> Substitution .
eq Subst |> N
= Subst |>* N [none] .
op _|>*_[_] : Substitution Nat Substitution -> Substitution .
eq none |>* N [Subst']
= Subst' .
eq ((V <- T') ; Subst) |>* N [Subst']
= Subst |>* N
[Subst' ; if highestVar(V) < N then (V <- T') else none fi ] .
--- instantiatesAbove -----------------------------------
op _instantiatesAbove_ : Substitution Nat -> Bool .
eq none instantiatesAbove N = false .
eq ((V <- T') ; Subst) instantiatesAbove N
= highestVar(V) >= N
or-else
Subst instantiatesAbove N .
----------------------------------------------
--- New Renaming Utilities -------------------
op highestVar : GTermList -> Nat .
eq highestVar(TL:GTermList)
= highestVar(TL:GTermList,0) .
op highestVarTerm : Term -> Nat . ---warning memo
op highestVarTerm : Context -> Nat . ---warning memo
eq highestVarTerm([]) = 0 .
eq highestVarTerm(C) = 0 .
eq highestVarTerm(V)
= if rfind(string(V), "#", length(string(V))) =/= notFound
and
rfind(string(V), ":", length(string(V))) =/= notFound
and
rat(substr(string(V),
rfind(string(V), "#", length(string(V))) + 1,
rfind(string(V), ":", length(string(V))) + (- 1))
,10)
:: Nat
then rat(substr(string(V),
rfind(string(V), "#", length(string(V))) + 1,
rfind(string(V), ":", length(string(V))) + (- 1))
,10)
else 0
fi .
eq highestVarTerm(F[TL:GTermList])
= highestVar(TL:GTermList,0) .
op highestVar : GTermList Nat -> Nat .
eq highestVar(empty,N)
= N .
eq highestVar((Ct,TL:GTermList),N)
= highestVar(TL:GTermList,
if highestVarTerm(Ct) > N then highestVarTerm(Ct) else N fi
) .
eq highestVar((T,TL:GTermList),N)
= highestVar(TL:GTermList,
if highestVarTerm(T) > N then highestVarTerm(T) else N fi
) .
--- For substitutions
op highestVar : Substitution -> Nat . --- [memo] .
eq highestVar(Subst)
= highestVar(Subst,0) .
op highestVar : Substitution Nat -> Nat .
eq highestVar((none).Substitution,N) = N .
eq highestVar(V <- T ; Subst,N)
= highestVar(Subst,highestVar((T,V),N)) .
--- Renaming ------------------------------------------------------
op newVar : Nat TypeList -> TermList .
eq newVar(N,nil) = empty .
eq newVar(N,TP TPL) = (newVar*(N,TP),newVar(s(N),TPL)) .
op newVar* : Nat Type -> Variable .
eq newVar*(N,TP)
= qid("#" + string(N,10) + ":" + string(TP)) .
op simplifyVars : TermList -> TermList .
eq simplifyVars(TL) = TL << 0 < .
op _<<`(_`)< : TermList GTermList -> TermList .
eq X:TermList <<(TL:GTermList)<
= X:TermList << highestVar(TL:GTermList) + 1 < .
op _<<_ : TermList UnificationPair -> TermList .
eq TL << {Subst,N} = TL << Subst .
op _<<_ : TermList UnificationTriple -> TermList .
eq TL << {Subst,Subst',N} = TL << (Subst ; Subst') .
op _<<_ : Substitution UnificationTriple -> Substitution .
eq S:Substitution << {Subst,Subst',N} = S:Substitution << (Subst ; Subst') .
op _<<_< : TermList Nat -> TermList .
eq TL << N < = TL << (TL << { none, N } <) .
op _<<_< : TermList UnificationPair -> UnificationPair . ***Huge [memo] .
eq C << {S,N} < = {S,N} .
eq F[TL] << {S,N} < = TL << {S,N} < .
eq V << {S,N} <
= if not (dom S inVars V)
then {S ; V <- newVar(N,getType(V)), N + 1}
else {S,N}
fi .
eq (T,TL:NeTermList) << {S,N} <
= TL:NeTermList << (T << {S,N} < ) < .
eq empty << {S,N} <
= {S,N} .
endfm
fmod SUBSTITUTIONSET is
protecting SUBSTITUTION-HANDLING .
protecting META-LEVEL .
protecting TERMSET .
protecting RENAMING .
sort SubstitutionSet NeSubstitutionSet .
subsort Substitution < NeSubstitutionSet < SubstitutionSet .
op empty : -> SubstitutionSet [ctor] .
op _|_ : SubstitutionSet SubstitutionSet -> SubstitutionSet
[ctor assoc comm id: empty format (d n d d)] .
op _|_ : NeSubstitutionSet SubstitutionSet -> NeSubstitutionSet
[ctor ditto] .
eq X:Substitution | X:Substitution = X:Substitution .
vars SS SS' : SubstitutionSet .
vars S S' Subst : Substitution .
vars T T' : Term .
vars TL TL' : TermList .
vars N N' : Nat .
var V : Variable .
op _<<_ : Substitution SubstitutionSet -> SubstitutionSet .
eq S << empty = empty .
ceq S << (S' | SS') = (S << S') | (S << SS') if SS' =/= empty .
op _..._ : SubstitutionSet [SubstitutionSet]
-> SubstitutionSet [strat (1) gather (e E)] .
eq empty ... SS':[SubstitutionSet] = empty .
eq (S | SS) ... SS':[SubstitutionSet]
= (S ...' SS':[SubstitutionSet])
|
(SS ... SS':[SubstitutionSet]) .
op _...'_ : Substitution SubstitutionSet -> SubstitutionSet .
eq S ...' empty
= empty .
eq S ...' (S' | SS')
= (S .. S')
|
(S ...' SS') .
op _|>_ : SubstitutionSet TermList -> SubstitutionSet .
eq (empty).SubstitutionSet |> TL = empty .
eq (S | SS:NeSubstitutionSet) |> TL
= (S |> TL) | (SS:NeSubstitutionSet |> TL) .
op _|>_ : SubstitutionSet Nat -> SubstitutionSet .
eq SS:NeSubstitutionSet |> N
= SS:NeSubstitutionSet |> (0,N) .
op _|>`(_,_`) : SubstitutionSet Nat Nat -> SubstitutionSet .
eq (empty).SubstitutionSet |> (N,N') = empty .
eq (S | SS:NeSubstitutionSet) |> (N,N')
= (S |> (N,N')) | (SS:NeSubstitutionSet |> (N,N')) .
op _|>`(_,_`) : Substitution Nat Nat -> Substitution .
eq none |> (N,N') = none .
eq ((V <- T') ; Subst) |> (N,N')
= if N <= highestVar(V) and highestVar(V) <= N'
then (V <- T')
else none
fi
; (Subst |> (N,N')) .
op filter_by!InVars_ : SubstitutionSet TermList -> SubstitutionSet .
eq filter (empty).SubstitutionSet by!InVars TL
= (empty).SubstitutionSet .
eq filter (S | SS) by!InVars TL
= if dom S inVars TL
then empty
else S
fi
| filter SS by!InVars TL .
op _==* none : SubstitutionSet -> Bool .
eq (none | SS) ==* none = SS ==* none .
eq (empty).SubstitutionSet ==* none = true .
eq SS ==* none = false [owise] .
op |_| : SubstitutionSet -> Nat .
eq | (empty).SubstitutionSet | = 0 .
eq | (S | SS) | = s(| SS |) .
endfm
fmod UNIFICATIONPAIRSET is
protecting SUBSTITUTIONSET .
protecting RENAMING .
protecting UNIFICATIONTRIPLE .
vars V V' : Variable .
vars U U' : UnificationPair .
vars US US' : UnificationPairSet .
vars S S' S1 S1' S2 S2' : Substitution .
var SS : SubstitutionSet .
vars N N' N1 N2 : Nat .
vars T T' : Term .
var TL : TermList .
var M : Module .
--- Combine UnificationPair ---------------------------------------------
op _.._ : UnificationPair UnificationPair -> UnificationPair .
eq {S,N} .. {S',N'} = {S .. S',max(N,N')} .
--- Detect used variables ----------------------------------------------
op dom_inVars_ : UnificationPair TermList -> Bool . --- [memo] .
eq dom {S,N} inVars TL = dom S inVars TL .
--- UnificationPairSet --------------------------------------------------
sort UnificationPairSet .
subsort UnificationPair < UnificationPairSet .
op empty : -> UnificationPairSet [ctor] .
op _|_ : UnificationPairSet UnificationPairSet -> UnificationPairSet
[ctor assoc comm id: empty format (d n d d)] .
eq X:UnificationPair | X:UnificationPair = X:UnificationPair .
op _..._ : UnificationPairSet [UnificationPairSet]
-> UnificationPairSet [strat (1) gather (e E)] .
eq (empty).UnificationPairSet ... US':[UnificationPairSet]
= (empty).UnificationPairSet .
eq (U | US) ... US':[UnificationPairSet]
= (U ...' US':[UnificationPairSet])
|
(US ... US':[UnificationPairSet]) .
op _...'_ : UnificationPair UnificationPairSet -> UnificationPairSet .
eq U ...' (empty).UnificationPairSet
= (empty).UnificationPairSet .
eq U ...' (U' | US')
= (U .. U')
|
(U ...' US') .
--- Restriction -----------------------
op _|>_ : UnificationPairSet TermList -> UnificationPairSet .
eq (empty).UnificationPairSet |> TL = empty .
eq ({S,N} | US) |> TL = {(S |> TL),N} | (US |> TL) .
op filter_by!InVars_ : UnificationPairSet TermList
-> UnificationPairSet .
eq filter (empty).UnificationPairSet by!InVars TL
= (empty).UnificationPairSet .
eq filter (U | US) by!InVars TL
= if dom U inVars TL
then empty
else U
fi
| filter US by!InVars TL .
op toUnificationPair[_]`(_`) : Nat SubstitutionSet -> UnificationPairSet .
eq toUnificationPair[N](empty)
= empty .
eq toUnificationPair[N](S | SS)
= {S,highestVar(S,N)}
| toUnificationPair[N](SS) .
op toSubstitution : UnificationPairSet -> SubstitutionSet .
eq toSubstitution((empty).UnificationPairSet)
= empty .
eq toSubstitution({S,N} | US)
= S | toSubstitution(US) .
op _in_ : UnificationPair UnificationPairSet -> Bool .
eq X:UnificationPair in (X:UnificationPair | XS:UnificationPairSet) = true .
eq X:UnificationPair in XS:UnificationPairSet = false [owise] .
endfm
fmod UNIFICATIONTRIPLESET is
protecting SUBSTITUTIONSET .
protecting RENAMING .
protecting UNIFICATIONPAIRSET .
vars V V' : Variable .
var C : Constant .
var F : Qid .
vars U U' : UnificationTriple .
vars US US' : UnificationTripleSet .
vars S S' S1 S1' S2 S2' : Substitution .
var SS : SubstitutionSet .
var SSe : NeSubstitutionSet .
vars N N' N1 N2 NextVar : Nat .
vars T T' : Term .
var TL : TermList .
var NeTL : NeTermList .
var M : Module .
--- Combine UnificationPair ---------------------------------------------
op _.._ : UnificationTriple UnificationTriple -> UnificationTriple .
eq {S1,S1',N1} .. {S2,S2',N2} = {S1 .. S2,S1' .. S2',max(N1,N2)} .
--- UnificationPairSet --------------------------------------------------
sort UnificationTripleSet .
subsort UnificationTriple < UnificationTripleSet .
op empty : -> UnificationTripleSet [ctor] .
op _|_ : UnificationTripleSet UnificationTripleSet
-> UnificationTripleSet
[ctor assoc comm id: empty format (d n d d)] .
eq X:UnificationTriple | X:UnificationTriple = X:UnificationTriple .
op _..._ : UnificationTripleSet [UnificationTripleSet]
-> UnificationTripleSet [strat (1) gather (e E)] .
eq (empty).UnificationTripleSet ... US':[UnificationTripleSet]
= (empty).UnificationTripleSet .
eq (U | US) ... US':[UnificationTripleSet]
= (U ...' US':[UnificationTripleSet])
|
(US ... US':[UnificationTripleSet]) .
op _...'_ : UnificationTriple UnificationTripleSet
-> UnificationTripleSet .
eq U ...' (empty).UnificationTripleSet
= (empty).UnificationTripleSet .
eq U ...' (U' | US')
= (U .. U')
|
(U ...' US') .
--- convert -----------------------------------------------------
op split : UnificationPair Nat -> UnificationTriple .
eq split({none,N},N') = {none,none,N} .
eq split({(V <- T') ; S,N},N')
= if highestVar(V) < N'
then {(V <- T'),none,N}
else {none,(V <- T'),N}
fi
.. split({S,N},N') .
op toUnificationTriple[_]`(_`) :
Nat SubstitutionSet -> UnificationTripleSet .
eq toUnificationTriple[N](SS)
= toUnificationTriple*[N](SS,empty) .
op toUnificationTriple*[_]`(_,_`) :
Nat SubstitutionSet
UnificationTripleSet -> UnificationTripleSet .
eq toUnificationTriple*[N](empty,US)
= US .
eq toUnificationTriple*[N](S | SS,US)
= toUnificationTriple*[N](SS, US | {none,S,highestVar(S,N)}) .
op toUnificationTriple[_,_]`(_`) :
Nat Nat SubstitutionSet -> UnificationTripleSet .
eq toUnificationTriple[NextVar,N](SS)
= toUnificationTriple*[NextVar,N](SS,empty) .
op toUnificationTriple*[_,_]`(_,_`) :
Nat Nat SubstitutionSet
UnificationTripleSet -> UnificationTripleSet .
eq toUnificationTriple*[NextVar,N](empty,US)
= US .
eq toUnificationTriple*[NextVar,N](S | SS,US)
= toUnificationTriple*[NextVar,N](SS,
US | split({S,highestVar(S,N)},NextVar)) .
op toUnificationTriple[_,_,_]`(_`) :
Term Term Nat SubstitutionSet -> UnificationTripleSet .
eq toUnificationTriple[T,T',N](SS)
= toUnificationTriple*[T,T',N](SS,empty) .
op toUnificationTriple*[_,_,_]`(_,_`) :
Term Term Nat SubstitutionSet
UnificationTripleSet -> UnificationTripleSet .
eq toUnificationTriple*[T,T',N](empty,US)
= US .
eq toUnificationTriple*[T,T',N](S | SS,US)
= toUnificationTriple*[T,T',N](SS, US | {S |> T,S |> T',highestVar(S,N)}) .
op toSubstitution : UnificationTripleSet -> SubstitutionSet .
eq toSubstitution(US)
= toSubstitution*(US,empty) .
op toSubstitution* : UnificationTripleSet
SubstitutionSet -> SubstitutionSet .
eq toSubstitution*((empty).UnificationTripleSet,SS)
= SS .
eq toSubstitution*({S,S',N} | US,SS)
= toSubstitution*(US,SS | (S ; S')) .
op _in_ : UnificationTriple UnificationTripleSet -> Bool .
eq X:UnificationTriple
in (X:UnificationTriple | XS:UnificationTripleSet) = true .
eq X:UnificationTriple in XS:UnificationTripleSet = false [owise] .
--- restriction ---------------------------------------------------
op _|>_ : UnificationTripleSet TermList -> UnificationTripleSet .
eq US |> TL
= US *|> TL [empty] .
op _*|>_[_] : UnificationTripleSet TermList
UnificationTripleSet -> UnificationTripleSet .
eq (empty).UnificationTripleSet *|> TL [US']
= US' .
eq ({S,S',N} | US) *|> TL [US']
= US *|> TL [US' | {(S |> TL),(S' |> TL),N} ] .
op _filterBy_ : UnificationTripleSet Nat -> UnificationTripleSet .
eq US filterBy NextVar
= US filterBy* NextVar [empty] .
op _filterBy*_[_] : UnificationTripleSet Nat
UnificationTripleSet -> UnificationTripleSet .
eq empty filterBy* NextVar [US']
= US' .
eq ({S,S',N} | US) filterBy* NextVar [US']
= US filterBy* NextVar
[US' | if S instantiatesAbove NextVar then empty else {S,S',N} fi ] .
endfm
fmod MODULE-HANDLING is
protecting INT .
protecting META-LEVEL .
protecting EXT-BOOL . *** From Full Maude
protecting SUBSTITUTION-HANDLING .
protecting UNIFICATIONTRIPLESET .
var T T' T'' T1 T2 Lhs Rhs : Term .
var C C' : Constant .
var QIL : QidList .
var N N' : Nat .
var NL NL' : NatList .
var Q F F' : Qid .
vars AtS AtS' : AttrSet .
var EqS : EquationSet .
var Eq : Equation .
var RlS : RuleSet .
var Rl : Rule .
var Cond : Condition .
var TP TP' : Type .
var TPL TPL' : TypeList .
---var TPL TPL' : ETypeList .
---var ET ET' : EType .
var VDS OPDS : OpDeclSet .
var OPD : OpDecl .
var M : Module .
var TL TL' TL'' : TermList .
var B : Bool .
var V V' : Variable .
var I : Int .
*** canonice ******************************
op canonice : Module Term -> Term .
----eq canonice(M, T) = getTerm(metaReduce(eraseRls(eraseEqs(M)), T)) .
eq canonice(M, T) = getTerm(metaNormalize(M, T)) .
*** typeLeq **************************************************
op typeLeq : Module TypeList TypeList ~> Bool [memo] .
eq typeLeq(M,TP:Sort TPL,TP':Sort TPL')
= sortLeq(M,TP:Sort,TP':Sort) and typeLeq(M,TPL,TPL') .
eq typeLeq(M,TP:Sort TPL,TP':Kind TPL')
= getKind(M,TP:Sort) == TP':Kind
and typeLeq(M,TPL,TPL') .
eq typeLeq(M,TP:Kind TPL,TP':Sort TPL')
= false .
eq typeLeq(M,TP:Kind TPL,TP':Kind TPL')
= TP:Kind == TP':Kind and typeLeq(M,TPL,TPL') .
eq typeLeq(M,nil,nil)
= true .
*** getTypes **************************************************
op getTypes : Module TermList -> TypeList . ---Memo is huge
eq getTypes(M, (T, TL)) = leastSort(M, T) getTypes(M, TL) .
eq getTypes(M, empty) = nil .
*** getFrozen ************************************************
op getFrozen : Module Qid TypeList -> NatList [memo] .
eq getFrozen(M,F,TPL) = getFrozen(getOpsOfQid(M,F,TPL)) .
op getFrozen : OpDeclSet -> NatList .
eq getFrozen((op F : TPL -> TP [frozen(NL) AtS] .) OPDS) = NL .
eq getFrozen(OPDS) = 0 [owise] .
*** inNatList ************************************************
op _inNatList_ : Nat NatList -> Bool .
eq N inNatList (NL N NL') = true .
eq N inNatList NL = false [owise] .
*** membership ************************************************
op _in_ : Type TypeList ~> Bool .
eq TP in (TPL TP TPL') = true .
eq TP in TPL = false [owise] .
*** isConstructor ******************************
op isConstructor : Module Term -> Bool .
op isConstructor : Module Qid TypeList -> Bool [memo] .
op isConstructor : OpDeclSet -> Bool .
eq isConstructor(M,V) = false .
eq isConstructor(M,C) = isConstructor(M,C,nil) .
eq isConstructor(M,F[TL]) = isConstructor(M,F,getTypes(M,TL)) .
eq isConstructor(M,F,TPL)
= getEqsOfQid(M,F,TPL) == none or-else isConstructor(getOpsOfQid(M,F,TPL)) .
eq isConstructor((op F : TPL -> TP [ctor AtS] .) OPDS) = true .
eq isConstructor(OPDS) = false [owise] .
*** getOpsOfType ***********************************************
op getOpsOfType : Module Type -> OpDeclSet [memo] .
op getOpsOfType : Module OpDeclSet Type -> OpDeclSet .
eq getOpsOfType(M,TP) = getOpsOfType(M,getOps(M),TP) .
eq getOpsOfType(M,((op F : TPL -> TP [AtS] .) OPDS),TP')
= if TP == TP'
then (op F : TPL -> TP [AtS] .)
getOpsOfType(M,OPDS,TP')
else getOpsOfType(M,OPDS,TP')
fi .
eq getOpsOfType(M,OPDS,TP)
= none
[owise] .
*** getOpsOfQid ***********************************************
op getOpsOfQid : Module Qid TypeList -> OpDeclSet [memo] .
op getOpsOfQid : Module OpDeclSet Qid TypeList -> OpDeclSet .
eq getOpsOfQid(M,F,TPL)
= if getOpsOfQid(M,getOps(M),F,TPL) =/= none
then getOpsOfQid(M,getOps(M),F,TPL)
else getOpsOfQid(M,getOps(M),F,restrict TPL To 2)
fi .
eq getOpsOfQid(M,((op F : TPL -> TP [AtS] .) OPDS),F,TPL')
= if eSameKind(M,TPL,TPL')
then (op F : TPL -> TP [AtS] .)
getOpsOfQid(M,OPDS,F,TPL')
else getOpsOfQid(M,OPDS,F,TPL')
fi .
eq getOpsOfQid(M,OPDS,F',TPL')
= none
[owise] .
op restrict_To_ : TypeList Nat -> TypeList .
eq restrict nil To NL = nil .
eq restrict TPL To 0 = nil .
eq restrict (TP,TPL) To s(N) = (TP, restrict TPL To N) .
*** getEqsOfQid ******************************************************
op getEqsOfQid : Module Qid TypeList -> EquationSet [memo] .
op getEqsOfQid : Module Qid TypeList EquationSet -> EquationSet .
eq getEqsOfQid(M, F,TPL) = getEqsOfQid(M, F, TPL, getEqs(M)) .
ceq getEqsOfQid(M, F, TPL, (eq C = T' [AtS] .) EqS )
= (eq C = T' [AtS] .) getEqsOfQid(M, F, TPL, EqS)
if F == C .
ceq getEqsOfQid(M, F, TPL, (eq F[TL] = T' [AtS] .) EqS )
= (eq F[TL] = T' [AtS] .) getEqsOfQid(M, F, TPL, EqS)
if eSameKind(M,getTypes(M,TL),TPL) .
ceq getEqsOfQid(M, F, TPL, (ceq C = T' if Cond [AtS] .) EqS )
= (ceq C = T' if Cond [AtS] .) getEqsOfQid(M, F, TPL, EqS)
if F == C .
ceq getEqsOfQid(M, F, TPL, (ceq F[TL] = T' if Cond [AtS] .) EqS )
= (ceq F[TL] = T' if Cond [AtS] .) getEqsOfQid(M, F, TPL, EqS)
if eSameKind(M,getTypes(M,TL),TPL) .
eq getEqsOfQid(M, F, TPL, Eq EqS )
= getEqsOfQid(M, F, TPL, EqS) [owise] .
eq getEqsOfQid(M, F, TPL, (none).EquationSet )
= (none).EquationSet .
*** getTypesOfQid ****************************************
op getTypesOfQid : Module Qid TypeList -> TypeSet [memo] .
op getTypesOfQid : OpDeclSet -> TypeSet .
eq getTypesOfQid(M,F,TPL) = getTypesOfQid(getOpsOfQid(M,F,TPL)) .
eq getTypesOfQid((op F : TPL -> TP [AtS] .) OPDS)
= TP ; getTypesOfQid(OPDS) .
eq getTypesOfQid((none).OpDeclSet) = (none).TypeSet .
*** filterConstructorSymbols ************************************
op filterConstructorSymbols : OpDeclSet -> OpDeclSet .
eq filterConstructorSymbols(((op F : TPL -> TP [AtS] .) OPDS))
= if isConstructor((op F : TPL -> TP [AtS] .) none)
then (op F : TPL -> TP [AtS] .)
filterConstructorSymbols(OPDS)
else filterConstructorSymbols(OPDS)
fi .
eq filterConstructorSymbols(none)
= none .
*** filterDefinedSymbols *****************************************
op filterDefinedSymbols : OpDeclSet -> OpDeclSet .
eq filterDefinedSymbols(((op F : TPL -> TP [ctor AtS] .) OPDS))
= filterDefinedSymbols(OPDS) .
eq filterDefinedSymbols(((op F : TPL -> TP [AtS] .) OPDS))
= (op F : TPL -> TP [AtS] .) filterDefinedSymbols(OPDS) [owise] .
eq filterDefinedSymbols(none)
= none .
*** isCommutative ******************************
op isCommutative : Module Term -> Bool .
op isCommutative : Module Qid TypeList -> Bool [memo] .
op isCommutative : OpDeclSet -> Bool .
eq isCommutative(M,V) = false .
eq isCommutative(M,C) = false .
eq isCommutative(M,F[TL]) = isCommutative(M,F,getTypes(M,TL)) .
eq isCommutative(M,F,TPL) = isCommutative(getOpsOfQid(M,F,TPL)) .
eq isCommutative((op F : TPL -> TP [comm AtS] .) OPDS) = true .
eq isCommutative(OPDS) = false [owise] .
*** isAssociative ******************************
op isAssociative : Module Term -> Bool .
op isAssociative : Module Qid TypeList -> Bool [memo] .
op isAssociative : OpDeclSet -> Bool .
eq isAssociative(M,V) = false .
eq isAssociative(M,C) = false .
eq isAssociative(M,F[TL]) = isAssociative(M,F,getTypes(M,TL)) .
eq isAssociative(M,F,TPL) = isAssociative(getOpsOfQid(M,F,TPL)) .
eq isAssociative((op F : TPL -> TP [assoc AtS] .) OPDS) = true .
eq isAssociative(OPDS) = false [owise] .
*** getIdSymbol ******************************
op getIdSymbol : Module Term ~> Term .
eq getIdSymbol(M,F[TL]) = getIdSymbol(M,F,getTypes(M,TL)) .
op getIdSymbol : Module Qid TypeList ~> Term [memo] .
eq getIdSymbol(M,F,TPL) = getIdSymbol(getOpsOfQid(M,F,TPL)) .
op getIdSymbol : OpDeclSet ~> Term .
eq getIdSymbol((op F : TPL -> TP [id(T) AtS] .) OPDS) = T .
op getLeftIdSymbol : Module Term ~> Term .
eq getLeftIdSymbol(M,F[TL]) = getLeftIdSymbol(M,F,getTypes(M,TL)) .
op getLeftIdSymbol : Module Qid TypeList ~> Term .
eq getLeftIdSymbol(M,F,TPL) = getLeftIdSymbol(getOpsOfQid(M,F,TPL)) .
op getLeftIdSymbol : OpDeclSet ~> Term .
eq getLeftIdSymbol((op F : TPL -> TP [left-id(T) AtS] .) OPDS) = T .
op getRightIdSymbol : Module Term ~> Term .
eq getRightIdSymbol(M,F[TL]) = getRightIdSymbol(M,F,getTypes(M,TL)) .
op getRightIdSymbol : Module Qid TypeList ~> Term .
eq getRightIdSymbol(M,F,TPL) = getRightIdSymbol(getOpsOfQid(M,F,TPL)) .
op getRightIdSymbol : OpDeclSet ~> Term .
eq getRightIdSymbol((op F : TPL -> TP [right-id(T) AtS] .) OPDS) = T .
*** eSameKind ******************************
op eSameKind : Module TypeList TypeList -> Bool [memo] .
eq eSameKind(M,TP TPL, TP' TPL')
= sameKind(M,TP,TP') and eSameKind(M,TPL,TPL') .
eq eSameKind(M,nil,nil) = true .
eq eSameKind(M,TPL,nil) = true .
eq eSameKind(M,nil,TPL') = true .
---eq eSameKind(M,TPL,TPL') = false [owise] .
*** eqs2rls *******************************
sort EqSet&RlsSet .
op {_,_} : EquationSet RuleSet -> EqSet&RlsSet .
op getEqs : EqSet&RlsSet -> EquationSet .
eq getEqs({EqS,RlS}) = EqS .
op getRls : EqSet&RlsSet -> RuleSet .
eq getRls({EqS,RlS}) = RlS .
op eqs2rls# : EquationSet -> EqSet&RlsSet [memo] .
eq eqs2rls#(none) = {none,none} .
eq eqs2rls#((eq Lhs = Rhs [AtS label('homomorphism)] .) EqS)
= {(eq Lhs = Rhs [AtS label('homomorphism)] .) getEqs(eqs2rls#(EqS)),
getRls(eqs2rls#(EqS))
} .
eq eqs2rls#((eq Lhs = Rhs [AtS] .) EqS)
= {getEqs(eqs2rls#(EqS)),
(rl Lhs => Rhs [AtS] .) getRls(eqs2rls#(EqS))
} [owise] .
eq eqs2rls#((ceq Lhs = Rhs if Cond [AtS] .) EqS)
= {getEqs(eqs2rls#(EqS)),
(crl Lhs => Rhs if Cond [AtS] .) getRls(eqs2rls#(EqS))
} .
op eqs2rls : SModule -> SModule .
eq eqs2rls(
mod Q:Qid is
IL:ImportList
sorts S:SortSet .
S:SubsortDeclSet
O:OpDeclSet
M:MembAxSet
E:EquationSet
R:RuleSet
endm)
= mod (addsufix '-EQS2RLS To Q:Qid) is
IL:ImportList
sorts S:SortSet .
S:SubsortDeclSet
O:OpDeclSet
M:MembAxSet
getEqs(eqs2rls#(E:EquationSet))
getRls(eqs2rls#(E:EquationSet))
endm .
op eqs2rls : FModule -> FModule .
eq eqs2rls(
fmod Q:Qid is
IL:ImportList
sorts S:SortSet .
S:SubsortDeclSet
O:OpDeclSet
M:MembAxSet
E:EquationSet
endfm)
= mod (addsufix '-EQS2RLS To Q:Qid) is
IL:ImportList
sorts S:SortSet .
S:SubsortDeclSet
O:OpDeclSet
M:MembAxSet
getEqs(eqs2rls#(E:EquationSet))
getRls(eqs2rls#(E:EquationSet))
endm .
*** getEqsNoLabel *******************************
op getEqsNoLabel : Module -> EquationSet .
eq getEqsNoLabel(
fmod Q:Qid is
IL:ImportList
sorts S:SortSet .
S:SubsortDeclSet
O:OpDeclSet
M:MembAxSet
E:EquationSet
endfm)
= getEqsNoLabel(E:EquationSet) .
eq getEqsNoLabel(
mod Q:Qid is
IL:ImportList
sorts S:SortSet .
S:SubsortDeclSet
O:OpDeclSet
M:MembAxSet
E:EquationSet
R:RuleSet
endm)
= getEqsNoLabel(E:EquationSet) .
op getEqsNoLabel : EquationSet -> EquationSet [memo] .
eq getEqsNoLabel(none) = none .
eq getEqsNoLabel((eq Lhs = Rhs [AtS label('homomorphism)] .) EqS)
= getEqsNoLabel(EqS) .
eq getEqsNoLabel((eq Lhs = Rhs [AtS] .) EqS)
= (eq Lhs = Rhs [AtS] .) getEqsNoLabel(EqS) [owise] .
eq getEqsNoLabel((ceq Lhs = Rhs if Cond [AtS] .) EqS)
= (ceq Lhs = Rhs if Cond [AtS] .) getEqsNoLabel(EqS) .
*** getEqsNoLabel *******************************
op onlyEqsNoLabel : Module -> Module .
eq onlyEqsNoLabel(
fmod Q:Qid is
IL:ImportList
sorts S:SortSet .
S:SubsortDeclSet
O:OpDeclSet
M:MembAxSet
E:EquationSet
endfm)
= fmod Q:Qid is
IL:ImportList
sorts S:SortSet .
S:SubsortDeclSet
O:OpDeclSet
M:MembAxSet
getEqsNoLabel(E:EquationSet)
endfm .
eq onlyEqsNoLabel(
mod Q:Qid is
IL:ImportList
sorts S:SortSet .
S:SubsortDeclSet
O:OpDeclSet
M:MembAxSet
E:EquationSet
R:RuleSet
endm)
= mod Q:Qid is
IL:ImportList
sorts S:SortSet .
S:SubsortDeclSet
O:OpDeclSet
M:MembAxSet
getEqsNoLabel(E:EquationSet)
R:RuleSet
endm .
*** getEqsNoLabel *******************************
op getEqsLabel : Module -> EquationSet .
eq getEqsLabel(
fmod Q:Qid is
IL:ImportList
sorts S:SortSet .
S:SubsortDeclSet
O:OpDeclSet
M:MembAxSet
E:EquationSet
endfm)
= getEqsLabel(E:EquationSet) .
eq getEqsLabel(
mod Q:Qid is
IL:ImportList
sorts S:SortSet .
S:SubsortDeclSet
O:OpDeclSet
M:MembAxSet
E:EquationSet
R:RuleSet
endm)
= getEqsLabel(E:EquationSet) .
op getEqsLabel : EquationSet -> EquationSet [memo] .
eq getEqsLabel(none) = none .
eq getEqsLabel((eq Lhs = Rhs [AtS label('homomorphism)] .) EqS)
= (eq Lhs = Rhs [AtS] .) getEqsLabel(EqS) .
eq getEqsLabel((eq Lhs = Rhs [AtS] .) EqS)
= getEqsLabel(EqS) [owise] .
eq getEqsLabel((ceq Lhs = Rhs if Cond [AtS] .) EqS)
= getEqsLabel(EqS) .
*** getEqsNoLabel *******************************
op onlyEqsLabel : Module -> Module .
eq onlyEqsLabel(
fmod Q:Qid is
IL:ImportList
sorts S:SortSet .
S:SubsortDeclSet
O:OpDeclSet
M:MembAxSet
E:EquationSet
endfm)
= fmod Q:Qid is
IL:ImportList
sorts S:SortSet .
S:SubsortDeclSet
O:OpDeclSet
M:MembAxSet
getEqsLabel(E:EquationSet)
endfm .
eq onlyEqsLabel(
mod Q:Qid is
IL:ImportList
sorts S:SortSet .
S:SubsortDeclSet
O:OpDeclSet
M:MembAxSet
E:EquationSet
R:RuleSet
endm)
= mod Q:Qid is
IL:ImportList
sorts S:SortSet .
S:SubsortDeclSet
O:OpDeclSet
M:MembAxSet
getEqsLabel(E:EquationSet)
R:RuleSet
endm .
*** rls2eqs *******************************
op rls2eqs# : RuleSet -> EquationSet [memo] .
eq rls2eqs#(none) = none .
eq rls2eqs#((rl Lhs => Rhs [AtS] .) RlS)
= (eq Lhs = Rhs [AtS] .) rls2eqs#(RlS) .
eq rls2eqs#((crl Lhs => Rhs if Cond [AtS] .) RlS)
= (ceq Lhs = Rhs if Cond [AtS] .) rls2eqs#(RlS) .
op rls2eqs : SModule -> SModule .
eq rls2eqs(
mod Q:Qid is
IL:ImportList
sorts S:SortSet .
S:SubsortDeclSet
O:OpDeclSet
M:MembAxSet
E:EquationSet
R:RuleSet
endm)
= mod (addsufix '-RLS2EQS To Q:Qid) is
IL:ImportList
sorts S:SortSet .
S:SubsortDeclSet
O:OpDeclSet
M:MembAxSet
E:EquationSet rls2eqs#(R:RuleSet)
none
endm .
*** flipRls *******************************
op flipRls : RuleSet -> RuleSet [memo] .
eq flipRls(none) = none .
eq flipRls((rl Lhs => Rhs [AtS] .) RlS:RuleSet)
= if all Vars(Lhs) in Vars(Rhs)
then (rl Rhs => Lhs [removeNonExec(AtS)] .)
else (rl Rhs => Lhs [nonexec removeNonExec(AtS)] .)
fi
flipRls(RlS:RuleSet) .
eq flipRls((crl Lhs => Rhs if Cond [AtS] .) RlS:RuleSet)
= if all Vars(Lhs) in Vars(Rhs)
then (crl Rhs => Lhs if Cond [removeNonExec(AtS)] .)
else (crl Rhs => Lhs if Cond [nonexec removeNonExec(AtS)] .)
fi
flipRls(RlS:RuleSet) .
op removeNonExec : AttrSet -> AttrSet .
eq removeNonExec(nonexec AtS) = AtS .
eq removeNonExec(AtS) = AtS [owise] .
op flipRls : SModule -> SModule .
eq flipRls(mod Q:Qid is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
O:OpDeclSet M:MembAxSet E:EquationSet R:RuleSet endm)
= mod (addsufix '-FLIPPEDRLS To Q:Qid)
is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
O:OpDeclSet M:MembAxSet E:EquationSet flipRls(R:RuleSet) endm .
*** addOp *******************************
op addOps : OpDeclSet SModule -> SModule [memo] .
eq addOps(OO:OpDeclSet,mod Q:Qid is IL:ImportList sorts S:SortSet .
S:SubsortDeclSet O:OpDeclSet M:MembAxSet E:EquationSet R:RuleSet endm)
= mod (addsufix '-ADDEDOPS To Q:Qid)
is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
override(O:OpDeclSet,OO:OpDeclSet)
M:MembAxSet E:EquationSet R:RuleSet endm .
op override : OpDeclSet OpDeclSet -> OpDeclSet .
eq override(
(op F : TPL -> TP [AtS] .) O:OpDeclSet,
(op F : TPL -> TP [AtS'] .) O':OpDeclSet)
= override(O:OpDeclSet,(op F : TPL -> TP [AtS'] .) O':OpDeclSet) .
eq override(O:OpDeclSet,O':OpDeclSet)
= O:OpDeclSet O':OpDeclSet [owise] .
*** addRules *******************************
op addRules : RuleSet SModule -> SModule [memo] .
eq addRules(RR:RuleSet,mod Q:Qid is IL:ImportList sorts S:SortSet .
S:SubsortDeclSet O:OpDeclSet M:MembAxSet E:EquationSet R:RuleSet endm)
= mod (addsufix '-ADDEDRLS To Q:Qid)
is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
O:OpDeclSet M:MembAxSet E:EquationSet (R:RuleSet RR:RuleSet) endm .
*** addEqs *******************************
op addEqs : EquationSet SModule -> SModule [memo] .
op addEqs : EquationSet FModule -> FModule [memo] .
eq addEqs(ES:EquationSet,mod Q:Qid is IL:ImportList sorts S:SortSet .
S:SubsortDeclSet O:OpDeclSet M:MembAxSet E:EquationSet R:RuleSet endm)
= mod (addsufix '-ADDEDEQS To Q:Qid)
is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
O:OpDeclSet M:MembAxSet (E:EquationSet ES:EquationSet) R:RuleSet endm .
eq addEqs(ES:EquationSet,fmod Q:Qid is IL:ImportList sorts S:SortSet .
S:SubsortDeclSet O:OpDeclSet M:MembAxSet E:EquationSet endfm)
= fmod (addsufix '-ADDEDEQS To Q:Qid)
is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
O:OpDeclSet M:MembAxSet (E:EquationSet ES:EquationSet) endfm .
*** addSorts *******************************
op addSorts : SortSet SModule -> SModule [memo] .
op addSorts : SortSet FModule -> FModule [memo] .
eq addSorts(X:SortSet,
mod Q:Qid is IL:ImportList sorts S:SortSet .
S:SubsortDeclSet O:OpDeclSet M:MembAxSet E:EquationSet R:RuleSet endm)
= mod Q:Qid is IL:ImportList sorts (X:SortSet ; S:SortSet) .
S:SubsortDeclSet O:OpDeclSet M:MembAxSet E:EquationSet R:RuleSet endm .
eq addSorts(X:SortSet,
fmod Q:Qid is IL:ImportList sorts S:SortSet .
S:SubsortDeclSet O:OpDeclSet M:MembAxSet E:EquationSet endfm)
= fmod Q:Qid is IL:ImportList sorts (X:SortSet ; S:SortSet) .
S:SubsortDeclSet O:OpDeclSet M:MembAxSet E:EquationSet endfm .
*** putFrozen *******************************
op putFrozen : NatList Qid TypeList SModule -> SModule [memo] .
eq putFrozen(NL,F,TPL,
(mod Q:Qid is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
((op F : TPL -> TP [frozen(NL') AtS] .) O:OpDeclSet)
M:MembAxSet E:EquationSet R:RuleSet endm))
= (mod (addsufix F To (addsufix '-FROZEN# To Q:Qid))
is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
((op F : TPL -> TP [frozen(NL) AtS] .) O:OpDeclSet)
M:MembAxSet E:EquationSet R:RuleSet endm) .
eq putFrozen(NL,F,TPL,
(mod Q:Qid is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
((op F : TPL -> TP [AtS] .) O:OpDeclSet)
M:MembAxSet E:EquationSet R:RuleSet endm))
= (mod (addsufix F To (addsufix '-FROZEN# To Q:Qid))
is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
((op F : TPL -> TP [frozen(NL) AtS] .) O:OpDeclSet)
M:MembAxSet E:EquationSet R:RuleSet endm) [owise] .
*** putStrat *******************************
op putStrat : NatList Qid TypeList SModule -> SModule [memo] .
eq putStrat(NL,F,TPL,
(mod Q:Qid is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
((op F : TPL -> TP [strat(NL') AtS] .) O:OpDeclSet)
M:MembAxSet E:EquationSet R:RuleSet endm))
= (mod (addsufix F To (addsufix '-STRAT#EQ# To Q:Qid))
is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
((op F : TPL -> TP [strat(NL) AtS] .) O:OpDeclSet)
M:MembAxSet E:EquationSet R:RuleSet endm) .
eq putStrat(NL,F,TPL,
(mod Q:Qid is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
((op F : TPL -> TP [AtS] .) O:OpDeclSet)
M:MembAxSet E:EquationSet R:RuleSet endm))
= (mod (addsufix F To (addsufix '-STRAT#EQ# To Q:Qid))
is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
((op F : TPL -> TP [strat(NL) AtS] .) O:OpDeclSet)
M:MembAxSet E:EquationSet R:RuleSet endm) [owise] .
op putStrat : NatList Qid TypeList FModule -> FModule [memo] .
eq putStrat(NL,F,TPL,
(fmod Q:Qid is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
((op F : TPL -> TP [strat(NL') AtS] .) O:OpDeclSet)
M:MembAxSet E:EquationSet endfm))
= (fmod (addsufix F To (addsufix '-STRAT#EQ# To Q:Qid))
is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
((op F : TPL -> TP [strat(NL) AtS] .) O:OpDeclSet)
M:MembAxSet E:EquationSet endfm) .
eq putStrat(NL,F,TPL,
(fmod Q:Qid is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
((op F : TPL -> TP [AtS] .) O:OpDeclSet)
M:MembAxSet E:EquationSet endfm))
= (fmod (addsufix F To (addsufix '-STRAT#EQ# To Q:Qid))
is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
((op F : TPL -> TP [strat(NL) AtS] .) O:OpDeclSet)
M:MembAxSet E:EquationSet endfm) [owise] .
*** clearFrozen *******************************
op clearFrozen : NatList Qid TypeList SModule -> SModule [memo] .
eq clearFrozen(NL,F,TPL,
(mod Q:Qid is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
((op F : TPL -> TP [frozen(NL') AtS] .) O:OpDeclSet)
M:MembAxSet E:EquationSet R:RuleSet endm))
= (mod Q:Qid is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
((op F : TPL -> TP [AtS] .) O:OpDeclSet)
M:MembAxSet E:EquationSet R:RuleSet endm) .
eq clearFrozen(NL,F,TPL,M)
= M [owise] .
*** clearEqsFrozen *******************************
op clearEqsFrozen : SModule -> SModule [memo] .
eq clearEqsFrozen(M)
= clearEqsFrozen*(M) .
op clearEqsFrozen* : SModule -> SModule .
eq clearEqsFrozen*(
(mod Q:Qid is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
((op F : TPL -> TP [frozen(NL') AtS] .) O:OpDeclSet)
M:MembAxSet
((eq F[TL] = Rhs [AtS'] .) E:EquationSet)
R:RuleSet endm))
= clearEqsFrozen*(
(mod Q:Qid is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
((op F : TPL -> TP [AtS] .) O:OpDeclSet)
M:MembAxSet
((eq F[TL] = Rhs [AtS'] .) E:EquationSet)
R:RuleSet endm)) .
eq clearEqsFrozen*(M)
= M [owise] .
*** clearAllFrozen *******************************
op clearAllFrozen : SModule -> SModule [memo] .
eq clearAllFrozen(
(mod Q:Qid is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
O:OpDeclSet
M:MembAxSet E:EquationSet R:RuleSet endm))
= (mod (addsufix '-CLEARFROZEN To Q:Qid)
is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
clearAllFrozen(O:OpDeclSet)
M:MembAxSet E:EquationSet R:RuleSet endm) .
op clearAllFrozen : FModule -> FModule [memo] .
eq clearAllFrozen(
(fmod Q:Qid is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
O:OpDeclSet
M:MembAxSet E:EquationSet endfm))
= (fmod (addsufix '-CLEARFROZEN To Q:Qid)
is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
clearAllFrozen(O:OpDeclSet)
M:MembAxSet E:EquationSet endfm) .
op clearAllFrozen : OpDeclSet -> OpDeclSet .
eq clearAllFrozen(none)
= none .
eq clearAllFrozen(
(op F : TPL -> TP [frozen(NL) AtS] .) O:OpDeclSet)
= (op F : TPL -> TP [AtS] .)
clearAllFrozen(O:OpDeclSet) .
eq clearAllFrozen(
(op F : TPL -> TP [AtS] .) O:OpDeclSet)
= (op F : TPL -> TP [AtS] .)
clearAllFrozen(O:OpDeclSet) [owise] .
*** anyNonExec *******************************
op anyNonExec : SModule -> Bool [memo] .
eq anyNonExec(
(mod Q:Qid is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
O:OpDeclSet M:MembAxSet E:EquationSet R:RuleSet endm))
= anyNonExec(E:EquationSet) or-else anyNonExec(R:RuleSet) .
op anyNonExec : RuleSet -> Bool .
eq anyNonExec(
(rl Lhs => Rhs [nonexec AtS] .) R:RuleSet)
= true .
eq anyNonExec(
(crl Lhs => Rhs if Cond [nonexec AtS] .) R:RuleSet)
= true .
eq anyNonExec(R:RuleSet)
= false [owise] .
op anyNonExec : EquationSet -> Bool .
eq anyNonExec(
(eq Lhs = Rhs [nonexec AtS] .) R:EquationSet)
= true .
eq anyNonExec(
(ceq Lhs = Rhs if Cond [nonexec AtS] .) R:EquationSet)
= true .
eq anyNonExec(R:EquationSet)
= false [owise] .
*** clearNonExec *******************************
op clearNonExec : SModule -> SModule [memo] .
eq clearNonExec(
(mod Q:Qid is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
O:OpDeclSet M:MembAxSet E:EquationSet R:RuleSet endm))
= (mod (addsufix '-CLEARNONEXEC To Q:Qid)
is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
O:OpDeclSet M:MembAxSet
clearNonExec(E:EquationSet) clearNonExec(R:RuleSet) endm) .
op clearNonExec : FModule -> FModule [memo] .
eq clearNonExec(
(fmod Q:Qid is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
O:OpDeclSet M:MembAxSet E:EquationSet endfm))
= (fmod (addsufix '-CLEARNONEXEC To Q:Qid)
is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
O:OpDeclSet M:MembAxSet
clearNonExec(E:EquationSet) endfm) .
op clearNonExec : RuleSet -> RuleSet .
eq clearNonExec((none).RuleSet)
= (none).RuleSet .
eq clearNonExec(
(rl Lhs => Rhs [nonexec AtS] .) R:RuleSet)
= (rl Lhs => Rhs [AtS] .)
clearNonExec(R:RuleSet) .
eq clearNonExec(
(rl Lhs => Rhs [AtS] .) R:RuleSet)
= (rl Lhs => Rhs [AtS] .)
clearNonExec(R:RuleSet) [owise] .
op clearNonExec : EquationSet -> EquationSet .
eq clearNonExec((none).EquationSet)
= (none).EquationSet .
eq clearNonExec(
(eq Lhs = Rhs [nonexec AtS] .) R:EquationSet)
= (eq Lhs = Rhs [AtS] .)
clearNonExec(R:EquationSet) .
eq clearNonExec(
(eq Lhs = Rhs [AtS] .) R:EquationSet)
= (eq Lhs = Rhs [AtS] .)
clearNonExec(R:EquationSet) [owise] .
*** eraseRls *******************************
op eraseRls : Module -> Module [memo] .
eq eraseRls(
(mod Q:Qid is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
O:OpDeclSet M:MembAxSet E:EquationSet R:RuleSet endm))
= (mod Q:Qid is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
O:OpDeclSet M:MembAxSet E:EquationSet none endm) .
eq eraseRls(
(fmod Q:Qid is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
O:OpDeclSet M:MembAxSet E:EquationSet endfm))
= (fmod Q:Qid is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
O:OpDeclSet M:MembAxSet E:EquationSet endfm) .
*** eraseEqs *******************************
op eraseEqs : Module -> Module [memo] .
eq eraseEqs(
(mod Q:Qid is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
O:OpDeclSet M:MembAxSet E:EquationSet R:RuleSet endm))
= (mod Q:Qid is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
O:OpDeclSet M:MembAxSet none R:RuleSet endm) .
eq eraseEqs(
(fmod Q:Qid is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
O:OpDeclSet M:MembAxSet E:EquationSet endfm))
= (fmod Q:Qid is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
O:OpDeclSet M:MembAxSet none endfm) .
*** flatten ******************************
op flatten : Module TermList -> TermList .
eq flatten(M,V) = V .
eq flatten(M,C) = C .
eq flatten(M,F[TL:NeTermList])
= if isAssociative(M,F,getTypes(M,TL:NeTermList))
then F[aliens(TL:NeTermList,F)]
else F[flatten(M,TL:NeTermList)]
fi .
eq flatten(M,(T:Term,TL:NeTermList))
= (flatten(M,T:Term),flatten(M,TL:NeTermList)) .
op aliens : TermList Qid -> TermList .
eq aliens(empty,F) = empty .
eq aliens((F[TL':NeTermList],TL:TermList),F)
= aliens((TL':NeTermList,TL:TermList),F) .
eq aliens((T:Term,TL:TermList),F)
= (T:Term,aliens(TL:TermList,F)) [owise] .
*** unflatten ******************************
op unflatten : Module TermList -> TermList .
eq unflatten(M,T) = unflatten*(M,T) .
op unflatten* : Module TermList -> TermList .
eq unflatten*(M,V) = V .
eq unflatten*(M,C) = C .
eq unflatten*(M,F[TL:NeTermList])
= if isAssociative(M,F,getTypes(M,TL:NeTermList))
then unflatten**(M,F,TL:NeTermList)
else F[unflatten*(M,TL:NeTermList)]
fi .
eq unflatten*(M,(T:Term,TL:NeTermList))
= (unflatten*(M,T:Term),unflatten*(M,TL:NeTermList)) .
op unflatten** : Module Qid TermList -> TermList .
eq unflatten**(M,F,(T1:Term,TL:NeTermList))
= F[unflatten*(M,T1:Term),unflatten**(M,F,TL:NeTermList)] .
eq unflatten**(M,F,T:Term)
= unflatten*(M,T:Term) .
*** wrapRules_bySymbol_ *******************************
op wrapRules_bySymbol_ : SModule Qid -> SModule [memo] .
eq wrapRules
(mod Q:Qid is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
O:OpDeclSet
M:MembAxSet E:EquationSet R:RuleSet endm)
bySymbol F:Qid
= (mod (addsufix F:Qid To (addsufix '-WRAPPED# To Q:Qid))
is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
O:OpDeclSet
M:MembAxSet E:EquationSet
wrapRules R:RuleSet bySymbol F:Qid endm) .
op wrapRules_bySymbol_ : RuleSet Qid -> RuleSet .
eq wrapRules none bySymbol F:Qid = none .
eq wrapRules ((rl Lhs => Rhs [AtS] .) RlS:RuleSet) bySymbol F:Qid
= (rl F:Qid[Lhs] => F:Qid[Rhs] [AtS] .)
wrapRules RlS:RuleSet bySymbol F:Qid .
eq wrapRules ((crl Lhs => Rhs if Cond [AtS] .) RlS:RuleSet) bySymbol F:Qid
= (crl F:Qid[Lhs] => F:Qid[Rhs] if Cond [AtS] .)
wrapRules RlS:RuleSet bySymbol F:Qid .
op toSModule : FModule -> SModule .
eq toSModule(
fmod Q:Qid is
IL:ImportList
sorts S:SortSet .
S:SubsortDeclSet
O:OpDeclSet
M:MembAxSet
E:EquationSet
endfm)
= mod (addsufix '-CONVERTED#SMODULE To Q:Qid) is
IL:ImportList
sorts S:SortSet .
S:SubsortDeclSet
O:OpDeclSet
M:MembAxSet
E:EquationSet
none
endm .
op newName : Qid SModule -> SModule .
op newName : Qid FModule -> FModule .
eq newName(F:Qid,
fmod Q:Qid is
IL:ImportList
sorts S:SortSet .
S:SubsortDeclSet
O:OpDeclSet
M:MembAxSet
E:EquationSet
endfm)
= fmod F:Qid is
IL:ImportList
sorts S:SortSet .
S:SubsortDeclSet
O:OpDeclSet
M:MembAxSet
E:EquationSet
endfm .
eq newName(F:Qid,
mod Q:Qid is
IL:ImportList
sorts S:SortSet .
S:SubsortDeclSet
O:OpDeclSet
M:MembAxSet
E:EquationSet
R:RuleSet
endm)
= mod F:Qid is
IL:ImportList
sorts S:SortSet .
S:SubsortDeclSet
O:OpDeclSet
M:MembAxSet
E:EquationSet
R:RuleSet
endm .
***
op removeBoolEqs : Module -> Module [memo] .
eq removeBoolEqs(
(mod Q:Qid is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
O:OpDeclSet M:MembAxSet E:EquationSet R:RuleSet endm))
= (mod Q:Qid is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
O:OpDeclSet M:MembAxSet
removeBoolEqs(E:EquationSet)
R:RuleSet endm) .
eq removeBoolEqs(
(fmod Q:Qid is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
O:OpDeclSet M:MembAxSet E:EquationSet endfm))
= (fmod Q:Qid is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
O:OpDeclSet M:MembAxSet
removeBoolEqs(E:EquationSet) endfm) .
op removeBoolEqs : EquationSet -> EquationSet .
eq removeBoolEqs((eq '_and_[TL] = Rhs [AtS] .) EqS)
= removeBoolEqs(EqS) .
eq removeBoolEqs((eq 'not_[TL] = Rhs [AtS] .) EqS)
= removeBoolEqs(EqS) .
eq removeBoolEqs((eq '_or_[TL] = Rhs [AtS] .) EqS)
= removeBoolEqs(EqS) .
eq removeBoolEqs((eq '_xor_[TL] = Rhs [AtS] .) EqS)
= removeBoolEqs(EqS) .
eq removeBoolEqs((eq '_implies_[TL] = Rhs [AtS] .) EqS)
= removeBoolEqs(EqS) .
eq removeBoolEqs(EqS)
= EqS [owise] .
***
op keepOnlyACAttr : Module -> Module [memo] .
eq keepOnlyACAttr(
(mod Q:Qid is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
O:OpDeclSet M:MembAxSet E:EquationSet R:RuleSet endm))
= (mod (addsufix '-REMOVED-ID-SYMBOLS To Q:Qid)
is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
keepOnlyACAttr*(O:OpDeclSet)
M:MembAxSet E:EquationSet R:RuleSet endm) .
eq keepOnlyACAttr(
(fmod Q:Qid is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
O:OpDeclSet M:MembAxSet E:EquationSet endfm))
= (fmod (addsufix '-REMOVED-ID-SYMBOLS To Q:Qid)
is IL:ImportList sorts S:SortSet . S:SubsortDeclSet
keepOnlyACAttr*(O:OpDeclSet)
M:MembAxSet E:EquationSet endfm) .
op keepOnlyACAttr* : OpDeclSet -> OpDeclSet .
eq keepOnlyACAttr*((op F : TPL -> TP [id(T) AtS] .) OPDS)
= keepOnlyACAttr*((op F : TPL -> TP [AtS] .) OPDS) .
eq keepOnlyACAttr*((op F : TPL -> TP [left-id(T) AtS] .) OPDS)
= keepOnlyACAttr*((op F : TPL -> TP [AtS] .) OPDS) .
eq keepOnlyACAttr*((op F : TPL -> TP [right-id(T) AtS] .) OPDS)
= keepOnlyACAttr*((op F : TPL -> TP [AtS] .) OPDS) .
eq keepOnlyACAttr*(OPDS)
= keepOnlyACAttr**(OPDS) [owise] .
op _in#_ : Attr AttrSet -> Bool .
eq X:Attr in# X:Attr X:AttrSet = true .
eq X:Attr in# X:AttrSet = false [owise] .
op keepOnlyACAttr** : OpDeclSet -> OpDeclSet .
eq keepOnlyACAttr**((op F : TPL -> TP [assoc AtS] .) OPDS)
= if comm in# AtS
then (op F : TPL -> TP [assoc AtS] .) keepOnlyACAttr**(OPDS)
else keepOnlyACAttr**((op F : TPL -> TP [AtS] .) OPDS)
fi .
eq keepOnlyACAttr**(OPDS)
= OPDS [owise] .
endfm
fmod META-MINIMIZE-BINDINGS is
pr SUBSTITUTION-HANDLING .
pr MODULE-HANDLING .
pr SUBSTITUTIONSET .
pr UNIFICATIONTRIPLESET .
pr CONVERSION .
pr META-LEVEL .
var M : Module .
var T T' : Term .
var TL : TermList .
vars S S' S* S'* : Substitution .
vars V V' : Variable .
vars N N' NOld : Nat .
var US? : [UnificationTripleSet] .
var US US' : UnificationTripleSet .
--- minimizeBindings ---
op minimizeBindingsTerm : Module TermList UnificationTripleSet
-> UnificationTripleSet .
eq minimizeBindingsTerm(M,TL,US)
= minimizeBindingsTerm(M,TL,highestVar(TL),US) .
op minimizeBindingsTerm : Module TermList Nat UnificationTripleSet
-> UnificationTripleSet .
eq minimizeBindingsTerm(M,TL,NOld,US)
= minimizeBindingsTerm*(M,TL,NOld,US,empty) .
op minimizeBindingsTerm* : Module TermList Nat UnificationTripleSet
UnificationTripleSet -> UnificationTripleSet .
eq minimizeBindingsTerm*(M,TL,NOld,empty,US')
= US' .
eq minimizeBindingsTerm*(M,TL,NOld,{S,S',N} | US,US')
= minimizeBindingsTerm*(M,TL,NOld,US,
US' | minimizeBindingsTerm**(M,TL,NOld,{S,S',N},S,S')
) .
op minimizeBindingsTerm** : Module TermList ---variables to minimize bindings
Nat --- or maximum index of variables
UnificationTriple Substitution Substitution
-> UnificationTriple .
eq minimizeBindingsTerm**(M,TL,NOld,{S*,S'*,N},none,none)
= {S*,S'*,N} .
eq minimizeBindingsTerm**(M,TL,NOld,{S*,V <- V ; S'*,N},none,V <- V ; S')
= minimizeBindingsTerm**(M,TL,NOld,{S*,S'*,N},none,S') .
eq minimizeBindingsTerm**(M,TL,NOld,{S*,V <- T' ; S'*,N},none,V <- T' ; S')
= if T' :: Variable
and-then not (V in TL) and-then not (T' in TL)
and-then highestVar(V) < NOld
and-then highestVar(T') >= NOld
and-then typeLeq(M,getTypes(M,V),getTypes(M,T'))
then minimizeBindingsTerm**(M,TL,NOld,
{S* << (T' <- V),S'* .. (T' <- V),N},
none,S' .. (T' <- V))
else minimizeBindingsTerm**(M,TL,NOld,{S*,V <- T' ; S'*,N},none,S')
fi .
eq minimizeBindingsTerm**(M,TL,NOld,{V <- V ; S*,S'*,N},V <- V ; S,S')
= minimizeBindingsTerm**(M,TL,NOld,{S*,S'*,N},S,S') .
eq minimizeBindingsTerm**(M,TL,NOld,{V <- T' ; S*,S'*,N},V <- T' ; S,S')
= if T' :: Variable
and-then V in TL and-then not (T' in TL)
and-then typeLeq(M,getTypes(M,V),getTypes(M,T'))
then minimizeBindingsTerm**(M,TL,NOld,
{S* << (T' <- V),S'* .. (T' <- V),N},
S << (T' <- V),S' .. (T' <- V))
else minimizeBindingsTerm**(M,TL,NOld,{V <- T' ; S*,S'*,N},S,S')
fi .
endfm
fmod TYPEOFNARROWING is
pr QID .
--- TypeOfNarrowing ----------------------------------
sorts TypeOfNarrowingElem TypeOfNarrowing .
subsort TypeOfNarrowingElem < TypeOfNarrowing .
op none : -> TypeOfNarrowing [ctor] .
op __ : TypeOfNarrowing TypeOfNarrowing -> TypeOfNarrowing
[ctor assoc comm id: none] .
---eq X:TypeOfNarrowingElem X:TypeOfNarrowingElem = X:TypeOfNarrowingElem .
*** select one and only one of the following
op full : -> TypeOfNarrowingElem [ctor] .
op basic : -> TypeOfNarrowingElem [ctor] .
op variant : -> TypeOfNarrowingElem [ctor] .
op variant : Nat -> TypeOfNarrowingElem [ctor] .
op E-rewriting : -> TypeOfNarrowingElem [ctor] .
*** select one and only one of the following
op E-ACU-unify : -> TypeOfNarrowingElem [ctor] .
op E-ACU-unify-Irr : -> TypeOfNarrowingElem [ctor] .
op E-AC-unify : -> TypeOfNarrowingElem [ctor] .
op E-AC-unify-Irr : -> TypeOfNarrowingElem [ctor] .
op ACU-unify : -> TypeOfNarrowingElem [ctor] .
op AC-unify : -> TypeOfNarrowingElem [ctor] .
op BuiltIn-unify : -> TypeOfNarrowingElem [ctor] .
op E-BuiltIn-unify : -> TypeOfNarrowingElem [ctor] .
op E-BuiltIn-unify-Irr : -> TypeOfNarrowingElem [ctor] .
*** select one and only one of the following
op noStrategy : -> TypeOfNarrowingElem [ctor] .
op topmost : -> TypeOfNarrowingElem [ctor] .
op innermost : -> TypeOfNarrowingElem [ctor] .
op outermost : -> TypeOfNarrowingElem [ctor] .
*** select any combination of the following
op E-normalize-terms : -> TypeOfNarrowingElem [ctor] .
op normalize-terms : -> TypeOfNarrowingElem [ctor] .
op computed-normalized-subs : -> TypeOfNarrowingElem [ctor] .
op applied-normalized-subs : -> TypeOfNarrowingElem [ctor] .
op minimal-unifiers : -> TypeOfNarrowingElem [ctor] .
op testUnifier : -> TypeOfNarrowingElem [ctor] .
op _in_ : TypeOfNarrowingElem TypeOfNarrowing -> Bool .
eq X:TypeOfNarrowingElem in X:TypeOfNarrowingElem XS:TypeOfNarrowing
= true .
eq variant in variant(N:Nat) XS:TypeOfNarrowing
= true .
eq X:TypeOfNarrowingElem in XS:TypeOfNarrowing
= false [owise] .
op _!in_ : TypeOfNarrowingElem TypeOfNarrowing -> Bool .
eq X:TypeOfNarrowingElem !in XS:TypeOfNarrowing
= not (X:TypeOfNarrowingElem in XS:TypeOfNarrowing) .
-------------------------------------------------------
sort TypeOfRelation .
ops '* '! '+ : -> TypeOfRelation .
op [_] : TypeOfRelation -> Qid .
eq [ '+ ] = qid("+") .
eq [ '* ] = qid("*") .
eq [ '! ] = qid("!") .
op typeOfRelation : Qid ~> TypeOfRelation .
eq typeOfRelation( '+ ) = '+ .
eq typeOfRelation( '* ) = '* .
eq typeOfRelation( '! ) = '! .
endfm
fmod RESULT-CONTEXT-SET is
protecting META-TERM .
protecting META-LEVEL .
protecting TERM-HANDLING .
protecting SUBSTITUTION-HANDLING .
protecting RENAMING .
protecting SUBSTITUTIONSET .
protecting UNIFICATIONTRIPLESET .
vars T T' TS CtTS : Term .
var TP : Type .
vars S S' Subst Subst' : Substitution .
var NL : NatList .
var M : Module .
vars Ct CtS : Context .
vars RTS RTS' : ResultContextSet .
vars NextVar N : Nat .
var TL : TermList .
op subTerm_of_ : NatList ResultTriple ~> ResultTriple .
eq subTerm NL of {T,TP,S} = {subTerm NL of T,TP,S} .
op replaceSubTerm_of_by_ : NatList ResultTriple Term ~> ResultTriple .
eq replaceSubTerm NL of {T,TP,S} by T' = {replaceSubTerm NL of T by T',TP,S} .
--- ResultTriple ---------------------------
--- op {_,_,_} : Term Type Substitution -> ResultTriple [ctor] .
sort ResultTripleSet .
subsort ResultTriple < ResultTripleSet .
op empty : -> ResultTripleSet [ctor] .
op _|_ : ResultTripleSet ResultTripleSet -> ResultTripleSet
[ctor assoc comm id: empty prec 65 format (d d n d)] .
eq X:ResultTriple | X:ResultTriple = X:ResultTriple .
var RT : ResultTripleSet .
op _|>_ : ResultTripleSet TermList -> ResultTripleSet .
eq (empty).ResultTripleSet |> TL = (empty).ResultTripleSet .
eq ({T,TP,S} | RT) |> TL = {T,TP,S |> TL} | (RT |> TL) .
eq (failure | RT ) |> TL = failure | (RT |> TL) .
op getTerms : ResultTripleSet -> TermSet .
eq getTerms({T:Term,TP:Type,S:Substitution} | R:ResultTripleSet)
= T:Term | getTerms(R:ResultTripleSet) .
eq getTerms((empty).ResultTripleSet)
= emptyTermSet .
op getSubstitutions : ResultTripleSet -> SubstitutionSet .
eq getSubstitutions({T,TP,S} | R:ResultTripleSet)
= S | getSubstitutions(R:ResultTripleSet) .
eq getSubstitutions((empty).ResultTripleSet)
= (empty).SubstitutionSet .
--- ResultContextSet ---------------------------
--- Flags
sort Flags Flag .
subsort Flag < Flags .
op empty : -> Flags [ctor] .
op __ : Flags Flags -> Flags [ctor assoc comm id: empty] .
eq X:Flag X:Flag = X:Flag .
--- Flag to know whether term is a end point or not
op end : Bool -> Flag [ctor frozen] .
op end : Bool Flags -> Flags .
eq end(B:Bool, end(B':Bool) B:Flags) = end(B:Bool) B:Flags .
eq end(B:Bool, B:Flags) = end(B:Bool) B:Flags [owise] .
op end : Flags -> Bool .
eq end(end(B:Bool) B:Flags) = B:Bool .
eq end(B:Flags) = false [owise] .
---
sorts ResultContext ResultContextSet ResultContextNeSet .
op {_,_,_,_,_,_,_,_,_,_} :
Term Type
Substitution Substitution --- computed subs and applied subst
Context Context --- Original and WithSubst
Term Term --- TermWithSubst and ContextWithTermAndSubt
Nat --- highest index of variable
Flags
-> ResultContext [ctor] .
subsort ResultContext < ResultContextNeSet < ResultContextSet .
op empty : -> ResultContextSet [ctor] .
op _|_ : ResultContextSet ResultContextSet -> ResultContextSet
[ctor assoc comm id: empty prec 65 format (d n d d)] .
op _|_ : ResultContextNeSet ResultContextSet -> ResultContextNeSet
[ctor ditto] .
eq X:ResultContext | X:ResultContext = X:ResultContext .
op getCTTerm : ResultContext -> Term .
eq getCTTerm(
{T,TP,S,S',Ct:Context,CtS:Context,TS:Term,CtTS:Term,NextVar,B:Flags})
= CtTS:Term .
op getNextVar : ResultContext -> Nat .
eq getNextVar(
{T,TP,S,S',Ct:Context,CtS:Context,TS:Term,CtTS:Term,NextVar,B:Flags})
= NextVar .
op getLSubst : ResultContext -> Substitution .
eq getLSubst(
{T,TP,S,S',Ct:Context,CtS:Context,TS:Term,CtTS:Term,NextVar,B:Flags})
= S .
op getRSubst : ResultContext -> Substitution .
eq getRSubst(
{T,TP,S,S',Ct:Context,CtS:Context,TS:Term,CtTS:Term,NextVar,B:Flags})
= S' .
op _<<_ : ResultContext UnificationTripleSet -> ResultContextSet .
eq {T,TP,S,S',Ct:Context,CtS:Context,TS:Term,CtTS:Term,NextVar,B:Flags}
<< (empty).UnificationTripleSet
= (empty).ResultContextSet .
eq {T,TP,S,S',Ct:Context,CtS:Context,TS:Term,CtTS:Term,NextVar,B:Flags}
<< ({Subst,Subst',N} | SS:UnificationTripleSet)
= {T,
TP,
(S .. Subst) << Subst', (S' .. Subst') << Subst,
Ct:Context,
CtS:Context << (Subst ; Subst'),
TS:Term << (Subst ; Subst'),
CtTS:Term << (Subst ; Subst'),
max(NextVar,N + 1),
B:Flags}
| {T,TP,S,S',Ct:Context,CtS:Context,TS:Term,CtTS:Term,NextVar,B:Flags}
<< SS:UnificationTripleSet .
op toTriple : Module ResultContextSet -> ResultTripleSet .
eq toTriple(M, empty ) = empty .
eq toTriple(M, {T,TP,S,S',Ct,CtS,TS:Term,CtTS:Term,NextVar,B:Flags} | RTS )
= {CtTS:Term, leastSort(M,CtTS:Term), S .. S'}
| toTriple(M,RTS) .
op _|>_ : ResultContextSet TermList -> ResultContextSet .
eq (empty).ResultContextSet |> TL = (empty).ResultContextSet .
eq ({T,TP,S,S',Ct,CtS,TS:Term,CtTS:Term,NextVar,B:Flags}
| RTS:ResultContextSet) |> TL
= {T,TP,S |> TL,S' |> TL,Ct,CtS,TS:Term,CtTS:Term,NextVar,B:Flags}
| (RTS:ResultContextSet |> TL) .
op getTerms : ResultContextSet -> TermSet .
eq getTerms({T,TP,S,S',Ct,CtS,TS:Term,CtTS:Term,NextVar,B:Flags} | RTS)
= CtTS:Term | getTerms(RTS) .
eq getTerms((empty).ResultContextSet)
= emptyTermSet .
op toUnificationTriples : ResultContextSet -> UnificationTripleSet .
eq toUnificationTriples(
{T,TP,S,S',Ct,CtS,TS,CtTS,NextVar,B:Flags} | R:ResultContextSet)
= {S,S',NextVar}
| toUnificationTriples(R:ResultContextSet) .
eq toUnificationTriples((empty).ResultContextSet)
= (empty).UnificationTripleSet .
*** auxiliary Sort SubstitutionCond for metaNarrowSearch *****
sort SubstitutionCond .
subsort Substitution < SubstitutionCond .
op |_| : ResultTripleSet -> Nat .
eq | (empty).ResultTripleSet | = 0 .
eq | (RT:ResultTriple | RTS:ResultTripleSet) |
= | RTS:ResultTripleSet | + 1 .
op |_| : ResultContextSet -> Nat .
eq | (empty).ResultContextSet | = 0 .
eq | (RT:ResultContext | RTS:ResultContextSet) |
= | RTS:ResultContextSet | + 1 .
endfm
fmod IRR-FLAGS is
sort IrrFlags .
op __ : IrrFlags IrrFlags -> IrrFlags [assoc comm id: none] .
op none : -> IrrFlags [ctor] .
op irreducible : -> IrrFlags [ctor] .
op reducible : -> IrrFlags [ctor] .
op minimal-unifiers : -> IrrFlags [ctor] .
endfm
fmod EFLAGS is
pr TYPEOFNARROWING .
pr IRR-FLAGS .
sort EFlags .
subsort IrrFlags < EFlags .
op __ : EFlags EFlags -> EFlags [assoc comm id: none] .
op none : -> EFlags [ctor] .
op ACUUnify : -> EFlags [ctor] .
op ACUnify : -> EFlags [ctor] .
op BuiltInUnify : -> EFlags [ctor] .
op testUnifier : -> EFlags [ctor] .
op _in_ : EFlags EFlags -> Bool .
eq X:EFlags in X:EFlags Y:EFlags = true .
eq X:EFlags in Y:EFlags = false [owise] .
op _!in_ : EFlags EFlags -> Bool .
eq X:EFlags !in Y:EFlags = not (X:EFlags in Y:EFlags) .
op [_] : EFlags -> TypeOfNarrowing .
eq [ ACUUnify X:EFlags ] = ACU-unify [ X:EFlags ] .
eq [ ACUnify X:EFlags ] = AC-unify [ X:EFlags ] .
eq [ BuiltInUnify X:EFlags ] = BuiltIn-unify [ X:EFlags ] .
eq [ minimal-unifiers X:EFlags ] = minimal-unifiers [ X:EFlags ] .
eq [ testUnifier X:EFlags ] = testUnifier [ X:EFlags ] .
eq [ X:EFlags ] = none [owise] .
endfm
fmod VARIANT is
pr SUBSTITUTION-HANDLING .
pr META-MINIMIZE-BINDINGS .
pr RESULT-CONTEXT-SET .
pr MODULE-HANDLING .
pr META-LEVEL .
var M : Module .
vars T T' TS TS' CtTS CtTS' Lhs Rhs : Term .
vars N N' NextVar NextVar' NextVar'' : Nat .
var B : Bound .
var TL TL' : TermList .
var NeTL : NeTermList .
var EqS : EquationSet .
var AtS : AttrSet .
var Q : Qid .
vars S S' : Substitution .
var V : Variable .
var R RT : ResultContext .
vars RTS RTS' : ResultContextSet .
vars TP TP' : Type .
vars Ct Ct' CtS CtS' : Context .
var C : Constant .
vars F F' : Qid .
--- Variants ----------------------------------------------------------
sort VariantTriple .
op {_,_,_} : Term Substitution Nat -> VariantTriple [ctor] .
sort VariantTripleSet .
subsort VariantTriple < VariantTripleSet .
op empty : -> VariantTripleSet [ctor] .
op _|_ : VariantTripleSet VariantTripleSet -> VariantTripleSet
[ctor assoc comm id: empty prec 65 format (d d n d)] .
eq X:VariantTriple | X:VariantTriple = X:VariantTriple .
op getTerms : VariantTripleSet -> TermSet .
eq getTerms({T:Term,S:Substitution,NextVar:Nat}
| R:VariantTripleSet)
= T:Term | getTerms(R:VariantTripleSet) .
eq getTerms((empty).VariantTripleSet)
= emptyTermSet .
--- Variants ----------------------------------------------------------
sort VariantFour .
op {_,_,_,_} : Term Substitution Substitution Nat -> VariantFour [ctor] .
sort VariantFourSet .
subsort VariantFour < VariantFourSet .
op empty : -> VariantFourSet [ctor] .
op _|_ : VariantFourSet VariantFourSet -> VariantFourSet
[ctor assoc comm id: empty prec 65 format (d d n d)] .
eq X:VariantFour | X:VariantFour = X:VariantFour .
var VT : VariantFour .
vars VTS VTS' : VariantFourSet .
op toVariants : Nat ResultContextSet -> VariantFourSet .
eq toVariants(OldNextVar:Nat,empty)
= empty .
eq toVariants(OldNextVar:Nat,{T,TP,S,S',Ct,CtS,TS,CtTS,NextVar,B:Flags} | RTS)
= {CtTS,S |> OldNextVar:Nat,S' |> OldNextVar:Nat,NextVar}
| toVariants(OldNextVar:Nat,RTS) .
op _|>_ : VariantFourSet TermList -> VariantFourSet .
eq (empty).VariantFourSet |> TL = empty .
eq ({T,S,S',N} | VTS) |> TL = {T,(S |> TL),(S' |> TL),N} | (VTS |> TL) .
op getTerms : VariantFourSet -> TermSet .
eq getTerms({T:Term,S:Substitution,S':Substitution,NextVar:Nat}
| R:VariantFourSet)
= T:Term | getTerms(R:VariantFourSet) .
eq getTerms((empty).VariantFourSet)
= emptyTermSet .
op toVariantTripleSet : VariantFourSet -> VariantTripleSet .
eq toVariantTripleSet(empty)
= empty .
eq toVariantTripleSet({T,S,S',NextVar} | VTS)
--- = {T,S ; S',NextVar} | toVariantTripleSet(VTS) .
= {T,S,NextVar} | toVariantTripleSet(VTS) .
endfm
fmod RIGIDIFE is
protecting UNIFICATIONTRIPLESET .
protecting MODULE-HANDLING .
protecting RESULT-CONTEXT-SET .
protecting VARIANT .
vars V V' : Variable .
var C : Constant .
vars F Q : Qid .
vars U U' : UnificationTriple .
vars US US' : UnificationTripleSet .
vars S S' S1 S1' S2 S2' : Substitution .
var SS : SubstitutionSet .
var SSe : NeSubstitutionSet .
vars N N' N1 N2 NextVar : Nat .
vars T T' : Term .
vars TL TL' : TermList .
var NeTL : NeTermList .
var M : Module .
var RTS : ResultTripleSet .
var TP : Type .
sort PairRigidife .
op {_,_} : Module TermList -> PairRigidife .
op getM : PairRigidife -> Module .
eq getM({M,TL}) = M .
op getTL : PairRigidife -> TermList .
eq getTL({M,TL}) = TL .
*** Transform variables in TermList into constants
op rigidifeList : Module Qid TermList TermList -> PairRigidife .
eq rigidifeList(M,Q,TL,empty)
= {M,TL} .
eq rigidifeList(M,Q,(T,NeTL),TL)
= { getM(rigidifeList(getM(rigidifeList(M,Q,T,TL)),Q,NeTL,TL)),
(getTL(rigidifeList(M,Q,T,TL)),
getTL(rigidifeList(getM(rigidifeList(M,Q,T,TL)),Q,NeTL,TL))) } .
eq rigidifeList(M,Q,C,TL)
= {M,C} .
eq rigidifeList(M,Q,F[NeTL],TL)
= {getM(rigidifeList(M,Q,NeTL,TL)),
F[getTL(rigidifeList(M,Q,NeTL,TL))]} .
eq rigidifeList(M,Q,V,TL)
= if V in TL then rigidifeVar***(M,Q,V) else {M,V} fi .
*** Transform variables above Nat into constants
op rigidifeNat : Module Qid TermList Nat -> PairRigidife .
eq rigidifeNat(M,Q,(T,NeTL),N)
= { getM(rigidifeNat(getM(rigidifeNat(M,Q,T,N)),Q,NeTL,N)),
(getTL(rigidifeNat(M,Q,T,N)),
getTL(rigidifeNat(getM(rigidifeNat(M,Q,T,N)),Q,NeTL,N))) } .
eq rigidifeNat(M,Q,C,N)
= {M,C} .
eq rigidifeNat(M,Q,F[NeTL],N)
= {getM(rigidifeNat(M,Q,NeTL,N)),
F[getTL(rigidifeNat(M,Q,NeTL,N))]} .
eq rigidifeNat(M,Q,V,N)
= if highestVar(V) >= N then rigidifeVar***(M,Q,V) else {M,V} fi .
*** Transform variables with rigig# into constants
op rigidife : Module Qid TermList -> PairRigidife .
eq rigidife(M,Q,(T,NeTL))
= { getM(rigidife(getM(rigidife(M,Q,T)),Q,NeTL)),
(getTL(rigidife(M,Q,T)),
getTL(rigidife(getM(rigidife(M,Q,T)),Q,NeTL))) } .
eq rigidife(M,Q,C)
= {M,C} .
eq rigidife(M,Q,F[NeTL])
= {getM(rigidife(M,Q,NeTL)),
F[getTL(rigidife(M,Q,NeTL))]} .
eq rigidife(M,Q,V)
= if rfind(string(V), "rigid#", length(string(V))) =/= notFound
then rigidifeVar***(M,Q,V)
else {M,V}
fi .
*** Basic case for transforming variables into constants
op rigidifeVar*** : Module Qid Variable -> PairRigidife .
eq rigidifeVar***(M,Q,V)
= {addOps((op qid("rigid@" + string(Q) + "@" + string(getName(V)))
: nil -> getType(V) [none].)
,M),
qid("rigid@" + string(Q) + "@" + string(getName(V))
+ "." + string(getType(V)))} .
*** Undo the transformation of variables into constants
op unrigidife : Qid TermList -> TermList .
eq unrigidife(Q,(T,NeTL))
= (unrigidife(Q,T),unrigidife(Q,NeTL)) .
eq unrigidife(Q,V) = V .
eq unrigidife(Q,F[TL]) = F[unrigidife(Q,TL)] .
eq unrigidife(Q,C)
= if rfind(string(C), "rigid@" + string(Q) + "@", length(string(C)))
=/= notFound
then qid(
string(getName(qid(
substr(string(C),
rfind(string(C), "rigid@" + string(Q) + "@",
length(string(C))) + 7 + length(string(Q)),
length(string(C)))
)))
+ ":" +
string(getType(qid(
substr(string(C),
rfind(string(C), "rigid@" + string(Q) + "@",
length(string(C))) + 7 + length(string(Q)),
length(string(C)))
)))
)
else C
fi .
op unrigidife : Qid Substitution -> Substitution .
eq unrigidife(Q,(none).Substitution) = none .
eq unrigidife(Q,V <- T ; S)
= unrigidife(Q,V) <- unrigidife(Q,T) ; unrigidife(Q,S) .
op unrigidife : Qid SubstitutionSet -> SubstitutionSet .
eq unrigidife(Q,(empty).SubstitutionSet) = empty .
eq unrigidife(Q,S | SSe)
= unrigidife(Q,S) | unrigidife(Q,SSe) .
op unrigidife : Qid UnificationTripleSet -> UnificationTripleSet .
eq unrigidife(Q,(empty).UnificationTripleSet) = empty .
eq unrigidife(Q,{S1,S2,N'} | US)
= {unrigidife(Q,S1),unrigidife(Q,S2),N'}
| unrigidife(Q,US) .
op unrigidife : Qid ResultTripleSet -> ResultTripleSet .
eq unrigidife(Q,(empty).ResultTripleSet) = empty .
eq unrigidife(Q,{T,TP,S} | RTS)
= {unrigidife(Q,T),TP,unrigidife(Q,S)}
| unrigidife(Q,RTS) .
op unrigidife : Qid VariantFourSet -> VariantFourSet .
eq unrigidife(Q,(empty).VariantFourSet) = empty .
eq unrigidife(Q,{T,S,S',N} | R:VariantFourSet)
= {unrigidife(Q,T),unrigidife(Q,S),unrigidife(Q,S'),N}
| unrigidife(Q,R:VariantFourSet) .
*** Label variables with rigid
op rigidLabel : Module TermList TermList -> TermList .
eq rigidLabel(M,TL,empty)
= TL .
eq rigidLabel(M,(T,NeTL),TL)
= rigidLabel(M,T,TL), rigidLabel(M,NeTL,TL) .
eq rigidLabel(M,C,TL)
= C .
eq rigidLabel(M,F[NeTL],TL)
= F[rigidLabel(M,NeTL,TL)] .
eq rigidLabel(M,V,TL)
= if V in TL then rigidLabel***(M,V) else V fi .
op rigidLabel*** : Module Variable -> Variable .
eq rigidLabel***(M,V)
= qid("rigid#" + string(getName(V)) + ":" + string(getType(V))) .
*** Undo the transformation of variables into constants
op unrigidLabel : TermList -> TermList .
eq unrigidLabel((T,NeTL))
= (unrigidLabel(T),unrigidLabel(NeTL)) .
eq unrigidLabel(C) = C .
eq unrigidLabel(F[TL]) = F[unrigidLabel(TL)] .
eq unrigidLabel(V)
= if rfind(string(V), "rigid#", length(string(V)))
=/= notFound
then qid(
string(getName(qid(
substr(string(V),
rfind(string(V), "rigid#",
length(string(V))) + 6,
length(string(V)))
)))
+ ":" +
string(getType(qid(
substr(string(V),
rfind(string(V), "rigid#",
length(string(V))) + 6,
length(string(V)))
)))
)
else V
fi .
op unrigidLabel : Substitution -> Substitution .
eq unrigidLabel((none).Substitution) = none .
eq unrigidLabel(V <- T ; S)
= unrigidLabel(V) <- unrigidLabel(T) ; unrigidLabel(S) .
op unrigidLabel : SubstitutionSet -> SubstitutionSet .
eq unrigidLabel((empty).SubstitutionSet) = empty .
eq unrigidLabel(S | SSe)
= unrigidLabel(S) | unrigidLabel(SSe) .
op unrigidLabel : UnificationTripleSet -> UnificationTripleSet .
eq unrigidLabel((empty).UnificationTripleSet) = empty .
eq unrigidLabel({S1,S2,N'} | US)
= {unrigidLabel(S1),unrigidLabel(S2),N'}
| unrigidLabel(US) .
op unrigidLabel : ResultTripleSet -> ResultTripleSet .
eq unrigidLabel((empty).ResultTripleSet) = empty .
eq unrigidLabel({T,TP,S} | RTS)
= {unrigidLabel(T),TP,unrigidLabel(S)}
| unrigidLabel(RTS) .
op unrigidLabel : VariantFourSet -> VariantFourSet .
eq unrigidLabel((empty).VariantFourSet) = empty .
eq unrigidLabel({T,S,S',N} | R:VariantFourSet)
= {unrigidLabel(T),unrigidLabel(S),unrigidLabel(S'),N}
| unrigidLabel(R:VariantFourSet) .
op qid : Nat -> Qid .
eq qid(N:Nat) = qid(string(N:Nat,10)) .
endfm
fmod META-E-BASIC-UNIFICATION is
pr TYPEOFNARROWING .
pr EFLAGS .
pr RESULT-CONTEXT-SET .
pr SUBSTITUTION-HANDLING .
pr META-MINIMIZE-BINDINGS .
pr RESULT-CONTEXT-SET .
pr MODULE-HANDLING .
pr META-LEVEL .
pr RIGIDIFE .
*** Repeated definitions to avoid cross calls between modules ************
op metaNarrowSearchGenAll : Module Term Term SubstitutionCond
TypeOfRelation Bound Bound TypeOfNarrowing Nat
-> ResultContextSet .
op metaACUnify : Module Term Term Nat -> UnificationTripleSet .
*** Repeated definitions to avoid cross calls between modules ************
var M : Module .
var M' : [Module] .
vars T T' : Term .
vars NextVar N : Nat .
var EF : EFlags .
var F : Qid .
--- metaEUnify-Basic --------------------------------------------------
op metaEUnify-Basic : Module Term Term Nat EFlags
--- Term Lhs
-> UnificationTripleSet .
eq metaEUnify-Basic(M,T,T',NextVar,EF)
= if getEqsNoLabel(M) == none
then metaACUnify(M,T,T',NextVar)
else metaEUnify-Basic*(M,T,T',NextVar,EF)
fi .
op metaEUnify-Basic* : Module Term Term Nat EFlags
--- Term Lhs
-> UnificationTripleSet .
eq metaEUnify-Basic*(M,T,T',NextVar,EF)
= if glbSorts(M,leastSort(M,T),leastSort(M,T')) =/= none
then minimizeBindingsTerm(M,Vars(T),NextVar + 1,
toUnificationTriples(
metaNarrowSearchGenAll(
add=E=(new=E=(NextVar),
eqs2rls(clearAllFrozen(M)),
maximalSorts(M,getKind(M,leastSort(M,T)))),
new=E=(NextVar)[T',T],
none,
'!,
unbounded,
unbounded,
basic noStrategy [EF],
NextVar + 1
) |> (T,T')
)
)
else (empty).UnificationTripleSet
fi .
op new=E= : Nat -> Qid .
eq new=E=(N)
= qid("_=E" + string(N,10) + "=_") .
op add=E= : Qid Module SortSet -> Module .
eq add=E=(F,M,none)
= M .
eq add=E=(F,M,S:Sort ; SS:SortSet)
= add=E=(F,
addRules(
(rl F[(addType S:Sort ToVar 'X),(addType S:Sort ToVar 'X)]
=> 'true.Bool [none] .),
addOps(op F : S:Sort S:Sort -> 'Bool [frozen(2)] .,
M)),
SS:SortSet) .
endfm
fmod META-E-UNIFICATION is
pr TYPEOFNARROWING .
pr EFLAGS .
pr RESULT-CONTEXT-SET .
pr SUBSTITUTION-HANDLING .
pr META-MINIMIZE-BINDINGS .
pr RESULT-CONTEXT-SET .
pr MODULE-HANDLING .
pr META-LEVEL .
pr META-E-BASIC-UNIFICATION .
pr VARIANT .
*** Repeated definitions to avoid cross calls between modules ************
op normalizedSubstitution? : Module SubstitutionSet -> Bool .
op metaACUUnify : Module Term Term Nat -> UnificationTripleSet .
op metaACUnify : Module Term Term Nat -> UnificationTripleSet .
op metaACUnify? : Module Term Term Nat -> Bool .
op metaACUnify* : Module UnificandPair Nat Nat ~> UnificationTriple? .
op metaCoreUnify : Module Term Term Nat -> UnificationTripleSet .
op metaCoreUnify? : Module Term Term Nat -> Bool .
op metaBuiltInUnify : Module Term Term Nat -> UnificationTripleSet .
op metaBuiltInUnify? : Module Term Term Nat -> Bool .
op _<=[_]_ : SubstitutionSet Module SubstitutionSet -> Bool .
op _<=[_]_ : Term Module Term -> Bool .
*** Repeated definitions to avoid cross calls between modules ************
var M : Module .
vars T T' TS TS' CtTS CtTS' Lhs Rhs : Term .
vars N N' NextVar NextVar' NextVar'' : Nat .
var B : Bound .
var TL TL' : TermList .
var NeTL : NeTermList .
var EqS : EquationSet .
var AtS : AttrSet .
var ON : TypeOfNarrowing .
var Q : Qid .
vars US US' US$ : UnificationTripleSet .
vars U U' : UnificationTriple .
vars S S' S* S'* : Substitution .
var V : Variable .
var R RT : ResultContext .
vars RTS RTS' : ResultContextSet .
vars TP TP' : Type .
vars Ct Ct' CtS CtS' : Context .
var C : Constant .
vars F F' : Qid .
var EF : EFlags .
vars VT VT' : VariantFour .
vars VTS VTS' VTS$ : VariantFourSet .
var IRR : IrrFlags .
--- metaECoreUnify --------------------------------------------------
op metaECoreUnify : Module Term Term -> SubstitutionSet .
--- Term Lhs
eq metaECoreUnify(M, T, T')
= metaEACUnify(M, T, T') .
op metaECoreUnify? : Module Term Term -> Bool .
eq metaECoreUnify?(M, T, T')
= metaEACUnify?(M, T, T') .
--- metaEACUUnify --------------------------------------------------
op metaEACUUnify : Module Term Term -> SubstitutionSet .
eq metaEACUUnify(M, T, T')
= toSubstitution(metaEACUUnify(M,T,T',highestVar((T,T')) + 1,reducible)) .
op metaEACUUnify? : Module Term Term -> Bool .
eq metaEACUUnify?(M, T, T')
= metaEACUUnify?(M,T,T',highestVar((T,T')) + 1,reducible) .
op metaEACUUnifyIrr : Module Term Term -> SubstitutionSet .
--- T irreducible T' reducible
eq metaEACUUnifyIrr(M, T, T')
= toSubstitution(metaEACUUnify(M,T,T',highestVar((T,T')) + 1,irreducible)) .
op metaEACUUnifyIrr? : Module Term Term -> Bool .
eq metaEACUUnifyIrr?(M, T, T')
= metaEACUUnify?(M,T,T',highestVar((T,T')) + 1,irreducible) .
op metaEACUUnify : Module Term Term Nat IrrFlags -> UnificationTripleSet .
eq metaEACUUnify(M, T, T',NextVar,IRR)
= minimizeBindingsTerm(M,Vars(T),NextVar,
metaEUnify&(M, T, T',NextVar,ACUUnify IRR)
) |> (T,T') .
op metaEACUUnify? : Module Term Term Nat IrrFlags -> Bool .
eq metaEACUUnify?(M, T, T',NextVar,IRR)
= metaEUnify&?(M, T, T',NextVar,ACUUnify IRR) .
--- metaEACUnify --------------------------------------------------
op metaEACUnify : Module Term Term -> SubstitutionSet .
eq metaEACUnify(M, T, T')
= toSubstitution(metaEACUnify(M,T,T',highestVar((T,T')) + 1,reducible)) .
op metaEACUnify? : Module Term Term -> Bool .
eq metaEACUnify?(M, T, T')
= metaEACUnify?(M,T,T',highestVar((T,T')) + 1,reducible) .
op metaEACUnifyIrr : Module Term Term -> SubstitutionSet .
--- T irreducible T' reducible
eq metaEACUnifyIrr(M, T, T')
= toSubstitution(metaEACUnify(M,T,T',highestVar((T,T')) + 1,irreducible)) .
op metaEACUnifyIrr? : Module Term Term -> Bool .
--- T irreducible T' reducible
eq metaEACUnifyIrr?(M, T, T')
= metaEACUnify?(M,T,T',highestVar((T,T')) + 1,irreducible) .
op metaEACUnify : Module Term Term Nat IrrFlags
-> UnificationTripleSet .
eq metaEACUnify(M, T, T',NextVar,IRR)
= minimizeBindingsTerm(M,Vars(T),NextVar,
metaEUnify&(M, T, T',NextVar,ACUnify IRR)
) |> (T,T') .
op metaEACUnify? : Module Term Term Nat IrrFlags -> Bool .
eq metaEACUnify?(M, T, T',NextVar,IRR)
= metaEUnify&?(M, T, T',NextVar,ACUnify IRR) .
--- metaEBuiltInUnify --------------------------------------------------
op metaEBuiltInUnify : Module Term Term -> SubstitutionSet .
eq metaEBuiltInUnify(M, T, T')
= toSubstitution(
metaEBuiltInUnify(M,T,T',highestVar((T,T')) + 1,reducible)
) .
op metaEBuiltInUnify? : Module Term Term -> Bool .
eq metaEBuiltInUnify?(M, T, T')
= metaEBuiltInUnify?(M,T,T',highestVar((T,T')) + 1,reducible) .
op metaEBuiltInUnifyIrr : Module Term Term -> SubstitutionSet .
--- T irreducible T' reducible
eq metaEBuiltInUnifyIrr(M, T, T')
= toSubstitution(
metaEBuiltInUnify(M,T,T',highestVar((T,T')) + 1,irreducible)
) .
op metaEBuiltInUnifyIrr? : Module Term Term -> Bool .
--- T irreducible T' reducible
eq metaEBuiltInUnifyIrr?(M, T, T')
= metaEBuiltInUnify?(M,T,T',highestVar((T,T')) + 1,irreducible) .
op metaEBuiltInUnify : Module Term Term Nat IrrFlags
-> UnificationTripleSet .
eq metaEBuiltInUnify(M, T, T',NextVar,IRR)
= minimizeBindingsTerm(M,Vars(T),NextVar,
metaEUnify&(M, T, T',NextVar,BuiltInUnify IRR)
) |> (T,T') .
op metaEBuiltInUnify? : Module Term Term Nat IrrFlags -> Bool .
eq metaEBuiltInUnify?(M, T, T',NextVar,IRR)
= metaEUnify&?(M, T, T',NextVar,BuiltInUnify IRR) .
--- metaEUnify --------------------------------------------------
op metaEUnify& : Module Term Term Nat EFlags -> UnificationTripleSet .
--- Term Lhs
eq metaEUnify&(M,T,T',NextVar,EF)
= if glbSorts(M,leastSort(M,T),leastSort(M,T')) =/= none
then metaEUnify&*(removeBoolEqs(M),T,T',NextVar,EF)
else empty
fi .
op metaEUnify&? : Module Term Term Nat EFlags -> Bool .
--- Term Lhs
eq metaEUnify&?(M,T,T',NextVar,EF)
= glbSorts(M,leastSort(M,T),leastSort(M,T')) =/= none
and-then
metaEUnify&*?(removeBoolEqs(M),T,T',NextVar,EF) .
op metaEUnify&* : Module Term Term Nat EFlags -> UnificationTripleSet .
--- Term Lhs
eq metaEUnify&*(M,T,T',NextVar,EF)
= if metaBuiltInUnify(M,
fst(generalize(onlyEqsNoLabel(M),NextVar,T)),
fst(generalize(onlyEqsNoLabel(M),
snd(generalize(onlyEqsNoLabel(M),NextVar,T)),T')),
snd(generalize(onlyEqsNoLabel(M),
snd(generalize(onlyEqsNoLabel(M),NextVar,T)),T'))
) =/= empty
then if T' == fst(
generalize(onlyEqsNoLabel(M),
snd(generalize(onlyEqsNoLabel(M),NextVar,T)),T'))
then --- no narrowing is necessary to unify
metaBuiltInUnify(M,T,T',NextVar)
else metaEUnify$(M,T,T',NextVar,EF)
fi
else empty
fi .
op metaEUnify&*? : Module Term Term Nat EFlags -> Bool .
--- Term Lhs
eq metaEUnify&*?(M,T,T',NextVar,EF)
= if metaBuiltInUnify?(M,
fst(generalize(onlyEqsNoLabel(M),NextVar,T)),
fst(generalize(onlyEqsNoLabel(M),
snd(generalize(onlyEqsNoLabel(M),NextVar,T)),T')),
snd(generalize(onlyEqsNoLabel(M),
snd(generalize(onlyEqsNoLabel(M),NextVar,T)),T'))
)
then if T' == fst(
generalize(onlyEqsNoLabel(M),
snd(generalize(onlyEqsNoLabel(M),NextVar,T)),T'))
then --- no narrowing is necessary to unify
metaBuiltInUnify?(M,T,T',NextVar)
else metaEUnify$?(M,T,T',NextVar,EF)
fi
else false
fi .
op metaEUnify$ : Module Term Term Nat EFlags -> UnificationTripleSet .
--- Term Lhs
eq metaEUnify$(M,T,T',NextVar,EF)
= if howManyBuiltIn(M,(T,T')) > 0
then metaEUnify-Variant(M,EF,NextVar,
getVariantsTerm(M,T,NextVar,EF),
getVariants(M,T',maxNextVar(getVariantsTerm(M,T,NextVar,EF)),EF)
)
else metaEUnify-Basic(M,T,T',NextVar,EF)
fi .
op metaEUnify$? : Module Term Term Nat EFlags -> Bool .
eq metaEUnify$?(M,T,T',NextVar,EF)
= if howManyBuiltIn(M,(T,T')) > 0
then metaEUnify-Variant(M,testUnifier EF,NextVar,
getVariantsTerm(M,T,NextVar,testUnifier EF),
getVariants(M,T',
maxNextVar(getVariantsTerm(M,T,NextVar,testUnifier EF)),
testUnifier EF
)
)
else metaEUnify-Basic(M,T,T',NextVar,EF)
fi =/= empty .
op metaEUnify-Variant : Module Term Term Nat EFlags
--- Term Lhs
-> UnificationTripleSet .
eq metaEUnify-Variant(M,T,T',NextVar,EF)
= if glbSorts(M,leastSort(M,T),leastSort(M,T')) =/= none
then minimizeBindingsTerm(M,Vars(T),NextVar + 1,
toUnificationTriples(
metaNarrowSearchGenAll(
add=E=(new=E=(NextVar),
eqs2rls(clearAllFrozen(M)),
maximalSorts(M,getKind(M,leastSort(M,T)))),
new=E=(NextVar)[T',T],
none,
'!,
unbounded,
unbounded,
variant(NextVar + 1) noStrategy [EF],
NextVar + 1
) |> (T,T')
)
)
else (empty).UnificationTripleSet
fi .
op getVariantsTerm : Module Term Nat EFlags -> VariantFourSet .
eq getVariantsTerm(M,T,NextVar,EF)
= if irreducible in EF
then {T,none,none,NextVar}
else getVariants(M,T,NextVar,EF)
fi .
op metaEUnify-Variant : Module EFlags Nat VariantFourSet VariantFourSet
-> UnificationTripleSet .
eq metaEUnify-Variant(M,EF,N,VTS,VTS')
= filter-variant-UP(EF,eqs2rls(clearAllFrozen(M)),N,
filter-NF(eqs2rls(clearAllFrozen(M)),
metaEUnify-Variant*(M,EF,N,VTS,VTS')
)
)
.
op metaEUnify-Variant* : Module EFlags Nat VariantFourSet VariantFourSet
-> UnificationTripleSet .
eq metaEUnify-Variant*(M,EF,N, empty, VTS')
= empty .
eq metaEUnify-Variant*(M,EF,N, VT | VTS, VTS')
= metaEUnify-Variant**(M,EF,N, VT, VTS')
|
if testUnifier in EF
and
metaEUnify-Variant**(M,EF,N, VT, VTS') =/= empty
then empty
else metaEUnify-Variant*(M,EF,N, VTS, VTS')
fi .
op metaEUnify-Variant** : Module EFlags Nat VariantFour VariantFourSet
-> UnificationTripleSet .
eq metaEUnify-Variant**(M,EF,N,VT,empty)
= empty .
eq metaEUnify-Variant**(M,EF,N,{T,S,S*,NextVar},{T',S',S'*,NextVar'} | VTS')
= metaEUnify-Variant***(M,EF,N,{T,S,S*,NextVar},{T',S',S'*,NextVar'})
| metaEUnify-Variant**(M,EF,N,{T,S,S*,NextVar}, VTS') .
op metaEUnify-Variant*** : Module EFlags Nat VariantFour VariantFour
-> UnificationTripleSet .
eq metaEUnify-Variant***(M,EF,N,{T,S,S*,NextVar},{T',S',S'*,NextVar'})
= if metaEUV***(EF,N,M,T,T',max(NextVar,NextVar')) :: UnificationTripleSet
and
metaEUV***(EF,N,M,T,T',max(NextVar,NextVar')) =/= empty
then {S,S',max(NextVar,NextVar')}
... metaEUV***(EF,N,M,T,T',max(NextVar,NextVar'))
else empty
fi .
op metaEUV*** : EFlags Nat Module Term Term Nat -> UnificationTripleSet .
--- eq metaEUV***(EF,N,M,T,T',NextVar)
--- = filter-variant-UP(minimal-unifiers EF,eqs2rls(clearAllFrozen(M)),N,
--- metaEUV****(EF,M,T,T',NextVar)
--- ) .
eq metaEUV***(EF,N,M,T,T',NextVar)
= metaEUV****(EF,M,T,T',NextVar) .
op metaEUV**** : EFlags Module Term Term Nat -> UnificationTripleSet .
eq metaEUV****(EF,M,T,T',NextVar)
= if ACUUnify in EF
then metaACUUnify(M,T,T',NextVar)
else if ACUnify in EF
then metaACUnify(M,T,T',NextVar)
else metaBuiltInUnify(M,T,T',NextVar)
fi
fi .
op getVariants : Module Term Nat EFlags -> VariantFourSet .
eq getVariants(M,T,NextVar,EF)
= unrigidife(qid(NextVar),
getVariants*(
getM(rigidife(M,qid(NextVar),T)),
getTL(rigidife(M,qid(NextVar),T)),
NextVar + 1,EF
)
) .
op getVariants* : Module Term Nat EFlags -> VariantFourSet .
eq getVariants*(M,T,NextVar,EF)
= if howMany(onlyEqsNoLabel(M),T) == 0
then {T,none,none,NextVar}
else if getVariants**(M,T,NextVar,EF) :: VariantFourSet
and
getVariants**(M,T,NextVar,EF) =/= empty
then getVariants**(M,T,NextVar,EF)
else {T,none,none,NextVar}
fi
fi .
op getVariants** : Module Term Nat EFlags -> VariantFourSet .
eq getVariants**(M,T,NextVar,EF)
= filter-variant-VT(EF, ---minimal-unifiers EF,
eqs2rls(clearAllFrozen(M)),NextVar,
toVariants(NextVar,
metaNarrowSearchGenAll(eqs2rls(clearAllFrozen(M)),
T,newVar(NextVar,leastSort(M,T)),
none,'*,unbounded,unbounded,
variant(NextVar + 1) noStrategy [EF], ---do not use innermost!!!
NextVar + 1)
)
) .
*** Identify bound for terms
sort PairGeneralize .
op {_,_} : TermList Nat -> PairGeneralize .
op fst : PairGeneralize -> TermList .
eq fst({X:TermList,Y:Nat}) = X:TermList .
op snd : PairGeneralize -> Nat .
eq snd({X:TermList,Y:Nat}) = Y:Nat .
op generalize : Module Nat NeTermList -> PairGeneralize .
eq generalize(M,NextVar,NeTL)
= generalize*(M,NextVar,getEqs(M),NeTL) .
op generalize* : Module Nat EquationSet TermList -> PairGeneralize .
eq generalize*(M,NextVar,EqS,empty)
= {empty,NextVar} .
eq generalize*(M,NextVar,EqS,(T,TL))
= {(fst(generalize**(M,NextVar,EqS,T)),
fst(generalize*(M,snd(generalize**(M,NextVar,EqS,T)),EqS,TL))),
snd(generalize*(M,snd(generalize**(M,NextVar,EqS,T)),EqS,TL))
} .
op generalize** : Module Nat EquationSet Term -> PairGeneralize .
eq generalize**(M,NextVar,EqS,C)
= {C,NextVar} .
eq generalize**(M,NextVar,EqS,V)
= {V,NextVar} .
ceq generalize**(M,NextVar,(eq F'[TL'] = Rhs [AtS] .) EqS,F[TL])
= {newVar(NextVar,getKind(M,leastSort(M,F[TL]))),NextVar + 1}
if F == F'
and-then
glbSorts(M,leastSort(M,TL),leastSort(M,TL')) =/= none .
eq generalize**(M,NextVar,EqS,F[TL])
= {F[fst(generalize*(M,NextVar,EqS,TL))],
snd(generalize*(M,NextVar,EqS,TL))}
[owise] .
*** Identify bound for terms
op howMany : Module NeTermList -> Nat .
eq howMany(M,NeTL)
= howMany*(M,getEqs(M),NeTL << 0 < ) .
op howMany* : Module EquationSet TermList -> Nat .
eq howMany*(M,EqS,empty)
= 0 .
eq howMany*(M,EqS,(T,TL))
= howMany**(M,EqS,T) + howMany*(M,EqS,TL) .
op howMany** : Module EquationSet Term -> Nat .
eq howMany**(M,EqS,C)
= 0 .
eq howMany**(M,EqS,V)
= 0 .
ceq howMany**(M,(eq F'[TL'] = Rhs [AtS] .) EqS,F[TL])
= 1 + howMany*(M,(eq F'[TL'] = Rhs [AtS] .) EqS,TL)
if F == F'
and-then
glbSorts(M,leastSort(M,TL),leastSort(M,TL')) =/= none
and-then not isAssociative(M,F,getTypes(M,TL)) .
ceq howMany**(M,(eq F'[TL'] = Rhs [AtS] .) EqS,F[TL])
= sd(length(TL),1) + howMany*(M,(eq F'[TL'] = Rhs [AtS] .) EqS,TL)
if F == F'
and-then
glbSorts(M,leastSort(M,TL),leastSort(M,TL')) =/= none
and-then isCommutative(M,F,getTypes(M,TL))
and-then isAssociative(M,F,getTypes(M,TL)) .
eq howMany**(M,EqS,F[TL])
= howMany*(M,EqS,TL) [owise] .
*** Identify whether basic or variant narrowing should be used
op howManyAC : Module NeTermList -> Nat .
eq howManyAC(M,NeTL)
= if howManyAC$(M,getEqs(M)) == 0
then 0
else howManyAC*(M,getEqs(M),NeTL << 0 < )
fi .
op howManyAC* : Module EquationSet TermList -> Nat .
eq howManyAC*(M,EqS,empty)
= 0 .
eq howManyAC*(M,EqS,(T,TL))
= howManyAC**(M,EqS,T) + howManyAC*(M,EqS,TL) .
op howManyAC** : Module EquationSet Term -> Nat .
eq howManyAC**(M,EqS,C)
= 0 .
eq howManyAC**(M,EqS,V)
= 0 .
ceq howManyAC**(M,(eq F'[TL'] = Rhs [AtS] .) EqS,F[TL])
= sd(length(TL),1) + howManyAC*(M,(eq F'[TL'] = Rhs [AtS] .) EqS,TL)
if F == F'
and-then
glbSorts(M,leastSort(M,TL),leastSort(M,TL')) =/= none
and-then isCommutative(M,F,getTypes(M,TL))
and-then isAssociative(M,F,getTypes(M,TL)) .
eq howManyAC**(M,EqS,F[TL])
= howManyAC*(M,EqS,TL) [owise] .
op length : TermList -> Nat .
eq length((empty).TermList) = 0 .
eq length((T:Term,TL:TermList)) = 1 + length(TL:TermList) .
op howManyAC$ : Module EquationSet -> Nat [memo] .
eq howManyAC$(M,EqS)
= howManyAC$$(M,EqS) .
op howManyAC$$ : Module EquationSet -> Nat .
eq howManyAC$$(M,none)
= 0 .
eq howManyAC$$(M,(eq F[TL] = Rhs [AtS] .) EqS)
= if isCommutative(M,F,getTypes(M,TL))
and isAssociative(M,F,getTypes(M,TL))
then 1 else 0 fi
+ howManyAC$$(M,EqS) .
***
op howManyBuiltIn : Module NeTermList -> Nat .
eq howManyBuiltIn(M,NeTL)
= if howManyAC(M,NeTL) > 0
then howManyAC(M,NeTL)
else howMany(onlyEqsLabel(M),NeTL)
fi .
*** Filter UnificationPairSet according to Variant narrowing strategy
op filter-variant-UP : EFlags Module Nat UnificationTripleSet
-> UnificationTripleSet .
eq filter-variant-UP(EF,M,N,US)
= if minimal-unifiers in EF and testUnifier !in EF
then filter-variant-UP*(M,N,empty,US)
else US
fi .
op filter-variant-UP* :
Module Nat UnificationTripleSet UnificationTripleSet
-> UnificationTripleSet .
eq filter-variant-UP*(M,N,US$,empty)
= US$ .
eq filter-variant-UP*(M,N,US$,{S,S*,NextVar} | US)
= filter-variant-UP**(M,N,US$,US,{S,S*,NextVar},US) .
op filter-variant-UP** :
Module Nat UnificationTripleSet UnificationTripleSet
UnificationTriple UnificationTripleSet
-> UnificationTripleSet .
eq filter-variant-UP**(M,N,US$,US',{S,S*,NextVar},empty)
= --- RT is not implied by any in RTS'
filter-variant-UP*(M,N,US$ | {S,S*,NextVar},US') .
eq filter-variant-UP**(M,N,US$,U | US',U',U | US)
= if test-variant-UP(M,N,U,U') --- keep U & remove U'
then --- RT is implied by one in RTS'
filter-variant-UP*(M,N,US$,U | US')
else if test-variant-UP(M,N,U',U) --- keep U' & remove U
then --- remove T from the set US'
filter-variant-UP**(M,N,US$,US',U',US)
else --- continue searching in US
filter-variant-UP**(M,N,US$,U | US',U',US)
fi
fi .
op test-variant-UP :
Module Nat UnificationTriple UnificationTriple -> Bool .
eq test-variant-UP(M,N,{S,S*,NextVar},{S',S'*,NextVar'})
= (S ; S*) |> N <=[M] (S' ; S'*) |> N . --- keep T & remove T'
*** Filter VariantFourSet according to Variant narrowing strategy
op filter-variant-VT : EFlags Module Nat VariantFourSet -> VariantFourSet .
eq filter-variant-VT(EF,M,N,VTS)
= if minimal-unifiers in EF and testUnifier !in EF
then filter-variant-VT*(M,N,empty,VTS)
else VTS
fi .
op filter-variant-VT* :
Module Nat VariantFourSet VariantFourSet -> VariantFourSet .
eq filter-variant-VT*(M,N,VTS$,empty)
= VTS$ .
eq filter-variant-VT*(M,N,VTS$,VT | VTS)
= filter-variant-VT**(M,N,VTS$,VTS,VT,VTS) .
op filter-variant-VT** :
Module Nat VariantFourSet VariantFourSet
VariantFour VariantFourSet
-> VariantFourSet .
eq filter-variant-VT**(M,N,VTS$,VTS',VT,empty)
= --- RT is not implied by any in VTSS'
filter-variant-VT*(M,N,VTS$ | VT,VTS') .
eq filter-variant-VT**(M,N,VTS$,VT | VTS',VT',VT | VTS)
= if test-variant-VT(M,N,VT,VT')
then --- RT is implied by one in RTS'
filter-variant-VT*(M,N,VTS$,VT | VTS')
else if test-variant-VT(M,N,VT',VT)
then --- remove T from the set VTS'
filter-variant-VT**(M,N,VTS$,VTS',VT',VTS)
else --- continue searching in VTS
filter-variant-VT**(M,N,VTS$,VT | VTS',VT',VTS)
fi
fi .
op test-variant-VT : Module Nat VariantFour VariantFour -> Bool .
eq test-variant-VT(M,N,{T,S,S*,NextVar},{T',S',S'*,NextVar'})
= --- keep T & remove T'
((S ; S*) |> N ; (newVar(N + 1,leastSort(M,T)) <- T))
<=[M]
((S' ; S'*) |> N ; (newVar(N + 1,leastSort(M,T')) <- T')) .
*** Take only normal forms
op filter-NF : Module UnificationTripleSet -> UnificationTripleSet .
eq filter-NF(M,empty)
= empty .
eq filter-NF(M,{S,S*,NextVar} | US)
= if normalizedSubstitution?(M,S ; S*)
then {S,S*,NextVar}
else empty
fi
| filter-NF(M,US) .
op maxNextVar : VariantFourSet -> Nat .
eq maxNextVar(empty) = 0 .
eq maxNextVar({T,S,S*,NextVar} | VTS) = max(NextVar,maxNextVar(VTS)) .
endfm
fmod META-AC-UNIFICATION is
pr TERM-HANDLING .
pr SUBSTITUTION-HANDLING .
pr MODULE-HANDLING .
pr SUBSTITUTIONSET .
pr UNIFICATIONPAIRSET .
pr CONVERSION .
pr META-LEVEL .
pr META-MINIMIZE-BINDINGS .
pr META-E-UNIFICATION .
var M : Module .
vars T T' : Term .
vars N N' : Nat .
vars US : UnificationTripleSet .
--- metaACUnify --------------------------------------------------
op metaACUnify : Module Term Term -> SubstitutionSet .
eq metaACUnify(M, T, T')
= toSubstitution(metaACUnify(M, T, T', highestVar((T,T')) + 1)) .
op metaACUnify? : Module Term Term -> Bool .
eq metaACUnify?(M, T, T')
= metaACUnify?(M, T, T', highestVar((T,T')) + 1) .
--- eq metaACUnify?(M, T, T')
--- = metaACUnify(M, T, T') =/= empty .
*** General Call for UnificationPairSet
op metaACUnify : Module Term Term Nat -> UnificationTripleSet .
eq metaACUnify(M, T, T', N)
= metaACUnify$(M, canonice(M,T), canonice(M,T'), N) .
op metaACUnify$ : Module Term Term Nat -> UnificationTripleSet .
--- Term Lhs
eq metaACUnify$(M, T, T', N)
= if (root(T) =/= root(T')
and not (root(T) :: Variable) and not (root(T') :: Variable))
or-else
glbSorts(M,leastSort(M,T),leastSort(M,T')) == none
then empty
else minimizeBindingsTerm(M,Vars(T),N,
metaACUnifyCollect(M, T, T',N,0,empty))
fi .
op metaACUnify? : Module Term Term Nat -> Bool .
eq metaACUnify?(M, T, T', N)
= metaACUnify?$(M, canonice(M,T), canonice(M,T'), N) .
op metaACUnify?$ : Module Term Term Nat -> Bool .
eq metaACUnify?$(M, T, T', N)
= glbSorts(M,leastSort(M,T),leastSort(M,T')) =/= none
and-then
(metaACUnify*(M,T =? T',N,0) :: UnificationTriple?
and
metaACUnify*(M,T =? T',N,0) =/= noUnifier) .
op metaACUnifyCollect : Module Term Term Nat Nat
UnificationTripleSet
-> UnificationTripleSet .
eq metaACUnifyCollect(M,T,T',N,N',US)
= if metaACUnify*(M,T =? T',N,N') :: UnificationTriple?
and
metaACUnify*(M,T =? T',N,N') =/= noUnifier
then metaACUnifyCollect(M,T,T',N,s(N'),
US | metaACUnify*(M,T =? T',N,N') )
else US
fi .
*** Code for collection all unifiers
op metaACUnify* : Module UnificandPair Nat Nat ~> UnificationTriple? .
eq metaACUnify*(M, T =? T',N,N')
= metaUnifyTriple(
keepOnlyACAttr(eraseEqs(eraseRls(M))),
unflatten(M,T) =? unflatten(M,T'),
N,N') .
op metaUnifyTriple : Module UnificationProblem Nat Nat ~> UnificationTriple? .
eq metaUnifyTriple(M,T =? T',N,N')
= if metaUnify(M,T =? T',N,N') == noUnifier
then noUnifier
else {getSubst(metaUnify(M,T =? T',N,N')) |> T,
getSubst(metaUnify(M,T =? T',N,N')) |> T',
getNextVar(metaUnify(M,T =? T',N,N'))}
fi .
endfm
fmod META-ACU-UNIFICATION is
pr META-AC-UNIFICATION .
pr IRR-FLAGS .
var M : Module .
vars T T' Lhs Rhs : Term .
var S : Substitution .
var V : Variable .
var C : Constant .
vars N N' : Nat .
var US : [UnificationPairSet] .
vars F F' : Qid .
var AtS : AttrSet .
var At : Attr .
var TP TP' : Type .
var TPL TPL' : TypeList .
var OPDS : OpDeclSet .
var TL : NeTermList .
var EqS : EquationSet .
var IRR : IrrFlags .
--- metaACUUnify --------------------------------------------------
op metaACUUnify : Module Term Term -> SubstitutionSet .
eq metaACUUnify(M, T, T')
= toSubstitution(metaACUUnify(M,T,T',highestVar((T,T')) + 1)) .
op metaACUUnify : Module Term Term Nat -> UnificationTripleSet .
eq metaACUUnify(M, T, T',N)
= metaACUUnify*(M,T,T',N,reducible) .
op metaACUUnifyIrr : Module Term Term -> SubstitutionSet .
eq metaACUUnifyIrr(M, T, T')
= toSubstitution(metaACUUnifyIrr(M,T,T',highestVar((T,T')) + 1)) .
op metaACUUnifyIrr : Module Term Term Nat -> UnificationTripleSet .
eq metaACUUnifyIrr(M, T, T',N)
= metaACUUnify*(M,T,T',N,irreducible) .
op metaACUUnify-minimal : Module Term Term -> SubstitutionSet .
eq metaACUUnify-minimal(M, T, T')
= toSubstitution(metaACUUnify-minimal(M,T,T',highestVar((T,T')) + 1)) .
op metaACUUnify-minimal : Module Term Term Nat -> UnificationTripleSet .
eq metaACUUnify-minimal(M, T, T',N)
= metaACUUnify*(M,T,T',N,reducible minimal-unifiers) .
op metaACUUnifyIrr-minimal : Module Term Term -> SubstitutionSet .
eq metaACUUnifyIrr-minimal(M, T, T')
= toSubstitution(metaACUUnifyIrr-minimal(M,T,T',highestVar((T,T')) + 1)) .
op metaACUUnifyIrr-minimal : Module Term Term Nat -> UnificationTripleSet .
eq metaACUUnifyIrr-minimal(M, T, T',N)
= metaACUUnify*(M,T,T',N,irreducible minimal-unifiers) .
*** General Call for UnificationPairSet
op metaACUUnify* : Module Term Term Nat IrrFlags -> UnificationTripleSet .
--- Term Lhs
eq metaACUUnify*(M, T, T', N,IRR)
= if glbSorts(M,leastSort(M,T),leastSort(M,T')) == none
then empty
else minimizeBindingsTerm(M,Vars(T),metaACUUnifyAux(M,T,T',N,IRR))
fi .
op metaACUUnifyAux : Module Term Term Nat IrrFlags -> UnificationTripleSet .
eq metaACUUnifyAux(M,T,T',N,IRR)
= if getBound(eqsforIdSymbols(M,(T,T'))) > 0
then filter-variant-UP(IRR,eqs2rls(clearAllFrozen(M)),N,
metaEACUnify(
keepOnlyACAttr(
addEqs(getEqs(eqsforIdSymbols(M,(T,T'))),eraseEqs(eraseRls(M)))
),
unflatten(M,T), unflatten(M,T'), N,
IRR
)
)
else metaACUnifyCollect(M, T, T',N,0,empty)
fi .
*** Extra handy sort
sort Eqs&Bound .
op {_,_} : EquationSet Nat -> Eqs&Bound .
op getEqs : Eqs&Bound -> EquationSet .
eq getEqs({X:EquationSet,X:Nat}) = X:EquationSet .
op getBound : Eqs&Bound -> Nat .
eq getBound({X:EquationSet,X:Nat}) = X:Nat .
op _+_ : Eqs&Bound Eqs&Bound -> Eqs&Bound .
eq {X1:EquationSet,X1:Nat} + {X2:EquationSet,X2:Nat}
= {X1:EquationSet X2:EquationSet, X1:Nat + X2:Nat} .
*** Extra code for ACU Unification
op eqsforIdSymbols : Module NeTermList -> Eqs&Bound . ---[memo] .
eq eqsforIdSymbols(M,TL) = eqsforIdSymbols*(M,getOps(M),TL) .
op eqsforIdSymbols* : Module OpDeclSet NeTermList -> Eqs&Bound .
eq eqsforIdSymbols*(M,
(op F : TPL -> TP [special(X:NeHookList) AtS] .) OPDS,TL)
= eqsforIdSymbols*(M,OPDS,TL) .
eq eqsforIdSymbols*(M,(op F : TPL -> TP [id(T) AtS] .) OPDS,TL)
= eqsforIdSymbols**(M,F,getKind(M,TP),id(T),TL)
+ eqsforIdSymbols*(M,OPDS,TL) .
eq eqsforIdSymbols*(M,(op F : TPL -> TP [left-id(T) AtS] .) OPDS,TL)
= eqsforIdSymbols**(M,F,getKind(M,TP),left-id(T),TL)
+ eqsforIdSymbols*(M,OPDS,TL) .
eq eqsforIdSymbols*(M,(op F : TPL -> TP [right-id(T) AtS] .) OPDS,TL)
= eqsforIdSymbols**(M,F,getKind(M,TP),right-id(T),TL)
+ eqsforIdSymbols*(M,OPDS,TL) .
eq eqsforIdSymbols*(M,OPDS,TL)
= {none,0} [owise] .
op eqsforIdSymbols** : Module Qid Type Attr NeTermList -> Eqs&Bound .
eq eqsforIdSymbols**(M,F,TP,At,C)
= {none,0} .
eq eqsforIdSymbols**(M,F,TP,At,V)
= {none,0} .
eq eqsforIdSymbols**(M,F',TP,id(T),F[TL])
= if F == F'
and-then
getKind(M,leastSort(M,F[TL])) == TP
then if isCommutative(M,F,getTypes(M,TL))
then {(eq F[T,addType TP ToVar 'X] = addType TP ToVar 'X [none] .),1}
else {(eq F[T,addType TP ToVar 'X] = addType TP ToVar 'X [none] .)
(eq F[addType TP ToVar 'X,T] = addType TP ToVar 'X [none] .),1}
fi
else {none,0}
fi
+ eqsforIdSymbols**(M,F',TP,id(T),TL) .
eq eqsforIdSymbols**(M,F',TP,left-id(T),F[TL])
= if F == F'
and-then
getKind(M,leastSort(M,F[TL])) == TP
and-then
not isCommutative(M,F,getTypes(M,TL))
then {(eq F[T,addType TP ToVar 'X] = addType TP ToVar 'X [none] .),1}
else {none,0}
fi
+ eqsforIdSymbols**(M,F',TP,left-id(T),TL) .
eq eqsforIdSymbols**(M,F',TP,right-id(T),F[TL])
= if F == F'
and-then
getKind(M,leastSort(M,F[TL])) == TP
and-then
not isCommutative(M,F,getTypes(M,TL))
then {(eq F[addType TP ToVar 'X,T] = addType TP ToVar 'X [none] .),1}
else {none,0}
fi
+ eqsforIdSymbols**(M,F',TP,right-id(T),TL) .
eq eqsforIdSymbols**(M,F,TP,At,(T,TL))
= eqsforIdSymbols**(M,F,TP,At,T) + eqsforIdSymbols**(M,F,TP,At,TL) .
endfm
fmod META-UNIFICATION is
pr META-ACU-UNIFICATION .
var M : Module .
var T T' : Term .
var N : Nat .
--- metaUnify --------------------------------------------------
op metaCoreUnify : Module Term Term -> SubstitutionSet .
eq metaCoreUnify(M, T, T')
= toSubstitution(metaCoreUnify(M, T, T', highestVar((T,T')) + 1)) .
op metaCoreUnify : Module Term Term Nat -> UnificationTripleSet .
--- Term Lhs
eq metaCoreUnify(M, T, T', N)
= metaACUnify(M, T, T', N) .
op metaCoreUnify? : Module Term Term Nat -> Bool .
--- Term Lhs
eq metaCoreUnify?(M, T, T', N)
= metaACUnify?(M, T, T', N) .
endfm
fmod META-MSG-UNIFICATION is
pr META-AC-UNIFICATION .
--- pr unification * (op Solve(_,_,_) to metaHEUnify,
--- op HasHomomorphism to IsMetaHEUnify) .
*** Add this and modify metaMsgUnify*Msg in replacement
op IsMetaHEUnify : Module -> Bool .
eq IsMetaHEUnify(M) = false .
var M : Module .
vars T T' T1# T2# T1 T2 : Term .
vars N N' N1# N2# : Nat .
vars S S' S1# S2# LSubst RSubst : Substitution .
var UP : UnificationProblem .
var UTS : UnificationTripleSet .
var C : Constant .
vars V V1 V2 : Variable .
var F : Qid .
var TL : TermList .
var NeTL : NeTermList .
******* metaBuiltInMatch ***********************************************
op metaBuiltInMatch : Module Term Term -> SubstitutionSet .
*** T1 instance of T2
eq metaBuiltInMatch(M, T, T')
= toSubstitution(metaBuiltInMatch(M, T, T', highestVar((T,T')) + 1)) .
op metaBuiltInMatch? : Module Term Term -> Bool .
*** T1 instance of T2
eq metaBuiltInMatch?(M, T, T')
= metaBuiltInMatch?(M, T, T', highestVar((T,T')) + 1) .
op metaBuiltInMatch : Module Term Term Nat -> UnificationTripleSet .
--- Term Lhs
eq metaBuiltInMatch(M, T1, T2, N)
= unrigidife(qid(N),
metaBuiltInUnify(getM(rigidifeNat(M,qid(N),T1,N)),
getTL(rigidifeNat(M,qid(N),T1,N)),
T2,
N + 1)
) .
op metaBuiltInMatch? : Module Term Term Nat -> Bool .
--- Term Lhs
eq metaBuiltInMatch?(M, T1, T2, N)
= metaBuiltInUnify?(getM(rigidifeNat(M,qid(N),T1,N)),
getTL(rigidifeNat(M,qid(N),T1,N)),
T2,
N + 1) .
******* metaBuiltInUnify ***********************************************
op metaBuiltInUnify : Module Term Term -> SubstitutionSet .
eq metaBuiltInUnify(M, T, T')
= toSubstitution(metaBuiltInUnify(M, T, T', highestVar((T,T')) + 1)) .
*** General Call for UnificationPairSet
op metaBuiltInUnify : Module Term Term Nat -> UnificationTripleSet .
--- Term Lhs
eq metaBuiltInUnify(M, T1, T2, N)
= if IsMetaHEUnify(M)
then
minimizeBindingsTerm(M,Vars(T1),N,metaMsgUnify*(M, T1, T2,N))
else
metaCoreUnify(M, T1, T2, N)
fi .
op metaBuiltInUnify? : Module Term Term Nat -> Bool .
eq metaBuiltInUnify?(M, T1, T2, N)
= if IsMetaHEUnify(M)
then
metaMsgUnify*?(M, T1, T2,N)
else
metaCoreUnify?(M, T1, T2, N)
fi .
op metaMsgUnify* : Module Term Term Nat ~> UnificationTripleSet .
ceq metaMsgUnify*(M, T1, T2, N)
= if not (metaCoreUnify(M,T1#,T2#,N2#) :: UnificationTripleSet)
or
metaCoreUnify(M,T1#,T2#,N2#) == empty
then empty
else metaMsgUnify**(M,S1#,S2#,metaCoreUnify(M,T1#,T2#,N2#))
fi
if (T1#,S1#,N1#) := generalize(M,T1,N)
/\ (T2#,S2#,N2#) := generalize(M,T2,N1#) .
op metaMsgUnify*? : Module Term Term Nat ~> Bool .
ceq metaMsgUnify*?(M, T1, T2, N)
= metaCoreUnify?(M,T1#,T2#,N2#)
and-then
metaMsgUnify**?(M,S1#,S2#,metaCoreUnify(M,T1#,T2#,N2#))
if (T1#,S1#,N1#) := generalize(M,T1,N)
/\ (T2#,S2#,N2#) := generalize(M,T2,N1#) .
sort TripleGenVar .
op `(_`,_`,_`) : TermList Substitution Nat -> TripleGenVar .
op getTL : TripleGenVar -> Term .
eq getTL((TL,S,N)) = TL .
op getS : TripleGenVar -> Substitution .
eq getS((TL,S,N)) = S .
op getN : TripleGenVar -> Nat .
eq getN((TL,S,N)) = N .
op generalize : Module Term Nat -> TripleGenVar .
eq generalize(M,T,N)
= if typeLeq(M,leastSort(M,T),'Msg)
then (newVar(N,'Msg),newVar(N,'Msg) <- T,N + 1)
else generalize*(M,T,N)
fi .
op generalize* : Module Term Nat -> TripleGenVar .
eq generalize*(M,C,N) = (C,none,N) .
eq generalize*(M,V,N) = (V,none,N) .
eq generalize*(M,F[NeTL],N)
= (F[getTL(generalize*TL(M,NeTL,N))],
getS(generalize*TL(M,NeTL,N)),
getN(generalize*TL(M,NeTL,N))) .
op generalize*TL : Module TermList Nat -> TripleGenVar .
eq generalize*TL(M,empty,N)
= (empty,none,N) .
eq generalize*TL(M,(T,TL),N)
= ((getTL(generalize(M,T,N)),
getTL(generalize*TL(M,TL,getN(generalize(M,T,N))))),
(getS(generalize(M,T,N))
; getS(generalize*TL(M,TL,getN(generalize(M,T,N))))),
getN(generalize*TL(M,TL,getN(generalize(M,T,N))))) .
op metaMsgUnify** : Module Substitution Substitution
UnificationTripleSet -> UnificationTripleSet .
eq metaMsgUnify**(M, S1#, S2#, empty)
= empty .
eq metaMsgUnify**(M, S1#, S2#, {S,S',N} | UTS)
= metaMsgUnify***(M, S1#, S2#, {S,S',N})
| metaMsgUnify**(M, S1#, S2#, UTS) .
op metaMsgUnify**? : Module Substitution Substitution
UnificationTripleSet -> Bool .
eq metaMsgUnify**?(M, S1#, S2#, empty)
= false .
eq metaMsgUnify**?(M, S1#, S2#, {S,S',N} | UTS)
= metaMsgUnify***(M, S1#, S2#, {S,S',N}) =/= empty
or-else
metaMsgUnify**?(M, S1#, S2#, UTS) .
op metaMsgUnify*** : Module Substitution Substitution
UnificationTriple -> UnificationTripleSet .
eq metaMsgUnify***(M,
V1 <- T1 ; S1#,
V2 <- T2 ; S2#,
{V1 <- V2 ; S,S',N})
= metaMsgUnify****L(M,
V1 <- T1 ; S1#,
V2 <- T2 ; S2#,
V1,V2,
{V1 <- V2 ; S,S',N},
metaMsgUnify*Msg(M, T1, T2, N)
) .
eq metaMsgUnify***(M,
V1 <- T1 ; S1#,
V2 <- T2 ; S2#,
{S,V2 <- V1 ; S',N})
= metaMsgUnify****R(M,
V1 <- T1 ; S1#,
V2 <- T2 ; S2#,
V1,V2,
{S,V2 <- V1 ; S',N},
metaMsgUnify*Msg(M, T1, T2, N)
) .
eq metaMsgUnify***(M, S1#, S2#, {S,S',N})
= {S << S2#,S' << S1#,N} [owise] .
op metaMsgUnify****L : Module Substitution Substitution
Variable Variable UnificationTriple
UnificationTripleSet -> UnificationTripleSet .
eq metaMsgUnify****L(M,
V1 <- T1 ; S1#,
V2 <- T2 ; S2#,
V1,V2,
{V1 <- V2 ; S,S',N},
empty)
= empty . *** Error, no total unification is possible!!!
eq metaMsgUnify****L(M,
V1 <- T1 ; S1#,
V2 <- T2 ; S2#,
V1,V2,
{V1 <- V2 ; S,S',N},
{LSubst,RSubst,N'})
= metaMsgUnify***(M,
(V1 <- T1 ; S1#) << LSubst,
(V2 <- T2 ; S2#) << RSubst,
{S .. LSubst,S' .. RSubst,N'}) .
op metaMsgUnify****R : Module Substitution Substitution
Variable Variable UnificationTriple
UnificationTripleSet -> UnificationTripleSet .
eq metaMsgUnify****R(M,
V1 <- T1 ; S1#,
V2 <- T2 ; S2#,
V1,V2,
{S,V2 <- V1 ; S',N},
empty)
= empty . *** Error, no total unification is possible!!!
eq metaMsgUnify****R(M,
V1 <- T1 ; S1#,
V2 <- T2 ; S2#,
V1,V2,
{S,V2 <- V1 ; S',N},
{LSubst,RSubst,N'})
= metaMsgUnify***(M,
(V1 <- T1 ; S1#) << LSubst,
(V2 <- T2 ; S2#) << RSubst,
{S .. LSubst,S' .. RSubst,N'}) .
--- We assume it is unitary unification!!!!!
op metaMsgUnify*Msg : Module Term Term Nat -> UnificationTripleSet .
--- ceq metaMsgUnify*Msg(M, T, T', N)
--- = { S |> T, S |> T', N' }
--- if unifiable ; S ; N' := metaHEUnify(M, T ~ T', N) .
eq metaMsgUnify*Msg(M, T, T', N)
= empty [owise] .
endfm
fmod ORDERS-TERM-SUBSTITUTION is
protecting TERM-HANDLING .
protecting SUBSTITUTION-HANDLING .
protecting META-LEVEL .
protecting META-UNIFICATION .
protecting META-E-UNIFICATION .
protecting RENAMING .
protecting SUBSTITUTIONSET .
vars T T' : Term .
vars TL TL' : TermList .
var M : Module .
vars S S' : Substitution .
vars SS SS' : SubstitutionSet .
vars V V' : Variable .
vars TPL TPL' : TypeList .
vars N N' : Nat .
--- Not defined in this module ----------------------------------------
op isNF$ : Module Term ~> Bool .
--- Not defined in this module ----------------------------------------
--- metaCoreMatch(M,T,T') implies that T is an instance of T'
op metaCoreMatch : Module Term Term -> SubstitutionSet .
eq metaCoreMatch(M,T,T')
= metaCoreMatch$(M,canonice(M,T),canonice(M,T')) .
op metaCoreMatch$ : Module Term Term -> SubstitutionSet .
eq metaCoreMatch$(M,T,T')
= if glbSorts(M,leastSort(M,T),leastSort(M,T')) == none
then empty
else metaCoreMatchCollect(eraseEqs(eraseRls(M)),T,T')
fi .
op metaCoreMatch? : Module Term Term -> Bool .
eq metaCoreMatch?(M,T,T')
= metaCoreMatch?$(M,canonice(M,T),canonice(M,T')) .
op metaCoreMatch?$ : Module Term Term -> Bool .
eq metaCoreMatch?$(M,T,T')
= glbSorts(M,leastSort(M,T),leastSort(M,T')) =/= none
and-then
metaMatch(eraseEqs(eraseRls(M)),T',T,nil,0) =/= noMatch .
op metaCoreMatchSearchNone : Module TermList Term Term -> Bool .
--- eq metaCoreMatchSearchNone(M,TL,T,T')
--- = metaCoreMatchSearchNone$(M,TL,canonice(M,T),canonice(M,T')) .
eq metaCoreMatchSearchNone(M,TL,T,T')
= canonice(M,T) == canonice(M,T') .
op metaCoreMatchSearchNone$ : Module TermList Term Term -> Bool .
eq metaCoreMatchSearchNone$(M,TL,T,T')
= glbSorts(M,leastSort(M,T),leastSort(M,T')) =/= none
and-then
metaCoreMatchCollectSearchNone(eraseEqs(eraseRls(M)),TL,T,T') .
--- metaCoreMatchCollect(M,T,T') calls Maude metaMatch
op metaCoreMatchCollect : Module Term Term -> SubstitutionSet . ---[memo] .
eq metaCoreMatchCollect(M,T,T')
= metaCoreMatchCollect*(M,T,T',empty,0) .
op metaCoreMatchCollect* : Module Term Term SubstitutionSet Nat
-> SubstitutionSet .
eq metaCoreMatchCollect*(M,T,T',SS,N:Nat)
= if metaMatch(M,T',T,nil,N:Nat) =/= noMatch
then metaCoreMatchCollect*(M,T,T',
SS | metaMatch(M,T',T,nil,N:Nat),
s(N:Nat))
else SS
fi .
--- metaCoreMatchCollectSearchNone(M,T,T') calls Maude metaMatch
op metaCoreMatchCollectSearchNone : Module TermList Term Term -> Bool .
eq metaCoreMatchCollectSearchNone(M,TL,T,T')
= metaCoreMatchCollectSearchNone*(M,TL,T,T',0) .
op metaCoreMatchCollectSearchNone* : Module TermList Term Term Nat -> Bool .
eq metaCoreMatchCollectSearchNone*(M,TL,T,T',N:Nat)
= metaMatch(M,T',T,nil,N:Nat) =/= noMatch
and-then
(metaMatch(M,T',T,nil,N:Nat) |> TL == none
or-else
metaCoreMatchCollectSearchNone*(M,TL,T,T',s(N:Nat))) .
--- metaEMatch(M,T,T') implies that T is an instance of T' modulo E + axioms
op metaEMatch : Module Term Term -> SubstitutionSet .
eq metaEMatch(M,T,T')
= if metaCoreMatch(M,T,T') =/= empty
then metaCoreMatch(M,T,T')
else if metaEBuiltInUnifyIrr?(M,T,T')
then metaShared-filter(M,T,T',metaEBuiltInUnifyIrr(M,T,T'))
else empty
fi
fi .
op metaEMatch? : Module Term Term -> Bool .
eq metaEMatch?(M,T,T')
= metaCoreMatch?(M,T,T')
or-else
metaEBuiltInUnifyIrr?(M,T,T') .
--- Standard metaMatch does not deal with shared variables between T and T'
--- metaCoreMatch(M,T,T') implies that T is an instance of T'
op metaCoreMatchShared : Module Term Term -> SubstitutionSet .
eq metaCoreMatchShared(M,T,T')
= metaShared-filter(M,T,T',metaCoreMatch(M,T,T')) .
op metaShared-filter : Module Term Term SubstitutionSet
-> SubstitutionSet .
eq metaShared-filter(M,T,T',SS)
= metaShared-filter*(M,T,T',empty,SS) .
op metaShared-filter* : Module Term Term SubstitutionSet SubstitutionSet
-> SubstitutionSet .
eq metaShared-filter*(M,T,T',SS',empty)
= SS' .
eq metaShared-filter*(M,T,T',SS',S | SS)
= metaShared-filter*(M,T,T',
if S |> T == none
then SS' | S
else SS'
fi,
SS ) .
--- order between terms ---------------------------
--- T <=[M] T' implies that T' is an instance of T
op _<=[_]_ : Term Module Term -> Bool .
eq T <=[M] T' = (metaCoreMatch(M,T',T) |> T) =/= empty .
--- order between substitutions ---------------------------
--- Subst <=[M] Subst' implies that Subst' is an instance of Subst
op _<=[_]_ : SubstitutionSet Module SubstitutionSet -> Bool [ditto] .
eq SS <=[M] SS'
= SS <=[empty,M] SS' .
op _<=[_`,_]_ : SubstitutionSet TermList Module SubstitutionSet -> Bool .
eq empty <=[TL,M] SS'
= false .
eq SS <=[TL,M] SS'
= SS <=[TL,M]$ SS' [owise] .
op _<=[_`,_]$_ : SubstitutionSet TermList Module SubstitutionSet -> Bool .
eq SS <=[TL,M]$ empty
= true .
eq SS <=[TL,M]$ (S' | SS')
= (SS <=[TL,M]* S') and-then SS <=[TL,M]$ SS' .
op _<=[_`,_]*_ : SubstitutionSet TermList Module Substitution -> Bool .
eq empty <=[TL,M]* S'
= false .
eq (S | SS) <=[TL,M]* S'
= S <=[TL,M]** S' or-else SS <=[TL,M]* S' .
op _<=[_`,_]**_ : Substitution TermList Module Substitution -> Bool .
eq none <=[TL,M]** S'
= true .
eq S <=[TL,M]** S'
= 'Q[1st(gen(TL,S,S'))]
*<=[
addSorts('XXX,
addOps((op 'Q : 3rd(gen(TL,S,S')) -> 'XXX [none] .),
M))
]*
'Q[2nd(gen(TL,S,S'))]
[owise] .
--- T <=[M] T' implies that T' is an instance of T
--- T and T' can have shared variables
op _*<=[_]*_ : Term Module Term -> Bool .
eq T *<=[M]* T'
= (if anyVars T inVars T'
then metaCoreMatchShared(M,T',T)
else metaCoreMatch(M,T',T)
fi |> T)
=/= empty .
sort Triple .
op {{_`,_`,_}} : TermList TermList TypeList -> Triple .
op 1st : Triple -> TermList .
eq 1st({{TL,TL',TPL}}) = TL .
op 2nd : Triple -> TermList .
eq 2nd({{TL,TL',TPL}}) = TL' .
op 3rd : Triple -> TypeList .
eq 3rd({{TL,TL',TPL}}) = TPL .
ops gen : TermList Substitution Substitution -> Triple . ---[memo] .
eq gen(empty,none,none)
= {{empty,empty,nil}} .
eq gen((V,TL),none,none)
= {{(V,1st(gen(TL,none,none))),
(V,2nd(gen(TL,none,none))),
(getType(V) 3rd(gen(TL,none,none)))}} .
eq gen(TL,none,V <- T ; S')
= {{(V,1st(gen(TL \\ V,none,S'))),
(T,2nd(gen(TL \\ V,none,S'))),
(getType(V) 3rd(gen(TL \\ V,none,S')))}} .
eq gen(TL,V <- T ; S,V <- T' ; S')
= {{(T,1st(gen(TL \\ V,S,S'))),
(T',2nd(gen(TL \\ V,S,S'))),
(getType(V) 3rd(gen(TL \\ V,S,S')))}} .
eq gen(TL,V <- T ; S,S')
= {{(T,1st(gen(TL \\ V,S,S'))),
(V,2nd(gen(TL \\ V,S,S'))),
(getType(V) 3rd(gen(TL \\ V,S,S')))}}
[owise] .
op _\\_ : TermList Variable -> TermList .
eq (TL,V,TL') \\ V = (TL,TL') .
eq TL \\ V = TL [owise] .
--- renaming -----------------------------------------------
op metaCoreRenaming : Module Term Term -> Bool .
eq metaCoreRenaming(M,T,T')
= T =[M]= T' .
op _=[_]=_ : TermSet Module TermSet -> Bool .
eq emptyTermSet =[M:Module]= emptyTermSet
= true .
ceq T:Term | T:TermSet =[M:Module]= T':Term | T':TermSet
= T:TermSet =[M:Module]= T':TermSet
if T:Term =[M:Module]$= T':Term .
eq T:TermSet =[M:Module]= T':TermSet
= false [owise] .
op _=[_]$=_ : Term Module Term -> Bool .
eq T =[M]$= T'
= canonice(M,T) =[M]$$= canonice(M,T') .
op _=[_]$$=_ : Term Module Term -> Bool .
eq T =[M]$$= T'
= T == T'
or-else
onlyRenaming(metaCoreMatchShared(M,T',T) |> T) .
op onlyRenaming : SubstitutionSet -> Bool .
eq onlyRenaming(empty)
= false .
eq onlyRenaming(S | SS)
= onlyRenaming*(S) or-else onlyRenaming(SS) .
op onlyRenaming* : Substitution -> Bool .
eq onlyRenaming*((V <- T) ; (V' <- T) ; S)
= false .
eq onlyRenaming*(S) = onlyRenaming**(S) [owise] .
op onlyRenaming** : Substitution -> Bool .
eq onlyRenaming**(none)
= true .
eq onlyRenaming**((V <- T) ; S)
= T :: Variable and onlyRenaming**(S) .
*** Normalize Substitutions
op normalizedSubstitution? : Module SubstitutionSet -> Bool .
eq normalizedSubstitution?(M, empty)
= true .
eq normalizedSubstitution?(M, S | SS)
= normalizedSubstitution?*(M, S) and-then normalizedSubstitution?(M, SS) .
op normalizedSubstitution?* : Module Substitution -> Bool . ---[memo] .
eq normalizedSubstitution?*(M, none)
= true .
eq normalizedSubstitution?*(M, V <- T ; S:Substitution)
= isNF$(clearAllFrozen(M),T)
and-then
normalizedSubstitution?*(M, S:Substitution) .
*** Normalize Substitutions
op |_|`(_`) : SubstitutionSet Module -> SubstitutionSet .
eq | S:SubstitutionSet |(M)
= eqNormalizeSubstitution(M,S:SubstitutionSet) .
op eqNormalizeSubstitution : Module SubstitutionSet -> SubstitutionSet .
eq eqNormalizeSubstitution(M, empty)
= empty .
eq eqNormalizeSubstitution(M, S | SS)
= eqNormalizeSubstitution*(M, S) | eqNormalizeSubstitution(M, SS) .
op eqNormalizeSubstitution* : Module Substitution -> Substitution .
eq eqNormalizeSubstitution*(M, none)
= none .
eq eqNormalizeSubstitution*(M, V <- T ; S:Substitution)
= V <- getTerm(metaReduce(eraseRls(M),T))
; eqNormalizeSubstitution*(M, S:Substitution) .
endfm
fmod META-NORMALIZE is
protecting META-TERM .
protecting META-LEVEL .
protecting META-UNIFICATION .
protecting RESULT-CONTEXT-SET .
protecting ORDERS-TERM-SUBSTITUTION .
protecting TYPEOFNARROWING .
vars T T' TOrig Lhs Rhs TS TS' CtTS CtTS' : Term .
var V : Variable .
var C : Constant .
var F : Qid .
vars TL TL' : TermList .
var M : Module .
vars RTS RTS' RTS$ RTS$' : ResultContextSet .
vars RT RT' : ResultContext .
vars TP TP' : Type .
vars S S' S* S'* Subst : Substitution .
var RLS : RuleSet .
var Att : AttrSet .
vars B BN : Bound .
vars N NextVar NextVar' : Nat .
var NL : NatList .
vars Ct CtS Ct' CtS' : Context .
var ON : TypeOfNarrowing .
var QQ : TypeOfRelation .
*** Shortcut to Normalization by rewriting Search
op metaNormalizeCollect$ : Module Term ~> ResultTripleSet .
eq metaNormalizeCollect$(M,T)
= metaNormalizeCollect$(M,{T,leastSort(M,T),none}) .
op metaNormalizeCollect$ : Module Term Type ~> ResultTripleSet .
eq metaNormalizeCollect$(M,T,TP)
= metaNormalizeCollect$(M,{T,TP,none}) .
op metaNormalizeCollect$ : Module ResultTriple ~> ResultTripleSet . ---[memo] .
eq metaNormalizeCollect$(M,{T,TP,S})
= metaSearchCollect(M,
T, (addType TP ToVar 'XXXXXXX),
'!,unbounded) .
*** Shortcut to One rewriting step
op metaOneRewriting$ : Module Term ~> ResultTripleSet .
eq metaOneRewriting$(M,T)
= metaOneRewriting$(M,{T,leastSort(M,T),none}) .
op metaOneRewriting$ : Module Term Type -> ResultTripleSet .
eq metaOneRewriting$(M,T,TP)
= metaOneRewriting$(M,{T,TP,none}) .
op metaOneRewriting$ : Module ResultTriple -> ResultTripleSet . ---[memo] .
eq metaOneRewriting$(M,{T,TP,S})
= metaSearchCollect(M,
T, (addType TP ToVar 'XXXXXXX),
'+,1) .
*** Use Standard Maude metaSearch
op metaSearchCollect : Module Term Term TypeOfRelation Bound
~> ResultTripleSet .
eq metaSearchCollect(M,T,T',QQ,B)
= metaSearchCollect(clearNonExec(M),T,T',QQ,B,0) .
op metaSearchCollect : Module Term Term TypeOfRelation Bound Nat
~> ResultTripleSet .
eq metaSearchCollect(M,T,T',QQ,B,N:Nat)
= if metaSearch(M,T,T',nil,[QQ],B,N:Nat) :: ResultTripleSet
and
metaSearch(M,T,T',nil,[QQ],B,N:Nat) =/= failure
then metaSearch(M,T,T',nil,[QQ],B,N:Nat)
|
metaSearchCollect(M,T,T',QQ,B,s(N:Nat))
else empty
fi .
*** Shortcut to normal form detection
op isNF$ : Module Term ~> Bool .
eq isNF$(M,T) = isNF$$(M,T,leastSort(M,T)) .
op isNF$$ : Module Term Type ~> Bool .
eq isNF$$(M,T,TP)
= metaSearch(M,T,(addType TP ToVar 'XXXXXXX),nil,'+,1,0) == failure .
***********************************************************************
--- Not defined in this module-------------
op metaNarrowSearchAll : Module Term Term SubstitutionCond TypeOfRelation
Bound Bound --- number steps / number solutions
TypeOfNarrowing
ResultContextSet
-> ResultContextSet .
op oneMoreStep : Module SubstitutionCond TypeOfNarrowing
ResultContextSet -> ResultContextSet .
--- Not defined in this module-------------
op metaNormalizeCollect : Module Term ~> ResultTripleSet .
eq metaNormalizeCollect(M,T)
= if anyNonExec(M)
then metaNormalizeCollect#(M,T)
else metaNormalizeCollect$(M,T)
fi .
op metaNormalizeCollect : Module Term Type -> ResultTripleSet .
eq metaNormalizeCollect(M,T,TP)
= if anyNonExec(M)
then metaNormalizeCollect#(M,T,TP)
else metaNormalizeCollect$(M,T,TP)
fi .
op metaNormalizeCollect : Module ResultTriple -> ResultTripleSet .
eq metaNormalizeCollect(M,{T,TP,S})
= if anyNonExec(M)
then metaNormalizeCollect#(M,{T,TP,S})
else metaNormalizeCollect$(M,{T,TP,S})
fi .
op metaOneRewriting : Module Term ~> ResultTripleSet .
eq metaOneRewriting(M,T)
= if anyNonExec(M)
then metaOneRewriting#(M,T)
else metaOneRewriting$(M,T)
fi .
op metaOneRewriting : Module Term Type -> ResultTripleSet .
eq metaOneRewriting(M,T,TP)
= if anyNonExec(M)
then metaOneRewriting#(M,T,TP)
else metaOneRewriting$(M,T,TP)
fi .
op metaOneRewriting : Module ResultTriple -> ResultTripleSet .
eq metaOneRewriting(M,{T,TP,S})
= if anyNonExec(M)
then metaOneRewriting#(M,{T,TP,S})
else metaOneRewriting$(M,{T,TP,S})
fi .
--- Based on narrowing -----------------------------
op metaNormalizeCollect# : Module Term ~> ResultTripleSet .
eq metaNormalizeCollect#(M,T)
= metaNormalizeCollect#(M,{T,leastSort(M,T),none}) .
op metaNormalizeCollect# : Module Term Type -> ResultTripleSet .
eq metaNormalizeCollect#(M,T,TP)
= metaNormalizeCollect#(M,{T,TP,none}) .
---metaSearch of Maude doesn't work for rules with extra vars
op metaNormalizeCollect# : Module ResultTriple -> ResultTripleSet .
eq metaNormalizeCollect#(M,{T,TP,S})
= toTriple(M,
metaNarrowSearchAll(
M,
T, (addType TP ToVar 'XXXXXXX),
none,'!,unbounded,unbounded,E-rewriting noStrategy,
{T,TP,S,none,[],[],T << S,T << S,
max(highestVar(S),highestVar((T,T << S))) + 1,
empty}
)) .
op metaOneRewriting# : Module Term ~> ResultTripleSet .
eq metaOneRewriting#(M,T)
= metaOneRewriting#(M,{T,leastSort(M,T),none}) .
op metaOneRewriting# : Module Term Type -> ResultTripleSet .
eq metaOneRewriting#(M,T,TP)
= metaOneRewriting#(M,{T,TP,none}) .
op metaOneRewriting# : Module ResultTriple -> ResultTripleSet .
eq metaOneRewriting#(M,{T,TP,S})
= toTriple(M,
metaNarrowSearchAll(
M,
T, (addType TP ToVar 'XXXXXXX),
none,'+,1,unbounded,E-rewriting noStrategy,
{T,TP,S,none,[],[],T << S,T << S,
max(highestVar(S),highestVar((T,T << S))) + 1,
empty}
)) .
*** Remove itself
op noSelf : ResultContextSet ResultContextSet -> ResultContextSet .
eq noSelf(empty,RTS')
= RTS' .
eq noSelf({T,TP,S,S*,Ct,CtS,TS,CtTS,NextVar,B:Flags} | RTS,RTS')
= noSelf(RTS,
if TS == T and-then CtTS == T and-then Ct == [] and-then CtS == []
then noSelf*({T,TP,S,S*,Ct,CtS,TS,CtTS,NextVar,B:Flags}, RTS')
else RTS'
fi
) .
op noSelf* : ResultContext ResultContextSet -> ResultContextSet .
eq noSelf*(RT,empty)
= empty .
eq noSelf*({T,TP,S,S*,[],[],T,T,NextVar,B:Flags},
{T',TP',S',S'*,Ct',CtS',TS',CtTS',NextVar',B':Flags} | RTS)
= if TS' == T' and-then CtTS' == T' and-then Ct' == [] and-then CtS' == []
and-then
T == T' and-then TP == TP'
and-then
(S |> T) == (S' |> T)
then ---remove
empty
else ---keep
{T',TP',S',S'*,Ct',CtS',TS',CtTS',NextVar',B':Flags}
fi
| noSelf*({T,TP,S,S*,[],[],T,T,NextVar,B:Flags},RTS) .
endfm
fmod META-E-NARROWING is
protecting META-TERM .
protecting META-LEVEL .
protecting META-UNIFICATION .
protecting META-MSG-UNIFICATION .
protecting META-E-UNIFICATION .
protecting RESULT-CONTEXT-SET .
protecting ORDERS-TERM-SUBSTITUTION .
protecting TYPEOFNARROWING .
protecting META-NORMALIZE .
protecting UNIFICATIONTRIPLESET .
protecting RIGIDIFE .
var T T' T'' TOrig Lhs Lhs' Rhs Rhs' : Term .
var CT' TS TS' TS'' CtTS CtTS' CtTS'' : Term .
var V : Variable .
var C : Constant .
var F : Qid .
var M : Module .
var RTS RTS' RTS$ RTS-Rls RTS-Sub RTSSol : ResultContextSet .
var RTNeS : ResultContextNeSet .
var RT RT' : ResultContext .
vars S S' S'' Subst Subst' S* S'* : Substitution .
var SS : SubstitutionSet .
var RLS : RuleSet .
var RL : Rule .
vars Att Att' : AttrSet .
var B BN : Bound .
vars N N' N1 N2 : Nat .
var NL : NatList .
vars Ct CtS Ct' CtS' Ct'' CtS'' : Context .
var NeTL NeTL' : NeTermList .
vars TL TL' TL'' TL''' : TermList .
vars TP TP' TP'' : Type .
var ON : TypeOfNarrowing .
vars NextVar NextVar' NextVar'' NVarPrev : Nat .
var U : UnificationTriple .
vars US US' : UnificationTripleSet .
var IRR : IrrFlags .
--- metaNarrow ---------------------------
---( We implement:
* basic narrowing, where terms introduced
by unifiers (substitutions) are never
selected for narrowing, and
* standard narrowing, where this
restriction does not apply )
*** Shortcuts to Narrowing
op metaNarrow : Module Term -> ResultTripleSet .
eq metaNarrow(M,T) = metaNarrow(M,T,1) .
op metaNarrow : Module Term Bound -> ResultTripleSet .
eq metaNarrow(M,T,B)
= toTriple(M,metaENarrowShowAll(M,T,B,full noStrategy BuiltIn-unify)) |> T .
*** Shortcuts to Basic Narrowing
op metaBasicNarrow : Module Term -> ResultTripleSet .
eq metaBasicNarrow(M,T) = metaBasicNarrow(M,T,1) .
op metaBasicNarrow : Module Term Bound -> ResultTripleSet .
eq metaBasicNarrow(M,T,B)
= toTriple(M,metaENarrowShowAll(M,T,B,basic noStrategy BuiltIn-unify)) |> T .
*** Shortcuts to Narrowing
op metaENarrow : Module Term -> ResultTripleSet .
eq metaENarrow(M,T) = metaENarrow(M,T,1) .
op metaENarrow : Module Term Bound -> ResultTripleSet .
eq metaENarrow(M,T,B)
= toTriple(M,metaENarrowShowAll(M,T,B,full noStrategy E-BuiltIn-unify))
|> T .
*** Shortcuts to Narrowing
op metaEBuiltInTopMostNarrow : Module Term -> ResultTripleSet .
eq metaEBuiltInTopMostNarrow(M,T)
= metaETopMostNarrow(M,T,1,reducible, E-BuiltIn-unify) .
op metaEBuiltInTopMostNarrowIrr : Module Term -> ResultTripleSet .
eq metaEBuiltInTopMostNarrowIrr(M,T)
= metaETopMostNarrow(M,T,1,irreducible, E-BuiltIn-unify) .
op metaEACTopMostNarrow : Module Term -> ResultTripleSet .
eq metaEACTopMostNarrow(M,T)
= metaETopMostNarrow(M,T,1,reducible, E-AC-unify) .
op metaEACTopMostNarrowIrr : Module Term -> ResultTripleSet .
eq metaEACTopMostNarrowIrr(M,T)
= metaETopMostNarrow(M,T,1,irreducible, E-AC-unify) .
op metaEACUTopMostNarrow : Module Term -> ResultTripleSet .
eq metaEACUTopMostNarrow(M,T)
= metaETopMostNarrow(M,T,1,reducible, E-ACU-unify) .
op metaEACUTopMostNarrowIrr : Module Term -> ResultTripleSet .
eq metaEACUTopMostNarrowIrr(M,T)
= metaETopMostNarrow(M,T,1,reducible, E-ACU-unify) .
op metaETopMostNarrow : Module Term Bound IrrFlags TypeOfNarrowing
-> ResultTripleSet .
eq metaETopMostNarrow(M,T,B,IRR,ON)
= toTriple(M,metaENarrowShowAll(M,T,B,full topmost ON [IRR])) |> T .
--- Auxiliary
op [_,_] : TypeOfNarrowing IrrFlags ~> TypeOfNarrowing .
eq [ E-ACU-unify, reducible ] = E-ACU-unify .
eq [ E-ACU-unify, irreducible ] = E-ACU-unify-Irr .
eq [ E-AC-unify, reducible ] = E-AC-unify .
eq [ E-AC-unify, irreducible ] = E-AC-unify-Irr .
eq [ E-BuiltIn-unify, reducible ] = E-BuiltIn-unify .
eq [ E-BuiltIn-unify, irreducible ] = E-BuiltIn-unify-Irr .
*** Shortcuts to Basic Narrowing
op metaEBasicNarrow : Module Term -> ResultTripleSet .
eq metaEBasicNarrow(M,T)
= metaEBasicNarrow(M,T,1) .
*** Shortcuts for normalization
op metaEBasicNarrow : Module Term Bound -> ResultTripleSet .
eq metaEBasicNarrow(M,T,B)
= toTriple(M,metaENarrowShowAll(M,T,B,E-BuiltIn-unify noStrategy basic)) |> T .
op metaBasicNarrowNormalize : Module Term -> ResultTripleSet .
eq metaBasicNarrowNormalize(M,T)
= toTriple(M,metaBasicNarrowNormalizeAll(M,T,highestVar(T) + 1)) |> T .
op metaBasicNarrowNormalizeAll : Module Term Nat -> ResultContextSet .
eq metaBasicNarrowNormalizeAll(M,T,NextVar)
= metaENarrowShowAll(M,T,unbounded,
basic BuiltIn-unify
computed-normalized-subs applied-normalized-subs
normalize-terms noStrategy,NextVar) .
op metaNarrowNormalize : Module Term -> ResultTripleSet .
eq metaNarrowNormalize(M,T)
= toTriple(M,metaNarrowNormalizeAll(M,T,highestVar(T) + 1)) |> T .
op metaNarrowNormalizeAll : Module Term Nat -> ResultContextSet .
eq metaNarrowNormalizeAll(M,T,NextVar)
= metaENarrowShowAll(M,T,unbounded,
full BuiltIn-unify
computed-normalized-subs applied-normalized-subs
normalize-terms noStrategy,NextVar) .
*** General Call
op metaENarrowShowAll : Module Term Bound TypeOfNarrowing
-> ResultContextSet .
eq metaENarrowShowAll(M,T,B,ON)
= metaENarrowShowAll(M,T,B,ON,highestVar(T) + 1) .
op metaENarrowShowAll : Module Term Bound TypeOfNarrowing Bound
-> ResultContextSet .
eq metaENarrowShowAll(M,T,B,ON,N)
= metaENarrowGen(removeBoolEqs(M),B,ON,
{T,leastSort(M,T),none,none,[],[],T,T,N,empty}) .
*** Call for ResultContextSet
op metaENarrowGen : Module Bound TypeOfNarrowing
ResultContextSet
-> ResultContextSet .
eq metaENarrowGen(M,B,ON,RTS)
= if B == 0
then RTS
else metaENarrowGen*(M,B,ON,empty,empty,RTS)
fi .
op metaENarrowGen* : Module
Bound TypeOfNarrowing
ResultContextSet ResultContextSet ResultContextSet
-> ResultContextSet .
eq metaENarrowGen*(M,B,ON,RTSSol,RTS',empty)
= if RTS' == empty
or-else
(B =/= unbounded and-then B <= 1)
then RTSSol | RTS' --- Stop
else metaENarrowGen*(M,dec(B),ON,RTSSol,empty,RTS')
fi .
eq metaENarrowGen*(M,B,ON,RTSSol,RTS',RT | RTS)
= if isEND(normalize-terms?(M,ON,RT))
then metaENarrowGen*(M,B,ON,
RTSSol | normalize-terms?(M,ON,RT),
RTS',RTS)
else metaENarrowGen*(M,B,ON,RTSSol,
RTS' |
filter-variant-RT(M,ON,normalize-terms?(M,ON,RT),
metaENarrowGen**(M,B,ON,normalize-terms?(M,ON,RT))),
RTS)
fi .
op testNonVarRedex : TypeOfNarrowing Term Term -> Bool .
eq testNonVarRedex(basic ON,T,TS) = not(T :: Variable) .
eq testNonVarRedex(ON,T,TS) = not(TS :: Variable) [owise] .
op metaENarrowGen** : Module
Bound TypeOfNarrowing
ResultContext
-> ResultContextSet .
eq metaENarrowGen**(M,B,ON,{T,TP,S,S',Ct,CtS,TS,CtTS,NextVar,B:Flags})
= if not testNonVarRedex(ON,T,TS) --- T is a variable
then if CtS == []
then *** Term CtTS is a normal form so we return it
{T,TP,S,S',Ct,CtS,TS,CtTS,NextVar,B:Flags}
else *** Term T is a rigid normal form inside a context Ct
*** but since no rewrite has been done and
*** this can be part of a previous metaNarrowSub call,
*** this path is discarded
empty
fi
else if metaENarrowStra(M,B,ON,{T,TP,S,S',Ct,CtS,TS,CtTS,NextVar,B:Flags})
=/= empty
then metaENarrowStra(M,B,ON,{T,TP,S,S',Ct,CtS,TS,CtTS,NextVar,B:Flags})
else if CtS == []
then *** Term CtTS is a normal form so we return it
{T,TP,S,S',Ct,CtS,TS,CtTS,NextVar,end(true,B:Flags)}
else *** Term T is a rigid normal form inside a context Ct
*** but since no rewrite has been done and
*** this can be part of a previous metaNarrowSub call,
*** this path is discarded
empty
fi
fi
fi .
*** Try all rules at top level of term T in context Ct with metaENarrowRls
*** Try also inner subterms of T with metaENarrowSub
*** Note that metaENarrowRls and metaENarrowSub
*** call to metaNarrow recursively
op metaENarrowStra : Module Bound TypeOfNarrowing ResultContext
-> ResultContextSet . ---[memo] .
---innermost
eq metaENarrowStra(M,B,innermost ON,RT)
= if metaENarrowSub(M,B,innermost ON,RT) =/= empty
then metaENarrowSub(M,B,innermost ON,RT)
else metaENarrowRls(M,B,innermost ON,getRls(M),RT)
fi .
---outermost
eq metaENarrowStra(M,B,outermost ON,RT)
= if metaENarrowRls(M,B,outermost ON,getRls(M),RT) =/= empty
then metaENarrowRls(M,B,outermost ON,getRls(M),RT)
else metaENarrowSub(M,B,outermost ON,RT)
fi .
---topmost
eq metaENarrowStra(M,B,topmost ON,RT)
= metaENarrowRls(M,B,topmost ON,getRls(M),RT) .
---noStrategy
eq metaENarrowStra(M,B,noStrategy ON,RT)
= metaENarrowRls(M,B,noStrategy ON,getRls(M),RT)
|
metaENarrowSub(M,B,noStrategy ON,RT) .
op dec : Bound -> Bound .
eq dec(unbounded) = unbounded .
eq dec(s(N)) = N .
*** Generic call to metaUnification with different parameters
op auxMetaUnify : Module TypeOfNarrowing
Term Term Nat ~> UnificationTripleSet .
--- Term Lhs
eq auxMetaUnify(M,variant(N') ON,T,T',N)
--- = auxMetaUnify*(M,variant(N') ON,T,T',N) filterBy N' .
= unrigidife(qid(N'),
auxMetaUnify*(getM(rigidifeNat(M,qid(N'),T,N')),
variant(N') ON,
getTL(rigidifeNat(M,qid(N'),T,N')),
T',
N)
) .
eq auxMetaUnify(M,ON,T,T',N)
= auxMetaUnify*(M,ON,T,T',N) [owise] .
op auxMetaUnify* : Module TypeOfNarrowing
Term Term Nat ~> UnificationTripleSet .
--- Term Lhs
eq auxMetaUnify*(M,E-rewriting ON,T,T',N)
= toUnificationTriple[N](metaCoreMatch(removeBoolEqs(M),T,T')) .
eq auxMetaUnify*(M,E-ACU-unify ON,T,T',N)
= metaEACUUnify(removeBoolEqs(M),T,T',N,reducible) .
eq auxMetaUnify*(M,E-ACU-unify-Irr ON,T,T',N)
= metaEACUUnify(removeBoolEqs(M),T,T',N,irreducible) .
eq auxMetaUnify*(M,E-AC-unify ON,T,T',N)
= metaEACUnify(removeBoolEqs(M),T,T',N,reducible) .
eq auxMetaUnify*(M,E-AC-unify-Irr ON,T,T',N)
= metaEACUnify(removeBoolEqs(M),T,T',N,irreducible) .
eq auxMetaUnify*(M,E-BuiltIn-unify ON,T,T',N)
= metaEBuiltInUnify(removeBoolEqs(M),T,T',N,reducible) .
eq auxMetaUnify*(M,E-BuiltIn-unify-Irr ON,T,T',N)
= metaEBuiltInUnify(removeBoolEqs(M),T,T',N,irreducible) .
eq auxMetaUnify*(M,ACU-unify ON,T,T',N)
= metaACUUnify(removeBoolEqs(M),T,T',N) .
eq auxMetaUnify*(M,AC-unify ON,T,T',N)
= metaACUnify(removeBoolEqs(M),T,T',N) .
eq auxMetaUnify*(M,BuiltIn-unify ON,T,T',N)
= metaBuiltInUnify(removeBoolEqs(M),T,T',N) .
*** Remove rigid normal forms
op removeEND : ResultContextSet -> ResultContextSet .
eq removeEND(RTS)
= removeEND*(RTS,empty) .
op removeEND* : ResultContextSet ResultContextSet -> ResultContextSet .
eq removeEND*(empty,RTS')
= RTS' .
eq removeEND*(RT | RTS,RTS')
= removeEND*(RTS,if isEND(RT) then RTS' else RTS' | RT fi) .
op remove_From_ : ResultContextSet ResultContextSet -> ResultContextSet .
eq remove(RT | RTS) From (RT | RTS')
= remove(RTS) From (RT | RTS') .
eq remove(RTS) From (RTS')
= RTS [owise] .
op isEND : ResultContext -> Bool .
eq isEND({T,TP,S,S',Ct,CtS,TS,CtTS,NextVar,B:Flags})
= end(B:Flags) .
*** Call for Rules ---> Returns empty if no rule is applied
op metaENarrowRls : Module Bound TypeOfNarrowing
RuleSet ResultContext
-> ResultContextSet .
eq metaENarrowRls(M,B,ON,RL RLS,RT)
= metaENarrowRls#(M,B,ON,RL RLS,RT,empty) .
eq metaENarrowRls(M,B,ON,none,RT)
= empty .
op metaENarrowRls# : Module Bound TypeOfNarrowing
RuleSet ResultContext ResultContextSet
-> ResultContextSet .
eq metaENarrowRls#(M,B,ON,none,RT,RTS)
= RTS .
eq metaENarrowRls#(M,B,ON,RL RLS,RT,RTS)
= metaENarrowRls#(M,B,ON,RLS,RT,
RTS |
filter-variant-RT(M,ON,RT,
metaENarrowRls*(M,B,ON,RL,RT)
)
) .
--- General case
op metaENarrowRls* : Module Bound TypeOfNarrowing
Rule ResultContext
-> ResultContextSet .
eq metaENarrowRls*(M,B,ON,
(rl Lhs => Rhs [Att].),
{T,TP,S,S',Ct,CtS,TS,CtTS,NextVar,B:Flags})
= metaENarrowRls**$(M,B,ON,
(rl Lhs => Rhs [Att].),
{T,TP,S,S',Ct,CtS,TS,CtTS,NextVar,B:Flags},
'rl_=>_`[_`].[Lhs,Rhs,'none.AttrSet] <<{none,NextVar}<) .
eq metaENarrowRls*(M,B,ON, X:Rule, X:ResultContext)
= empty [owise] .
op metaENarrowRls**$ : Module Bound TypeOfNarrowing
Rule ResultContext
UnificationPair
-> ResultContextSet .
eq metaENarrowRls**$(M,B,ON,
(rl Lhs => Rhs [Att].),
{T,TP,S,S',Ct,CtS,TS,CtTS,NextVar,B:Flags},
{Subst,NextVar'})
= metaENarrowRls**$$(M,B,ON,
{T,TP,S,S',Ct,CtS,TS,CtTS,NextVar,B:Flags},
{Subst,NextVar'},
'rl_=>_`[_`].[Lhs,Rhs,'none.AttrSet] << Subst) .
op metaENarrowRls**$$ : Module Bound TypeOfNarrowing
ResultContext
UnificationPair Term
-> ResultContextSet .
eq metaENarrowRls**$$(M,B,ON,
{T,TP,S,S',Ct,CtS,TS,CtTS,NextVar,B:Flags},
{Subst,NextVar'},
'rl_=>_`[_`].[Lhs',Rhs','none.AttrSet])
= metaENarrowRls**$$$(M,B,ON,
{T,TP,S,S',Ct,CtS,TS,CtTS,NextVar,B:Flags},
{Subst,NextVar'},
'rl_=>_`[_`].[Lhs',Rhs','none.AttrSet],
auxMetaUnify(M,ON,TS,Lhs',NextVar')) .
op metaENarrowRls**$$$ : Module Bound TypeOfNarrowing
ResultContext
UnificationPair Term UnificationTripleSet
-> ResultContextSet .
eq metaENarrowRls**$$$(M,B,ON,
{T,TP,S,S',Ct,CtS,TS,CtTS,NextVar,B:Flags},
{Subst,NextVar'},
'rl_=>_`[_`].[Lhs',Rhs','none.AttrSet],US)
= if US =/= empty
then rebuildTypeAndDiscardErroneous(M,ON,
{Ct[Rhs'],
TP,
S,S',
[],
[],
CtS[Rhs'],
CtS[Rhs'],
NextVar',
B:Flags}
<<(M,ON) US
)
else empty
fi .
*** rebuild the context of the applied rule **********************
op rebuildTypeAndDiscardErroneous : Module TypeOfNarrowing
ResultContextSet -> ResultContextSet .
eq rebuildTypeAndDiscardErroneous(M,ON,empty)
= empty .
eq rebuildTypeAndDiscardErroneous(M,ON,RT | RTS)
= rebuildTypeAndDiscardErroneous*(M,ON,RT)
| rebuildTypeAndDiscardErroneous(M,ON,RTS) .
op rebuildTypeAndDiscardErroneous* : Module TypeOfNarrowing
ResultContext -> ResultContextSet .
eq rebuildTypeAndDiscardErroneous*(M,ON,
{T,TP,S,S',[],[],TS,TS,NextVar,B:Flags})
= if leastSort(M,TS) :: Type
then normalize-terms?(M,ON,
{canonice(M,T),leastSort(M,TS),S,S',
[],[],canonice(M,TS),canonice(M,TS),
NextVar,B:Flags})
else empty
fi .
*** auxiliary for variant narrowing **********************
op _<<`(_`,_`)_ : ResultContext
Module TypeOfNarrowing
UnificationTripleSet -> ResultContextSet .
eq RT <<(M,ON) (empty).UnificationTripleSet
= (empty).ResultContextSet .
eq {T,TP,S,S',Ct:Context,CtS:Context,TS:Term,CtTS:Term,NextVar,B:Flags}
<<(M,ON) ({Subst,Subst',N} | SS:UnificationTripleSet)
= {T,TP,S,S',Ct:Context,CtS:Context,TS:Term,CtTS:Term,NextVar,B:Flags}
<<((M,ON)) {Subst,Subst',N}
|
{T,TP,S,S',Ct:Context,CtS:Context,TS:Term,CtTS:Term,NextVar,B:Flags}
<<(M,ON) SS:UnificationTripleSet .
op _<<`(`(_`,_`)`)_ : ResultContext
Module TypeOfNarrowing
UnificationTriple -> ResultContextSet .
eq {T,TP,S,S',Ct:Context,CtS:Context,TS:Term,CtTS:Term,NextVar,B:Flags}
<<((M,ON)) {Subst,Subst',N}
= if (variant in ON
and-then
(Subst == none
or-else normalizedSubstitution?(M,Subst ; Subst')))
or-else
(computed-normalized-subs in ON
and-then normalizedSubstitution?(M,Subst))
or-else
(applied-normalized-subs in ON
and-then normalizedSubstitution?(M,Subst'))
or-else
(not variant in ON
and-then
not applied-normalized-subs in ON
and-then
not computed-normalized-subs in ON)
then {T,TP,S,S',Ct:Context,CtS:Context,TS:Term,CtTS:Term,NextVar,B:Flags}
<< {Subst,Subst',N}
else (empty).ResultContextSet
fi .
*** test flag normalize-terms and normalize **********************
*** !!!! This mustn't be combined with basic -> strange behavior
op normalize-terms? : Module TypeOfNarrowing ResultContext
-> ResultContext .
eq normalize-terms?(M,E-normalize-terms ON,
{T,TP,S,S',[],[],TS,TS,NextVar,B:Flags})
= {getTerm(metaReduce(M,T)),
getType(metaReduce(M,T)),
S,S',[],[],
getTerm(metaReduce(M,TS)),
getTerm(metaReduce(M,TS)),
NextVar,B:Flags} .
eq normalize-terms?(M,normalize-terms ON,
{T,TP,S,S',[],[],TS,TS,NextVar,B:Flags})
= {getTerm(metaNormalizeCollect(M,T)),
getType(metaNormalizeCollect(M,T)),
S,S',[],[],
getTerm(metaNormalizeCollect(M,TS)),
getTerm(metaNormalizeCollect(M,TS)),
NextVar,B:Flags} .
eq normalize-terms?(M,ON,RT)
= RT [owise] .
*** Call at inner subterms
op metaENarrowSub : Module Bound TypeOfNarrowing ResultContext
-> ResultContextSet . ---[memo] .
eq metaENarrowSub(M,B,ON,{T,TP,S,S',Ct,CtS,TS,CtTS,NextVar,B:Flags})
= metaENarrowSub#(M,B,ON,flatten(M,auxSplitTerm(ON,T,TS)),
{T,TP,S,S',Ct,CtS,TS,CtTS,NextVar,B:Flags}) .
op auxSplitTerm : TypeOfNarrowing Term Term -> Term .
eq auxSplitTerm(basic ON,T,TS) = T .
eq auxSplitTerm(ON,T,TS) = TS [owise] .
op metaENarrowSub# : Module Bound TypeOfNarrowing Term ResultContext
-> ResultContextSet .
eq metaENarrowSub#(M,B,ON,C,RT) = empty .
eq metaENarrowSub#(M,B,ON,V,RT) = empty .
eq metaENarrowSub#(M,B,ON,F[NeTL],RT)
= metaENarrowSub#Gen(M,B,ON,
splitTerm(M,F,
1,getFrozen(M,F,getTypes(M,NeTL)),
isAssociative(M,F,getTypes(M,NeTL))
or isCommutative(M,F,getTypes(M,NeTL)),
empty,NeTL,RT)) .
op splitTerm : Module Qid
Nat NeNatList Bool
TermList TermList
ResultContext -> ResultContextSet .
eq splitTerm(M,F,
N,NL,AC?:Bool,
TL',empty,
RT)
= empty .
eq splitTerm(M,F,
N,NL,AC?:Bool,
TL',(T,TL),
{T'',TP,S,S',Ct,CtS,TS,CtTS,NextVar,B:Flags})
= if ((not AC?:Bool) and-then N inNatList NL)
or-else
(AC?:Bool and-then NL =/= 0)
then empty
else {T,leastSort(M,T),S,S',
Ct[F[TL',[],TL]],
CtS[F[TL' << (S ; S'),[],TL << (S ; S')]],T << (S ; S'),
CtTS,NextVar,B:Flags}
fi
| splitTerm(M,F,
s(N),NL,AC?:Bool,
(TL',T),TL,
{T'',TP,S,S',Ct,CtS,TS,CtTS,NextVar,B:Flags}) .
op metaENarrowSub#Gen : Module Bound TypeOfNarrowing ResultContextSet
-> ResultContextSet .
eq metaENarrowSub#Gen(M,B,ON,empty)
= empty .
eq metaENarrowSub#Gen(M,B,ON,RT | RTS)
= metaENarrowGen**(M,B,ON,RT) | metaENarrowSub#Gen(M,B,ON,RTS) .
op filter-variant-RT : Module TypeOfNarrowing ResultContext
ResultContextSet -> ResultContextSet .
eq filter-variant-RT(M,ON,
{T,TP,S,S',Ct,CtS,TS,CtTS,NextVar,B:Flags},RTS)
= if variant in ON and testUnifier !in ON
then filter-variant-RT*(M,Vars(TS),empty,RTS)
else RTS
fi .
op filter-variant-RT* :
Module TermList ResultContextSet ResultContextSet -> ResultContextSet .
eq filter-variant-RT*(M,TL,RTS$,empty)
= RTS$ .
eq filter-variant-RT*(M,TL,RTS$,RT | RTS)
= filter-variant-RT**(M,TL,RTS$,RTS,RT,RTS) .
op filter-variant-RT** :
Module TermList ResultContextSet ResultContextSet
ResultContext ResultContextSet -> ResultContextSet .
eq filter-variant-RT**(M,TL,RTS$,RTS',RT,empty)
= --- RT is not implied by any in RTS'
filter-variant-RT*(M,TL,RTS$ | RT,RTS') .
eq filter-variant-RT**(M,TL,RTS$,RT | RTS',RT',RT | RTS)
= if test-variant-RT(M,TL,RT,RT')
then --- RT' is implied by RT in RTS'
filter-variant-RT*(M,TL,RTS$,RT | RTS')
else if test-variant-RT(M,TL,RT',RT)
then --- remove RT from the set RTS'
filter-variant-RT**(M,TL,RTS$,RTS',RT',RTS)
else --- continue searching in RTS
filter-variant-RT**(M,TL,RTS$,RT | RTS',RT',RTS)
fi
fi .
op test-variant-RT : Module TermList ResultContext ResultContext
-> Bool . ---[memo] .
eq test-variant-RT(M,TL,
{T,TP,S,S*,Ct,CtS,TS,CtTS,NextVar,B:Flags},
{T',TP',S',S'*,Ct',CtS',TS',CtTS',NextVar',B':Flags})
= test-variant-RT*(M,TL,S |> TL,S' |> TL) .
op test-variant-RT* : Module TermList Substitution Substitution -> Bool .
eq test-variant-RT*(M,TL,S,S')
= | S | <= | S' |
and-then
S <=[TL,M] S' . --- keep T & remove T'
op |_| : Substitution -> Nat .
eq | (none).Substitution | = 0 .
eq | V <- T ; S | = s(| S |) .
endfm
fmod META-NARROWING-SEARCH is
protecting META-E-NARROWING .
protecting META-TERM .
protecting META-LEVEL .
protecting META-UNIFICATION .
protecting RESULT-CONTEXT-SET .
protecting ORDERS-TERM-SUBSTITUTION .
var T T' TOrig Lhs Rhs TS TS' CtTS CtTS' : Term .
var V : Variable .
var C : Constant .
var F : Qid .
vars TL TL' : TermList .
var M : Module .
var RTS RTS' RTSSol : ResultContextSet .
var RT RT' : ResultContext .
vars TP TP' : Type .
vars S S' Subst S* S'* : Substitution .
var RLS : RuleSet .
var Att : AttrSet .
var B BN : Bound .
var N : Nat .
var NL : NatList .
vars Ct Ct' CtS CtS' : Context .
var ON : TypeOfNarrowing .
vars QQ QQ' : TypeOfRelation .
vars NextVar NextVar' : Nat .
var SCond : SubstitutionCond .
--- metaNarrowSearch --------------------------------------------------------
*** Shortcuts to Narrowing Search
op metaNarrowSearch : Module Term Term -> ResultTripleSet .
eq metaNarrowSearch(M,T,T') = metaNarrowSearch(M,T,T',unbounded) .
op metaNarrowSearch : Module Term Term Bound -> ResultTripleSet .
eq metaNarrowSearch(M,T,T',B) = metaNarrowSearch(M,T,T',B,1) .
op metaNarrowSearch : Module Term Term Bound Bound -> ResultTripleSet .
eq metaNarrowSearch(M,T,T',B,BN) = metaNarrowSearch(M,T,T','!,B,BN) .
op metaNarrowSearch : Module Term Term TypeOfRelation Bound Bound
-> ResultTripleSet .
eq metaNarrowSearch(M,T,T',QQ,B,BN)
= metaNarrowSearch(M,T,T',none,QQ,B,BN) .
op metaNarrowSearch : Module Term Term SubstitutionCond
TypeOfRelation Bound Bound
-> ResultTripleSet .
eq metaNarrowSearch(M,T,T',SCond,QQ,B,BN)
= metaNarrowSearchGen(M,T,T',SCond,QQ,B,BN,
full BuiltIn-unify noStrategy E-normalize-terms) .
*** General Call
op metaNarrowSearchGen : Module Term Term SubstitutionCond
TypeOfRelation
Bound Bound
--- steps sols
TypeOfNarrowing
-> ResultTripleSet .
eq metaNarrowSearchGen(M,T,T',SCond,QQ,B,BN,ON)
= toTriple(M,metaNarrowSearchGenAll(M,T,T',SCond,QQ,B,BN,ON)) .
op metaNarrowSearchGenAll : Module Term Term SubstitutionCond
TypeOfRelation Bound Bound TypeOfNarrowing
-> ResultContextSet .
eq metaNarrowSearchGenAll(M,T,T',SCond,QQ,B,BN,ON)
= metaNarrowSearchGenAll(M,T,T',SCond,QQ,B,BN,ON,highestVar((T,T')) + 1) .
op metaNarrowSearchGenAll : Module Term Term SubstitutionCond
TypeOfRelation Bound Bound TypeOfNarrowing Nat
-> ResultContextSet .
eq metaNarrowSearchGenAll(M,T,T',SCond,QQ,B,BN,ON,N)
= metaNarrowSearchAll(addSorts('Universal,M),
T,T',SCond,QQ,B,BN,ON,
{T,leastSort(M,T),none,none,[],[],T,T,N,empty}) .
*** One Narrowing step in the search process (including possible filters)
op metaNarrowStep : Module SubstitutionCond
ResultContextSet TypeOfNarrowing
-> ResultContextSet .
eq metaNarrowStep(M,SCond,RTS,ON)
= filterSCond(M,SCond,metaENarrowGen(M,1,ON,RTS)) .
*** Filter and normal forms
op filterSCond : Module SubstitutionCond ResultContextSet
-> ResultContextSet .
eq filterSCond(M,none,RTS)
= RTS .
eq filterSCond(M,SCond,RTS)
= filterSCond*(M,SCond,RTS) [owise] .
op filterSCond* : Module SubstitutionCond ResultContextSet
-> ResultContextSet .
eq filterSCond*(M,SCond,empty)
= empty .
eq filterSCond*(M,SCond,RT | RTS)
= filterSCond**(M,SCond,RT) | filterSCond*(M,SCond,RTS) .
op filterSCond** : Module SubstitutionCond ResultContext
-> ResultContextSet . ---[memo] .
eq filterSCond**(M,SCond,{T,TP,S,S',Ct,CtS,TS,CtTS,NextVar,B:Flags})
= if SCond <=[M] S
then {T,TP,S,S',Ct,CtS,TS,CtTS,NextVar,B:Flags}
else empty
fi .
*** Generate next successors in a breadth way
--- We reuse the metaNarrowSearchAll function
op metaNarrowSearchAll : Module Term Term SubstitutionCond TypeOfRelation
Bound Bound --- number steps / number solutions
TypeOfNarrowing
ResultContextSet
-> ResultContextSet .
eq metaNarrowSearchAll(M,TOrig,T',SCond,QQ,B,BN,ON,RTS)
= if QQ == '+
then noSelf(RTS,
metaNarrowSearchCheck(M,TOrig,T',SCond,'*,B,BN,ON,empty,RTS,empty)
)
else metaNarrowSearchCheck(M,TOrig,T',SCond,QQ,B,BN,ON,empty,RTS,RTS)
fi .
*** Take only normal forms
op isNF : Module ResultContext -> Bool .
eq isNF(M,{T,TP,S,S',Ct,CtS,TS,CtTS,NextVar,B:Flags})
= end(B:Flags) or-else metaOneRewriting(M,CtTS) == empty .
*** Take only normal forms
op isVariant : Module Nat ResultContextSet ResultContext -> Bool .
eq isVariant(M,N,
{T',TP',S',S'*,Ct',CtS',TS',CtTS',NextVar',B':Flags} | RTS,
{T,TP,S,S*,Ct,CtS,TS,CtTS,NextVar,B:Flags})
= not (
(S' |> N ; (newVar(N + 1,TP') <- CtTS'))
<=[M]
(S |> N ; (newVar(N + 1,TP) <- CtTS))
)
and-then
isVariant(M,N,RTS,{T,TP,S,S*,Ct,CtS,TS,CtTS,NextVar,B:Flags}) .
eq isVariant(M,N,RTS,RT)
= true [owise] .
*** Generate successors
op oneMoreStep : Module SubstitutionCond TypeOfNarrowing
ResultContextSet -> ResultContextSet .
eq oneMoreStep(M,SCond,ON,RTS)
= remove metaNarrowStep(M,SCond,removeEND(RTS),ON) From RTS .
*** Check each next successor for conditions
op metaNarrowSearchCheck : Module Term Term SubstitutionCond
TypeOfRelation Bound Bound TypeOfNarrowing
ResultContextSet ResultContextSet ResultContextSet
-> ResultContextSet .
eq metaNarrowSearchCheck(M,TOrig,T',SCond,QQ,B,BN,ON,RTSSol,RTS',empty)
= if B == 0 or-else BN == 0 or-else RTS' == empty
then *** Stop the search
RTSSol
else *** Compute Next successors of RTS' with oneMoreStep
metaNarrowSearchCheck(M,
TOrig,T',SCond,
QQ,
dec(B),BN,ON,
RTSSol,
oneMoreStep(M,SCond,ON,RTS'),
oneMoreStep(M,SCond,ON,RTS')
)
fi .
eq metaNarrowSearchCheck(M,TOrig,T',SCond,QQ,B,BN,ON,RTSSol,RTS',
RT | RTS)
= if isSolution?(M,TOrig,T',QQ,BN,ON,RTSSol,RT)
then if *** Is actual term an instance of T'?
auxMetaUnify(M,ON,getCTTerm(RT),T',getNextVar(RT)) =/= empty
then *** This is a solution
metaNarrowSearchCheck(M,TOrig,T',SCond,QQ,
B,dec(BN),ON,
RT << auxMetaUnify(M,ON,getCTTerm(RT),T',getNextVar(RT))
| RTSSol,
RTS',RTS)
else *** Continue with the rest
metaNarrowSearchCheck(M,TOrig,T',SCond,QQ,
B,BN,ON,RTSSol,RTS',RTS)
fi
else *** Continue with the rest
metaNarrowSearchCheck(M,TOrig,T',SCond,QQ,
B,BN,ON,RTSSol,RTS',RTS)
fi .
op isSolution? : Module Term Term
TypeOfRelation Bound TypeOfNarrowing
ResultContextSet ResultContext
-> Bool .
eq isSolution?(M,TOrig,T',QQ,BN,ON,RTSSol,RT)
= *** Is this the chosen solution?
(BN == unbounded or-else BN > 0)
and-then
*** Is this step correct wrt relations <'!,'*,'+> ?
( QQ == '* or-else (QQ == '! and-then isEND(RT)) )
and-then
*** Is this a valid variant solution?
(not (variant in ON) or-else
(isNF(M,RT) and-then isVariant(M,highestVar(TOrig) + 1,RTSSol,RT))) .
op upDown : Module ResultTripleSet -> ResultTripleSet .
eq upDown(M,RTS:ResultTripleSet)
= upDown#(M,empty,RTS:ResultTripleSet) .
op upDown# : Module ResultTripleSet ResultTripleSet -> ResultTripleSet .
eq upDown#(M,RTS':ResultTripleSet, empty)
= RTS':ResultTripleSet .
eq upDown#(M,RTS':ResultTripleSet, {T,TP,S} | RTS:ResultTripleSet)
= upDown#(M,{getTerm(metaReduce(M,T)),TP,upDown(M,S)}
| RTS':ResultTripleSet,RTS:ResultTripleSet) .
op upDown : Module Substitution -> Substitution .
eq upDown(M,S:Substitution)
= upDown#(M,none,S:Substitution) .
op upDown# : Module Substitution Substitution -> Substitution .
eq upDown#(M,S':Substitution,none)
= S':Substitution .
eq upDown#(M,S':Substitution,V <- T ; S:Substitution)
= upDown#(M,S':Substitution ; V <- getTerm(metaReduce(M,T)),S:Substitution) .
endfm
*************************************
****** End of Santiago Escobar's code
*******************************************************************************
*******************************************************************************
fmod 2TUPLE{X :: TRIV, Y :: TRIV} is
sorts Tuple{X, Y} .
op ((_,_)) : X$Elt Y$Elt -> Tuple{X, Y} .
op p1_ : Tuple{X, Y} -> X$Elt .
op p2_ : Tuple{X, Y} -> Y$Elt .
eq p1(V1:[X$Elt],V2:[Y$Elt]) = V1:[X$Elt] .
eq p2(V1:[X$Elt],V2:[Y$Elt]) = V2:[Y$Elt] .
endfm
fmod 3TUPLE{X :: TRIV, Y :: TRIV, Z :: TRIV} is
sort Tuple{X, Y, Z} .
op ((_,_,_)) : X$Elt Y$Elt Z$Elt -> Tuple{X, Y, Z} .
op p1_ : Tuple{X, Y, Z} -> X$Elt .
op p2_ : Tuple{X, Y, Z} -> Y$Elt .
op p3_ : Tuple{X, Y, Z} -> Z$Elt .
eq p1((A:[X$Elt], B:[Y$Elt], C:[Z$Elt])) = A:[X$Elt] .
eq p2((A:[X$Elt], B:[Y$Elt], C:[Z$Elt])) = B:[Y$Elt] .
eq p3((A:[X$Elt], B:[Y$Elt], C:[Z$Elt])) = C:[Z$Elt] .
endfm
fmod 4TUPLE{W :: TRIV, X :: TRIV, Y :: TRIV, Z :: TRIV} is
sort Tuple{W, X, Y, Z} .
op ((_,_,_,_)) : W$Elt X$Elt Y$Elt Z$Elt -> Tuple{W, X, Y, Z} .
op p1_ : Tuple{W, X, Y, Z} -> W$Elt .
op p2_ : Tuple{W, X, Y, Z} -> X$Elt .
op p3_ : Tuple{W, X, Y, Z} -> Y$Elt .
op p4_ : Tuple{W, X, Y, Z} -> Z$Elt .
eq p1((A:[W$Elt], B:[X$Elt], C:[Y$Elt], D:[Z$Elt])) = A:[W$Elt] .
eq p2((A:[W$Elt], B:[X$Elt], C:[Y$Elt], D:[Z$Elt])) = B:[X$Elt] .
eq p3((A:[W$Elt], B:[X$Elt], C:[Y$Elt], D:[Z$Elt])) = C:[Y$Elt] .
eq p4((A:[W$Elt], B:[X$Elt], C:[Y$Elt], D:[Z$Elt])) = D:[Z$Elt] .
endfm
fmod 5TUPLE{V :: TRIV, W :: TRIV, X :: TRIV, Y :: TRIV, Z :: TRIV} is
sort Tuple{V, W, X, Y, Z} .
op ((_,_,_,_,_)) : V$Elt W$Elt X$Elt Y$Elt Z$Elt -> Tuple{V, W, X, Y, Z} .
op p1_ : Tuple{V, W, X, Y, Z} -> V$Elt .
op p2_ : Tuple{V, W, X, Y, Z} -> W$Elt .
op p3_ : Tuple{V, W, X, Y, Z} -> X$Elt .
op p4_ : Tuple{V, W, X, Y, Z} -> Y$Elt .
op p5_ : Tuple{V, W, X, Y, Z} -> Z$Elt .
eq p1((A:[V$Elt], B:[W$Elt], C:[X$Elt], D:[Y$Elt], E:[Z$Elt])) = A:[V$Elt] .
eq p2((A:[V$Elt], B:[W$Elt], C:[X$Elt], D:[Y$Elt], E:[Z$Elt])) = B:[W$Elt] .
eq p3((A:[V$Elt], B:[W$Elt], C:[X$Elt], D:[Y$Elt], E:[Z$Elt])) = C:[X$Elt] .
eq p4((A:[V$Elt], B:[W$Elt], C:[X$Elt], D:[Y$Elt], E:[Z$Elt])) = D:[Y$Elt] .
eq p5((A:[V$Elt], B:[W$Elt], C:[X$Elt], D:[Y$Elt], E:[Z$Elt])) = E:[Z$Elt] .
endfm
fmod 6TUPLE{U :: TRIV, V :: TRIV, W :: TRIV, X :: TRIV, Y :: TRIV, Z :: TRIV} is
sort Tuple{U, V, W, X, Y, Z} .
op ((_,_,_,_,_,_)) : U$Elt V$Elt W$Elt X$Elt Y$Elt Z$Elt -> Tuple{U, V, W, X, Y, Z} .
op p1_ : Tuple{U, V, W, X, Y, Z} -> U$Elt .
op p2_ : Tuple{U, V, W, X, Y, Z} -> V$Elt .
op p3_ : Tuple{U, V, W, X, Y, Z} -> W$Elt .
op p4_ : Tuple{U, V, W, X, Y, Z} -> X$Elt .
op p5_ : Tuple{U, V, W, X, Y, Z} -> Y$Elt .
op p6_ : Tuple{U, V, W, X, Y, Z} -> Z$Elt .
eq p1((A:[U$Elt], B:[V$Elt], C:[W$Elt], D:[X$Elt], E:[Y$Elt], F:[Z$Elt])) = A:[U$Elt] .
eq p2((A:[U$Elt], B:[V$Elt], C:[W$Elt], D:[X$Elt], E:[Y$Elt], F:[Z$Elt])) = B:[V$Elt] .
eq p3((A:[U$Elt], B:[V$Elt], C:[W$Elt], D:[X$Elt], E:[Y$Elt], F:[Z$Elt])) = C:[W$Elt] .
eq p4((A:[U$Elt], B:[V$Elt], C:[W$Elt], D:[X$Elt], E:[Y$Elt], F:[Z$Elt])) = D:[X$Elt] .
eq p5((A:[U$Elt], B:[V$Elt], C:[W$Elt], D:[X$Elt], E:[Y$Elt], F:[Z$Elt])) = E:[Y$Elt] .
eq p6((A:[U$Elt], B:[V$Elt], C:[W$Elt], D:[X$Elt], E:[Y$Elt], F:[Z$Elt])) = F:[Z$Elt] .
endfm
view QidList from TRIV to QID-LIST is
sort Elt to QidList .
endv
view TermList from TRIV to META-MODULE is
sort Elt to TermList .
endv
view RuleSet from TRIV to META-MODULE is
sort Elt to RuleSet .
endv
view EquationSet from TRIV to META-MODULE is
sort Elt to EquationSet .
endv
view OpDeclSet from TRIV to META-MODULE is
sort Elt to OpDeclSet .
endv
view ImportList from TRIV to META-MODULE is
sort Elt to ImportList .
endv
view Condition from TRIV to META-MODULE is
sort Elt to Condition .
endv
view QidSet from TRIV to META-MODULE is
sort Elt to QidSet .
endv
view Module from TRIV to META-MODULE is
sort Elt to Module .
endv
view ParameterDeclList from TRIV to META-MODULE is
sort Elt to ParameterDeclList .
endv
view Bound from TRIV to META-LEVEL is
sort Elt to Bound .
endv
view Oid from TRIV to CONFIGURATION is
sort Elt to Oid .
endv
-------------------------------------------------------------------------------
*******************************************************************************
***
*** 2 The Signature of Full Maude
***
*******************************************************************************
-------------------------------------------------------------------------------
fmod EXTENDED-SORTS is
---- Any modification in this module must be reflected in the metamodule
---- used in eq addInfoConds in module UNIT-BUBBLE-PARSING
sorts @SortToken@ @ViewToken@ @Sort@ @Kind@ @Type@ @SortList@
@TypeList@ @ViewExp@ @ModExp@ .
subsorts @SortToken@ < @Sort@ < @SortList@ < @TypeList@ .
subsorts @Sort@ @Kind@ < @Type@ < @TypeList@ .
subsort @ViewToken@ < @ViewExp@ .
op _`{_`} : @Sort@ @ViewExp@ -> @Sort@ [prec 40] .
op __ : @SortList@ @SortList@ -> @SortList@ [assoc] .
op __ : @TypeList@ @TypeList@ -> @TypeList@ [assoc] .
op `[_`] : @Sort@ -> @Kind@ .
op _`,_ : @ViewExp@ @ViewExp@ -> @ViewExp@ [assoc] .
op _`{_`} : @ViewExp@ @ViewExp@ -> @ViewExp@ [prec 40] .
endfm
-------------------------------------------------------------------------------
******************************************************************************
-------------------------------------------------------------------------------
fmod OPERATOR-ATTRIBUTES is
sorts @Attr@ @AttrList@ @Hook@ @HookList@ @Bubble@ @Token@ @NeTokenList@ .
subsort @Attr@ < @AttrList@ .
subsort @Hook@ < @HookList@ .
op __ : @AttrList@ @AttrList@ -> @AttrList@ [assoc] .
ops assoc associative : -> @Attr@ .
ops comm commutative : -> @Attr@ .
ops idem idempotent : -> @Attr@ .
ops id:_ identity:_ : @Bubble@ -> @Attr@ .
ops left`id:_ left`identity:_ : @Bubble@ -> @Attr@ .
ops right`id:_ right`identity:_ : @Bubble@ -> @Attr@ .
ops frozen`(_`) poly`(_`) strat`(_`) strategy`(_`) :
@NeTokenList@ -> @AttrList@ .
ops memo memoization : -> @Attr@ .
ops prec_ precedence_ : @Token@ -> @Attr@ .
ops gather`(_`) gathering`(_`) : @NeTokenList@ -> @Attr@ .
ops format`(_`) : @NeTokenList@ -> @Attr@ .
ops ctor constructor : -> @Attr@ .
ops frozen ditto iter : -> @Attr@ .
ops object msg message config : -> @Attr@ .
op metadata_ : @Token@ -> @Attr@ .
op special`(_`) : @HookList@ -> @Attr@ .
op __ : @HookList@ @HookList@ -> @HookList@ [assoc] .
op id-hook_ : @Token@ -> @Hook@ .
op id-hook_`(_`) : @Token@ @NeTokenList@ -> @Hook@ .
op op-hook_`(_:_->_`) : @Token@ @Token@ @NeTokenList@ @Token@ -> @Hook@ .
op op-hook_`(_:`->_`) : @Token@ @Token@ @Token@ -> @Hook@ .
op op-hook_`(_:_~>_`) : @Token@ @Token@ @NeTokenList@ @Token@ -> @Hook@ .
op op-hook_`(_:`~>_`) : @Token@ @Token@ @Token@ -> @Hook@ .
op term-hook_`(_`) : @Token@ @Bubble@ -> @Hook@ .
endfm
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
fmod MOD-EXPRS is
including OPERATOR-ATTRIBUTES .
including EXTENDED-SORTS .
sorts @Map@ @MapList@ .
subsort @Map@ < @MapList@ .
subsorts @Token@ < @ModExp@ .
*** module expression
op _*`(_`) : @ModExp@ @MapList@ -> @ModExp@ .
op _`{_`} : @ModExp@ @ViewExp@ -> @ModExp@ .
op TUPLE`[_`] : @Token@ -> @ModExp@ .
op POWER`[_`] : @Token@ -> @ModExp@ .
op _+_ : @ModExp@ @ModExp@ -> @ModExp@ [assoc prec 42] .
*** renaming maps
op op_to_ : @Token@ @Token@ -> @Map@ .
op op_:_->_to_ : @Token@ @TypeList@ @Type@ @Token@ -> @Map@ .
op op_: ->_to_ : @Token@ @Type@ @Token@ -> @Map@ .
op op_:_~>_to_ : @Token@ @TypeList@ @Type@ @Token@ -> @Map@ .
op op_: ~>_to_ : @Token@ @Type@ @Token@ -> @Map@ .
op op_to_`[_`] : @Token@ @Token@ @AttrList@ -> @Map@ .
op op_:_->_to_`[_`] : @Token@ @TypeList@ @Type@ @Token@ @AttrList@ -> @Map@ .
op op_:`->_to_`[_`] : @Token@ @Type@ @Token@ @AttrList@ -> @Map@ .
op op_:_~>_to_`[_`] : @Token@ @TypeList@ @Type@ @Token@ @AttrList@ -> @Map@ .
op op_:`~>_to_`[_`] : @Token@ @Type@ @Token@ @AttrList@ -> @Map@ .
op sort_to_ : @Sort@ @Sort@ -> @Map@ .
op label_to_ : @Token@ @Token@ -> @Map@ .
op class_to_ : @Sort@ @Sort@ -> @Map@ .
op attr_._to_ : @Sort@ @Token@ @Token@ -> @Map@ .
op msg_to_ : @Token@ @Token@ -> @Map@ .
op msg_:_->_to_ : @Token@ @TypeList@ @Type@ @Token@ -> @Map@ .
op msg_:`->_to_ : @Token@ @Type@ @Token@ -> @Map@ .
op _`,_ : @MapList@ @MapList@ -> @MapList@ [assoc prec 42] .
endfm
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
fmod SIGNATURES is
inc MOD-EXPRS .
sorts @SortDecl@ @SubsortRel@ @SubsortDecl@ @OpDecl@ .
op `(_`) : @Token@ -> @Token@ .
*** sort declaration
op sorts_. : @SortList@ -> @SortDecl@ .
op sort_. : @SortList@ -> @SortDecl@ .
*** subsort declaration
op subsort_. : @SubsortRel@ -> @SubsortDecl@ .
op subsorts_. : @SubsortRel@ -> @SubsortDecl@ .
op _<_ : @SortList@ @SortList@ -> @SubsortRel@ .
op _<_ : @SortList@ @SubsortRel@ -> @SubsortRel@ .
*** operator declaration
op op_:`->_. : @Token@ @Type@ -> @OpDecl@ .
op op_:`->_`[_`]. : @Token@ @Type@ @AttrList@ -> @OpDecl@ .
op op_:_->_. : @Token@ @TypeList@ @Type@ -> @OpDecl@ .
op op_:_->_`[_`]. : @Token@ @TypeList@ @Type@ @AttrList@ -> @OpDecl@ .
op ops_:`->_. : @NeTokenList@ @Type@ -> @OpDecl@ .
op ops_:`->_`[_`]. : @NeTokenList@ @Type@ @AttrList@ -> @OpDecl@ .
op ops_:_->_. : @NeTokenList@ @TypeList@ @Type@ -> @OpDecl@ .
op ops_:_->_`[_`]. : @NeTokenList@ @TypeList@ @Type@ @AttrList@ -> @OpDecl@ .
op op_:`~>_. : @Token@ @Sort@ -> @OpDecl@ .
op op_:`~>_`[_`]. : @Token@ @Sort@ @AttrList@ -> @OpDecl@ .
op op_:_~>_. : @Token@ @TypeList@ @Sort@ -> @OpDecl@ .
op op_:_~>_`[_`]. : @Token@ @TypeList@ @Sort@ @AttrList@ -> @OpDecl@ .
op ops_:`~>_. : @NeTokenList@ @Sort@ -> @OpDecl@ .
op ops_:`~>_`[_`]. : @NeTokenList@ @Sort@ @AttrList@ -> @OpDecl@ .
op ops_:_~>_. : @NeTokenList@ @TypeList@ @Sort@ -> @OpDecl@ .
op ops_:_~>_`[_`]. : @NeTokenList@ @TypeList@ @Sort@ @AttrList@ -> @OpDecl@ .
endfm
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
fmod F&S-MODS&THS is
including SIGNATURES .
including QID-LIST .
sorts @FDeclList@ @SDeclList@ @Module@ @ImportDecl@ @Parameter@
@List<Parameter>@ @EqDecl@ @RlDecl@ @MbDecl@ @VarDecl@ @VarDeclList@ .
subsort @VarDecl@ < @VarDeclList@ .
subsorts @VarDecl@ @ImportDecl@ @SortDecl@ @SubsortDecl@ @OpDecl@ @MbDecl@
@EqDecl@ @VarDeclList@ < @FDeclList@ .
subsorts @RlDecl@ @FDeclList@ < @SDeclList@ .
*** variable declaration
op vars_:_. : @NeTokenList@ @Type@ -> @VarDecl@ .
op var_:_. : @NeTokenList@ @Type@ -> @VarDecl@ .
*** membership axiom declaration
op mb_:_. : @Bubble@ @Bubble@ -> @MbDecl@ .
----op mb[_]:_:_. : @Token@ @Bubble@ @Bubble@ -> @MbDecl@ .
op cmb_:_if_. : @Bubble@ @Sort@ @Bubble@ -> @MbDecl@ .
op cmb[_]:_:_if_. : @Token@ @Bubble@ @Sort@ @Bubble@ -> @MbDecl@ .
*** equation declaration
op eq_=_. : @Bubble@ @Bubble@ -> @EqDecl@ .
op ceq_=_if_. : @Bubble@ @Bubble@ @Bubble@ -> @EqDecl@ .
op cq_=_if_. : @Bubble@ @Bubble@ @Bubble@ -> @EqDecl@ .
*** rule declaration
*** op rl`[_`]:_=>_. : @Token@ @Bubble@ @Bubble@ -> @RlDecl@ .
op rl_=>_. : @Bubble@ @Bubble@ -> @RlDecl@ .
*** op crl`[_`]:_=>_if_. : @Token@ @Bubble@ @Bubble@ @Bubble@ -> @RlDecl@ .
op crl_=>_if_. : @Bubble@ @Bubble@ @Bubble@ -> @RlDecl@ .
*** importation declaration
ops including_. inc_. : @ModExp@ -> @ImportDecl@ .
ops extending_. ex_. : @ModExp@ -> @ImportDecl@ .
ops protecting_. pr_. : @ModExp@ -> @ImportDecl@ .
sorts @Interface@ .
subsort @Parameter@ < @List<Parameter>@ .
subsorts @Token@ < @Interface@ .
*** parameterized module interface
op _::_ : @Token@ @ModExp@ -> @Parameter@ [prec 40 gather (e &)] .
op _::_ : @Token@ @Interface@ -> @Parameter@ [prec 40 gather (e &)] .
op _`,_ : @List<Parameter>@ @List<Parameter>@ -> @List<Parameter>@ [assoc] .
op _`{_`} : @ModExp@ @List<Parameter>@ -> @Interface@ .
*** declaration list
op __ : @VarDeclList@ @VarDeclList@ -> @VarDeclList@ [assoc] .
op __ : @SDeclList@ @SDeclList@ -> @SDeclList@ [assoc] .
op __ : @FDeclList@ @FDeclList@ -> @FDeclList@ [assoc] .
*** functional and system module and theory
op fmod_is_endfm : @Interface@ @FDeclList@ -> @Module@ .
op obj_is_jbo : @Interface@ @FDeclList@ -> @Module@ .
op obj_is_endo : @Interface@ @FDeclList@ -> @Module@ .
op mod_is_endm : @Interface@ @SDeclList@ -> @Module@ .
op fth_is_endfth : @Interface@ @FDeclList@ -> @Module@ .
op th_is_endth : @Interface@ @SDeclList@ -> @Module@ .
endfm
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
fmod O-MODS&THS is
including F&S-MODS&THS .
sorts @ClassDecl@ @AttrDecl@ @AttrDeclList@ @SubclassDecl@ @MsgDecl@
@ODeclList@ .
subsorts @SDeclList@ @MsgDecl@ @SubclassDecl@ @ClassDecl@ < @ODeclList@ .
subsort @AttrDecl@ < @AttrDeclList@ .
op __ : @ODeclList@ @ODeclList@ -> @ODeclList@ [assoc] .
*** object-oriented module and theory
op omod_is_endom : @Interface@ @ODeclList@ -> @Module@ .
op oth_is_endoth : @Interface@ @ODeclList@ -> @Module@ .
*** class declaration
op class_|_. : @Sort@ @AttrDeclList@ -> @ClassDecl@ .
op class_. : @Sort@ -> @ClassDecl@ .
op _`,_ : @AttrDeclList@ @AttrDeclList@ -> @AttrDeclList@ [assoc] .
op _:_ : @Token@ @Sort@ -> @AttrDecl@ [prec 40] .
*** subclass declaration
op subclass_. : @SubsortRel@ -> @SubclassDecl@ .
op subclasses_. : @SubsortRel@ -> @SubclassDecl@ .
*** message declaration
op msg_:_->_. : @Token@ @SortList@ @Sort@ -> @MsgDecl@ .
op msgs_:_->_. : @NeTokenList@ @SortList@ @Sort@ -> @MsgDecl@ .
op msg_:`->_. : @Token@ @Sort@ -> @MsgDecl@ .
op msgs_:`->_. : @NeTokenList@ @Sort@ -> @MsgDecl@ .
endfm
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
fmod VIEWS is
including O-MODS&THS .
sorts @ViewDecl@ @ViewDeclList@ @View@ .
subsorts @VarDecl@ < @ViewDecl@ < @ViewDeclList@ .
subsort @VarDeclList@ < @ViewDeclList@ .
*** view maps
op op_to`term_. : @Bubble@ @Bubble@ -> @ViewDecl@ .
op op_to_. : @Token@ @Token@ -> @ViewDecl@ .
op op_:_->_to_. : @Token@ @TypeList@ @Type@ @Token@ -> @ViewDecl@ .
op op_:`->_to_. : @Token@ @Type@ @Token@ -> @ViewDecl@ .
op op_:_~>_to_. : @Token@ @TypeList@ @Type@ @Token@ -> @ViewDecl@ .
op op_:`~>_to_. : @Token@ @Type@ @Token@ -> @ViewDecl@ .
op sort_to_. : @Sort@ @Sort@ -> @ViewDecl@ .
op class_to_. : @Sort@ @Sort@ -> @ViewDecl@ .
op attr_._to_. : @Sort@ @Token@ @Token@ -> @ViewDecl@ .
op msg_to_. : @Token@ @Token@ -> @ViewDecl@ .
op msg_:_->_to_. : @Token@ @TypeList@ @Type@ @Token@ -> @ViewDecl@ .
op msg_:`->_to_. : @Token@ @Type@ @Token@ -> @ViewDecl@ .
*** view
op view_from_to_is_endv : @Interface@ @ModExp@ @ModExp@ @ViewDeclList@ -> @View@ .
op view_from_to_is endv : @Interface@ @ModExp@ @ModExp@ -> @View@ .
op __ : @ViewDeclList@ @ViewDeclList@ -> @ViewDeclList@ [assoc] .
endfm
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
fmod COMMANDS is
including MOD-EXPRS .
sorts @Command@ .
*** down function
op down_:_ : @ModExp@ @Command@ -> @Command@ .
*** parse commands
op parse_. : @Bubble@ -> @Command@ .
*** reduce commands
op red_. : @Bubble@ -> @Command@ .
op reduce_. : @Bubble@ -> @Command@ .
*** rewrite commands
op rew_. : @Bubble@ -> @Command@ .
op rewrite_. : @Bubble@ -> @Command@ .
*** frewrite commands
op frew_. : @Bubble@ -> @Command@ .
op frewrite_. : @Bubble@ -> @Command@ .
*** search commands
op search_=>1_. : @Bubble@ @Bubble@ -> @Command@ .
op search_=>*_. : @Bubble@ @Bubble@ -> @Command@ .
op search_=>+_. : @Bubble@ @Bubble@ -> @Command@ .
op search_=>!_. : @Bubble@ @Bubble@ -> @Command@ .
*** search commands
op search_~>1_. : @Bubble@ @Bubble@ -> @Command@ .
op search_~>*_. : @Bubble@ @Bubble@ -> @Command@ .
op search_~>+_. : @Bubble@ @Bubble@ -> @Command@ .
op search_~>!_. : @Bubble@ @Bubble@ -> @Command@ .
*** matching commands
op match_<=?_. : @Bubble@ @Bubble@ -> @Command@ .
op xmatch_<=?_. : @Bubble@ @Bubble@ -> @Command@ .
*** unifying command
op unify_. : @Bubble@ -> @Command@ .
*** unifying command
op id-unify_. : @Bubble@ -> @Command@ .
*** select command
op select_. : @ModExp@ -> @Command@ .
*** show commands
op show`module`. : -> @Command@ .
op show`module_. : @ModExp@ -> @Command@ .
op show`all`. : -> @Command@ .
op show`all_. : @ModExp@ -> @Command@ .
op show`vars`. : -> @Command@ .
op show`vars_. : @ModExp@ -> @Command@ .
op show`sorts`. : -> @Command@ .
op show`sorts_. : @ModExp@ -> @Command@ .
op show`ops`. : -> @Command@ .
op show`ops_. : @ModExp@ -> @Command@ .
op show`mbs`. : -> @Command@ .
op show`mbs_. : @ModExp@ -> @Command@ .
op show`eqs`. : -> @Command@ .
op show`eqs_. : @ModExp@ -> @Command@ .
op show`rls`. : -> @Command@ .
op show`rls_. : @ModExp@ -> @Command@ .
op show`view_. : @ViewExp@ -> @Command@ .
op show`modules`. : -> @Command@ .
op show`views`. : -> @Command@ .
*** set commands
op set`protect_on`. : @ModExp@ -> @Command@ .
op set`protect_off`. : @ModExp@ -> @Command@ .
op set`include_on`. : @ModExp@ -> @Command@ .
op set`include_off`. : @ModExp@ -> @Command@ .
op set`extend_on`. : @ModExp@ -> @Command@ .
op set`extend_off`. : @ModExp@ -> @Command@ .
*** miscellaneous
op load_. : @Bubble@ -> @Command@ .
ops remove`identity`attributes`. rm`ids`. : -> @Command@ .
ops remove`identity`attributes_. rm`ids_. : @ModExp@ -> @Command@ .
op remove`assoc`attributes`. : -> @Command@ .
op remove`assoc`attributes_. : @ModExp@ -> @Command@ .
op acu`coherence`completion`. : -> @Command@ .
op acu`coherence`completion_. : @ModExp@ -> @Command@ .
op help`. : -> @Command@ .
endfm
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
fmod FULL-MAUDE-SIGN is
including VIEWS .
including COMMANDS .
sort @Input@ .
subsorts @Command@ @Module@ @View@ < @Input@ .
endfm
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
*******
******* ERROR HANDLING, by Peter Olveczky
*******
*** The following module defines a function which prints up to n characters
*** of a bubble, followed by the usual arrow <---*HERE* which points to the
*** erroneous token:
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
fmod PRINT-SYNTAX-ERROR is
protecting META-LEVEL .
protecting INT .
var QIL : QidList .
var Q : Qid .
var N : Nat .
vars RP RP' : ResultPair .
var RP? : [ResultPair?] .
op printN : Nat QidList -> QidList . *** first N qid's in a qidList
eq printN(N, nil) = nil .
eq printN(0, QIL) = nil .
eq printN(s N, Q QIL) = Q printN(N, QIL) .
op removeFront : Nat QidList -> QidList . *** removes first N qid's
eq removeFront(N, nil) = nil .
eq removeFront(0, QIL) = QIL .
eq removeFront(s N, Q QIL) = removeFront(N, QIL) .
op printSyntaxError : [ResultPair?] QidList -> QidList .
eq printSyntaxError(noParse(N), QIL)
= '\r 'Parse 'error 'in '\o '\s printN(N + 1, QIL) '\r '<---*HERE* '\o .
eq printSyntaxError(ambiguity(RP, RP'), QIL)
= '\r 'Ambiguous 'parsing 'for '\o '\s QIL '\o .
eq printSyntaxError(RP?, QIL) = QIL [owise] .
endfm
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
***
*** The Abstract Data Type \texttt{Module}
***
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
*** In this section we present the abstract data type \texttt{Module}, which
*** can be seen as an extension of the predefined sort \texttt{Module} in
*** several ways. There are constructors for functional, system, and object-
*** oriented modules and theories, which can be parameterized and can import
*** module expressions. There can also be parameterized sorts in Full Maude
*** modules, and therefore, the constructors for the different declarations
*** that can appear in a module have to be appropriately extended.
*** The section is structured as follows. After introducing some modules
*** defining some functions on the predefined sorts \texttt{Bool} and
*** \texttt{QidList} in Section~\ref{BOOL-QID-LIST}, we present in
*** Sections~\ref{EXT-SORT} and~\ref{EXT-DECL} the data types for extended
*** sorts and extended declarations. In Section~\ref{mod-exp-mod-id} we
*** introduce module expressions and module names, and in
*** Section~\ref{unitADT} the abstract data type \texttt{Module} itself.
***
*** Extension \texttt{QID-LIST}
***
*** The conversion of lists of quoted identifiers into single quoted
*** identifiers by concatenating them is heavily used in the coming modules.
*** This is the task of the \texttt{} function, which is
*** introduced in the following module \texttt{EXT-QID-LIST} extending the
*** predefined module \texttt{QID-LIST}.
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
fmod EXT-QID-LIST is
pr QID-LIST .
op qidList2Qid : QidList -> Qid .
var QI : Qid .
var QIL : QidList .
vars St St' : String .
var N : Nat .
var F : FindResult .
eq qidList2Qid(('\s QIL)) = qid(" " + string(qidList2Qid(QIL))) .
eq qidList2Qid((QI QIL))
= qid(string(QI) + " " + string(qidList2Qid(QIL)))
[owise] .
eq qidList2Qid(nil) = qid("") .
op trimQidList : QidList -> QidList .
eq trimQidList(' QIL) = trimQidList(QIL) .
eq trimQidList(QI QIL) = QI trimQidList(QIL) [owise] .
eq trimQidList(nil) = nil .
op qidList2string : QidList -> String .
eq qidList2string(QI QIL) = string(QI) + " " + qidList2string(QIL) .
eq qidList2string(nil) = "" .
op string2qidList : String -> QidList .
op string2qidListAux : String -> QidList .
eq string2qidList(St) = trimQidList(string2qidListAux(St)) .
eq string2qidListAux("") = nil .
ceq string2qidListAux(St)
= if F == notFound
then qid(substr(St, findNonSpace(St), length(St)))
else qid(substr(St, findNonSpace(St), F))
if substr(St, findNonSpace(St) + F, 1) =/= " "
then qid(substr(St, findNonSpace(St) + F, 1))
else nil
fi
string2qidListAux(substr(St, findNonSpace(St) + F + 1, length(St)))
fi
if F := myfind(substr(St, findNonSpace(St), length(St)), " (){}[],", 0)
[owise] .
op findNonSpace : String -> Nat .
op findNonSpace : String Nat -> Nat .
---- returns the length of the string if not found
eq findNonSpace(St) = findNonSpace(St, 0) .
eq findNonSpace(St, N)
= if N < length(St)
then if substr(St, N, 1) == " "
then findNonSpace(St, N + 1)
else N
fi
else length(St)
fi .
op myfind : String String Nat -> FindResult .
eq myfind(St, St', N)
= if N < length(St)
then if find(St', substr(St, N, 1), 0) =/= notFound
then N
else myfind(St, St', N + 1)
fi
else notFound
fi .
endfm
fmod HELP is
pr EXT-QID-LIST .
op fm-help : -> QidList .
eq fm-help
= string2qidList("Additional commands available:") '\n
'\t string2qidList("(load <meta-module> .)") '\n
'\t '\t string2qidList("Takes as argument a term of sort Module,") '\s string2qidList("i.e.,") '\s string2qidList("a metaterm.") '\n
'\t '`( 'remove 'id 'attributes '\s '`[ '<module-expr.> '`] '\s '. '`) '\s '| '\s '`( 'remove 'ids '\s '`[ '<module-expr.> '`] '\s '. '`) '\n
'\t '\t string2qidList("Shows the module with the id attributes removed using variants.") '\n
'\t string2qidList("(remove assoc attributes") '\s string2qidList("[<module-expr.>]") '\s string2qidList(".)") '\n
'\t '\t string2qidList("Shows the module with the assoc (if not with comm) attributes removed using variants.") '\n
'\t string2qidList("(acu coherence completion") '\s string2qidList("[<module-expr.>]") '\s string2qidList(".)") '\n
'\t '\t string2qidList("Shows the module resulting from completing for ACU coherence.") '\n .
endfm
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
*** 3.2 View Expressions and Extended Sorts
*** To allow the use of parameterized sorts, or sorts qualified by the view
*** expression with which the parameterized module in which the given sorts
*** appear is instantiated, we add the sort Sort of ``extended sorts'' as a
*** supersort of the predefined sort Sort. View expressions and extended
*** sorts are introduced in the following modules.
*** 3.2.1 View Expressions
*** A view expression is given by a single quoted identifier, by a sequence of
*** view expressions (at the user level, separated by commas), or by the
*** composition of view expressions. In the current version, the composition
*** of view expressions is only used internally; we plan to make it available
*** to the user with syntax \verb~_;_~ in the future. View expressions are
*** used in the instantiation of parameterized modules and in parameterized
*** sorts. We plan to support parameterized views in the future as well. We
*** use operators \verb~_|_~ and \verb~_;;_~ to represent, respectively,
*** sequences and composition of view expressions.
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
fmod VIEW-EXPR is
pr META-MODULE .
sort ViewExp .
subsorts Sort < ViewExp < ModuleExpression NeParameterList .
op mtViewExp : -> ViewExp .
op _{_} : Sort ParameterList -> ViewExp [ctor prec 37].
op _;;_ : ViewExp ViewExp -> ViewExp
[assoc id: mtViewExp] . *** view composition _;_
endfm
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
*** Since the Core Maude engine does not know about view expressions, or, as
*** we shall see, about extended sorts, extended module expressions, extended
*** modules, and other declarations that we introduce, to be able to use them
*** with built-in functions such as \texttt{sameComponent},
*** \texttt{leastSort}, \texttt{metaReduce}, etc., we shall have to convert
*** them into terms which only use the built-in constructors. Thus, for
*** example, view expressions in sort \texttt{ViewExp} will be converted
*** into quoted identifiers of sort \texttt{Qid} by means of function
*** \texttt{parameter2Qid}, or, similarly, elements of sorts \texttt{Sort},
*** \texttt{SortList}, and \texttt{SortSet} are transformed into elements
*** of sorts \texttt{Qid}, \texttt{QidList}, and \texttt{QidSet},
*** respectively, with functions \texttt{eSortToQid} defined on the
*** appropriate sorts.
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
fmod VIEW-EXPR-TO-QID is
pr VIEW-EXPR .
pr EXT-QID-LIST .
op viewExp2Qid : ViewExp -> Qid .
op parameterList2Qid : ParameterList -> Qid .
op viewExp2QidList : ViewExp -> QidList .
op parameterList2QidList : ParameterList -> QidList .
op eMetaPrettyPrint : ViewExp -> QidList .
ceq eMetaPrettyPrint(VE) = viewExp2QidList(VE) if not VE :: TypeList .
var V : Sort .
var QI : Qid .
var QIL : QidList .
var P : ViewExp .
var PL : NeParameterList .
vars VE VE' : ViewExp .
eq parameterList2QidList(P) = viewExp2QidList(P) .
ceq parameterList2QidList((P, PL))
= (if QI == '`) then QIL QI '\s else QIL QI fi)
'`, parameterList2QidList(PL)
if QIL QI := viewExp2QidList(P).
eq viewExp2QidList(V{PL})
= (viewExp2QidList(V) '`{ parameterList2QidList(PL) '`}) .
ceq viewExp2QidList(VE ;; VE')
= (viewExp2QidList(VE) '; viewExp2QidList(VE'))
if VE =/= mtViewExp /\ VE' =/= mtViewExp .
eq viewExp2QidList(V) = V .
eq parameterList2Qid(P) = viewExp2Qid(P) .
eq parameterList2Qid((P, PL))
= qid(string(viewExp2Qid(P)) + ", " + string(parameterList2Qid(PL))) .
eq viewExp2Qid(VE) = qidList2Qid(viewExp2QidList(VE)) .
endfm
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
***
*** Parameterized Sorts
***
*** In addition to the \texttt{Sort} sort, in the following module
*** \texttt{EXT-SORT} we also define sorts \texttt{SortList} and
*** \texttt{SortSet}.
*** The operator \texttt{eSort} is declared to be a constructor for extended
*** sorts.
*** As for lists and sTS of quoted identifiers, we declare \verb~__~ and
*** \verb~_;_~ as constructors for sorts \texttt{SortList} and
*** \texttt{SortList}, and \texttt{SortSet}, respectively.
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
fmod EXT-SORT is
pr META-LEVEL .
pr EXT-BOOL .
pr VIEW-EXPR-TO-QID .
pr EXT-QID-LIST .
pr TERMSET .
*** We define operations extending the built-in functions \texttt{sameKind}
*** and \texttt{leastSort}, respectively, to lists of sorts and
*** to lists of extended terms. The function \texttt{sameKind} takes
*** a module and two lists of extended sorts as arguments, and returns
*** \texttt{true} if the $i$-th elements of both lists are in the same
*** connected component of sorts. This function will be used, for example, to
*** check whether two operators are in the same family of subsort overloaded
*** operators. \texttt{leastSort} returns a list of sorts where the $i$-th
*** element of the list is the least sort, computed by the homonymous built-in
*** function, of the $i$-th term in the list of terms given as argument.
*** Moreover, we define a function \verb~_in_~ to check whether an
*** extended sort is in a given set of extended sorts. Note that before
*** calling the built-in function \texttt{sameComponent}, extended sorts of
*** sort \texttt{Sort} have to be `desugared' into sorts of sort
*** \texttt{Sort} as defined in the predefined \texttt{META-LEVEL} module.
*** This conversion is done by the \texttt{eTypeToType} function. Basically,
*** user-defined sorts are converted into quoted identifiers by concatenating
*** the list of identifiers composing the name of the sort. For example, sorts
*** \texttt{'Nat} and \texttt{'List['Nat]} are converted, respectively, into
*** \texttt{'Nat} and \texttt{'List`[Nat`]}. Error
*** sorts~\cite{ClavelDuranEkerLincolnMarti-OlietMeseguerQuesada99} are left
*** as such.
vars Tp Tp' Tp'' Tp''' : Type .
vars TpL TpL' : TypeList .
op sameKind : Module TypeList TypeList -> Bool [ditto] .
eq sameKind(M:Module, (Tp Tp' TpL), (Tp'' Tp''' TpL'))
= sameKind(M:Module, Tp, Tp'')
and-then sameKind(M:Module, Tp' TpL, Tp''' TpL') .
eq sameKind(M:Module, nil, nil) = true .
eq sameKind(M:Module, TpL, TpL) = false [owise] .
eq sameKind(M:Module, cc(S:Sort ; SS:SortSet), Tp)
= sameKind(M:Module, S:Sort, Tp) .
eq sameKind(M:Module, Tp, cc(S:Sort ; SS:SortSet))
= sameKind(M:Module, Tp, S:Sort) .
eq sameKind(M:Module, cc(S:Sort ; SS:SortSet), cc(S':Sort ; SS':SortSet))
= sameKind(M:Module, S:Sort, S':Sort) .
op eLeastSort : Module TermList ~> TypeList .
eq eLeastSort(M:Module, (T:Term, TL:TermList))
= (leastSort(M:Module, T:Term) eLeastSort(M:Module, TL:TermList)) .
eq eLeastSort(M:Module, empty) = nil .
eq eLeastSort(M:Module, qidError(QIL)) = qidError(QIL) .
op eLeastSort : Module TermSet ~> TypeSet .
eq eLeastSort(M:Module, (T:Term | TS:TermSet))
= (leastSort(M:Module, T:Term) ; eLeastSort(M:Module, TS:TermSet)) .
eq eLeastSort(M:Module, emptyTermSet) = none .
eq eLeastSort(M:Module, qidError(QIL)) = qidError(QIL) .
op qidError : QidList -> [Sort] .
op stringError : QidList -> [String] .
eq string(qidError(QIL)) = stringError(QIL) .
eq qid(stringError(QIL)) = qidError(QIL) .
eq stringError(QIL) + St:String = stringError(QIL) .
op getMsg : [Sort] -> QidList .
eq getMsg(qidError(QIL:QidList)) = QIL:QidList .
op kind : TypeList -> Type .
eq kind(S:Sort TL:TypeList)
= qid("[" + string(S:Sort) + "]") kind(TL:TypeList) .
eq kind(K:Kind TL:TypeList) = K:Kind kind(TL:TypeList) .
eq kind(nil) = nil .
op kind : SortSet -> Type .
eq kind(S:Sort ; SS:SortSet) = qid("[" + string(S:Sort) + "]") .
op cc : SortSet -> Type .
op getSort : Kind -> Sort .
eq getSort(K:Kind)
= if findOut(string(K:Kind), "`,", "{", "}", 0) == notFound
then qid(substr(string(K:Kind),
2,
sd(length(string(K:Kind)), 4)))
else qid(substr(string(K:Kind),
2,
sd(findOut(string(K:Kind), "`,", "{", "}", 0), 2)))
fi .
op getSorts : Kind -> SortSet .
eq getSorts(K:Kind)
= if findOut(string(K:Kind), "`,", "{", "}", 0) == notFound
then qid(substr(string(K:Kind),
2,
sd(length(string(K:Kind)), 4)))
else qid(substr(string(K:Kind),
2,
sd(findOut(string(K:Kind), "`,", "{", "}", 0), 2)))
;
getSorts(qid("[" + substr(string(K:Kind),
sd(findOut(string(K:Kind), "`,", "{", "}", 0), 1),
length(string(K:Kind)))))
fi .
---- op qid2Sort : Sort -> Sort .
---- eq qid2Sort(S:Sort) = getName{S:Sort} { getPars(S:Sort) } .
---- name of a sort (the name of S{P1, ..., Pn} is S)
op getName : Sort -> Qid .
eq getName(S:Sort)
= if findOpening(string(S:Sort), "{", "}", sd(length(string(S:Sort)), 2))
== notFound
then S:Sort
else qid(substr(string(S:Sort),
0,
findOpening(string(S:Sort),
"{", "}",
sd(length(string(S:Sort)), 2))))
fi .
---- parameters of a sort (the parameters of S{P1, ..., Pn} are P1 ... Pn)
op getPars : Sort -> ParameterList [memo] .
op getParsAux : String Nat Nat -> ParameterList .
eq getPars(S:Sort)
= if findOpening(string(S:Sort), "{", "}", sd(length(string(S:Sort)), 2))
== notFound
then empty
else getParsAux(string(S:Sort),
findOpening(string(S:Sort),
"{", "}", sd(length(string(S:Sort)), 2)) + 1,
length(string(S:Sort)))
fi .
var St Pattern OpenPar ClosingPar : String .
vars L R N OpenPars ClosingPars : Nat .
eq getParsAux(St, L, R)
= if findOut(St, ",", "{", "}", L) == notFound
then qid(substr(St, L, sd(findClosing(St, "{", "}", L), L)))
else (qid(substr(St, L, sd(findOut(St, ",", "{", "}", L), L))),
getParsAux(St, findOut(St, ",", "{", "}", L) + 1, R))
fi .
---- finds a pattern out of balanced parentheses
---- findOut("S{P1, P2{P21, P22}, P3}", ",", "{", "}", 6) returns 18, not 12
op findOut : String String String String Nat -> FindResult .
op findOut : String String String String Nat Nat -> FindResult .
eq findOut(St, Pattern, OpenPar, ClosingPar, N)
= findOut(St, Pattern, OpenPar, ClosingPar, 0, N) .
eq findOut(St, Pattern, OpenPar, ClosingPar, OpenPars, N)
= if N >= length(St)
then notFound
else if OpenPars == 0 and-then substr(St, N, length(Pattern)) == Pattern
then N
else if substr(St, N, length(OpenPar)) == OpenPar
then findOut(St, Pattern, OpenPar, ClosingPar,
OpenPars + 1, N + 1)
else if substr(St, N, length(ClosingPar)) == ClosingPar
then findOut(St, Pattern, OpenPar, ClosingPar,
sd(OpenPars, 1), N + 1)
else findOut(St, Pattern, OpenPar, ClosingPar,
OpenPars, N + 1)
fi
fi
fi
fi .
---- finds the first closing unbalanced parenthesis
---- findOut("P1, P2{P21, P22}, P3}", "{", "}", 6) returns 21, not 16
op findClosing : String String String Nat -> FindResult .
op findClosing : String String String Nat Nat -> FindResult .
eq findClosing(St, OpenPar, ClosingPar, N)
= findClosing(St, OpenPar, ClosingPar, 0, N) .
eq findClosing(St, OpenPar, ClosingPar, OpenPars, N)
= if N >= length(St)
then notFound
else if OpenPars == 0
and-then substr(St, N, length(ClosingPar)) == ClosingPar
then N
else if substr(St, N, length(OpenPar)) == OpenPar
then findClosing(St, OpenPar, ClosingPar,
OpenPars + 1, N + 1)
else if substr(St, N, length(ClosingPar)) == ClosingPar
then findClosing(St, OpenPar, ClosingPar,
sd(OpenPars, 1), N + 1)
else findClosing(St, OpenPar, ClosingPar,
OpenPars, N + 1)
fi
fi
fi
fi .
---- finds the last opening unbalanced parenthesis
---- findOpening("S{P1, P2{P21, P22}, P3}", "{", "}", 21) returns 1, not 8
op findOpening : String String String Nat -> FindResult .
op findOpening : String String String Nat Nat -> FindResult .
eq findOpening(St, OpenPar, ClosingPar, N)
= findOpening(St, OpenPar, ClosingPar, 0, N) .
eq findOpening(St, OpenPar, ClosingPar, ClosingPars, N)
= if N == 0
then notFound
else if ClosingPars == 0
and-then substr(St, N, length(ClosingPar)) == OpenPar
then N
else if substr(St, N, length(OpenPar)) == ClosingPar
then findOpening(St, OpenPar, ClosingPar,
ClosingPars + 1, sd(N, 1))
else if substr(St, N, length(ClosingPar)) == OpenPar
then findOpening(St, OpenPar, ClosingPar,
sd(ClosingPars, 1), sd(N, 1))
else findOpening(St, OpenPar, ClosingPar,
ClosingPars, sd(N, 1))
fi
fi
fi
fi .
op makeSort : Sort ParameterList -> Sort .
op makeSort : Sort ParameterList ParameterList ParameterList -> Sort .
op makeSort2 : Sort ParameterList -> Sort .
op makePars : ParameterList -> String .
vars S P : Sort .
vars PL PL' PL'' PL3 : ParameterList .
var VE : ViewExp .
var QIL : QidList .
var K : Kind .
eq makeSort(S, PL)
= if PL == empty
then S
else makeSort(S, PL, empty, empty)
fi .
----eq makeSort(S, P, PL, PL') = makeSort(S, empty, (PL, P), PL') .
eq makeSort(S, (P, PL), PL', PL'') = makeSort(S, PL, (PL', P), PL'') .
eq makeSort(S, (P{PL}, PL'), PL'', PL3)
= makeSort(S, PL', (PL'', makeSort(P, PL)), PL3) .
----eq makeSort(S, (P ;; VE), PL, PL')
---- = makeSort(S, empty, (PL, P), (PL', VE))
---- [owise] .
eq makeSort(S, ((P ;; VE), PL), PL', PL'')
= makeSort(S, PL, (PL', P), (PL'', VE))
[owise] .
eq makeSort(S, empty, PL, PL')
= if PL' == empty
then makeSort2(S, PL)
else makeSort(makeSort2(S, PL), PL')
fi .
eq makeSort2(S, empty) = S:Sort .
eq makeSort2(S, P) = qid(string(S) + "{" + string(P) + "}") .
eq makeSort2(S, (P, PL))
= qid(string(S) + "{" + string(P) + makePars(PL))
[owise] .
eq makePars((P, PL)) = "," + string(P) + makePars(PL) .
eq makePars(P) = "," + string(P) + "}" .
eq makePars(empty) = "}" .
op list2set : TypeList -> TypeSet .
eq list2set(Tp TpL) = Tp ; list2set(TpL) .
eq list2set(nil) = none .
op type2qid : Type -> Qid .
eq type2qid(S)
= if getPars(S) == empty
then S
else qid(string(getName(S)) + "{" + string(parameterList2QidList(getPars(S))) + "}")
fi .
eq type2qid(K) = qid("[" + string(type2qid(getSort(K))) + "]") .
op size : TypeList -> Nat .
eq size(Tp TpL) = 1 + size(TpL) .
eq size((nil).TypeList) = 0 .
endfm
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
fmod DEFAULT-VALUE{X :: TRIV} is
sort Default{X} .
subsort X$Elt < Default{X} .
op null : -> Default{X} .
endfm
view Term from TRIV to META-TERM is
sort Elt to Term .
endv
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
***
*** Extended Declarations
***
*** In this section we discuss modules \texttt{EXT-DECL} and \texttt{O-O-DECL}
*** which introduce, respectively, the declarations extending the sorts and
*** constructors for declarations of the predefined data type \texttt{Module}
*** in the \texttt{META-LEVEL} module to allow the use of extended sorts in
*** them, and the declarations appearing in object-oriented units, namely
*** class declarations, subclass relation declarations, and message
*** declarations.
***
*** Declarations of Functional and System Modules
***
*** In the following module \texttt{EXT-DECL}, we introduce the declarations
*** extending those in \texttt{META-LEVEL} to allow the use of extended sorts
*** in declarations of sorts, subsort relations, operators, variables, and
*** membership axioms.
*** \begin{comment}
*** \footnote{In the future, the declarations for operators,
*** membership axioms, equations, and rules will be extended to allow
*** the use of extended sorts in sort tests, that is, terms of the
*** form \mbox{\verb~T : S~} and \mbox{\verb~T :: S~}.}
*** \end{comment}
*** The extension is accomplished by adding new supersorts for each of the
*** sorts in \texttt{META-LEVEL} involved, and by adding new constructors for
*** these new sorts.
*** We start introducing the declarations for the supersorts and their
*** corresponding constructors. The \texttt{EXT-DECL} module also contains the
*** declarations for sTS of such declarations.
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
fmod INT-LIST is
pr META-MODULE .
pr INT .
sort IntList .
subsort Int NatList < IntList .
op __ : IntList IntList -> IntList [ctor ditto] .
op numberError : QidList -> [Nat] .
vars N M : Nat .
op from_to_list : Nat Nat ~> NatList .
ceq from N to M list
= if N == M
then N
else N from N + 1 to M list
fi
if N <= M .
endfm
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
fmod EXT-DECL is
pr EXT-SORT .
pr INT-LIST .
var QI : Qid .
vars QIL QIL' : QidList .
var At : Attr .
var AtS : AttrSet .
var OPD OPD' : OpDecl .
var OPDS : OpDeclSet .
vars LHS RHS T T' : Term .
var S : Sort .
var Cond : Condition .
var EqS : EquationSet .
var RlS : RuleSet .
var MbS : MembAxSet .
var M : Module .
op variant : -> Attr [ctor] .
*** subsort declarations error
op subsortDeclError : QidList -> [SubsortDeclSet] [ctor format (r o)] .
eq subsortDeclError(QIL) subsortDeclError(QIL')
= subsortDeclError(QIL QIL') .
*** extended attribute declarations
op strat : IntList -> Attr [ditto] . *** to handle on-demand strategies
op ditto : -> Attr [ctor] .
op _in_ : Attr AttrSet -> Bool .
eq At in At AtS = true .
eq At in AtS = false [owise] .
*** extended operation declarations
op opDeclError : QidList -> [OpDeclSet] [ctor format (r o)] .
eq opDeclError(QIL) opDeclError(QIL') = opDeclError(QIL QIL') .
*** extended membership axioms
op membAxError : QidList -> [MembAxSet] [ctor format (r o)] .
eq membAxError(QIL) membAxError(QIL') = membAxError(QIL QIL') .
*** extended equations
op equationError : QidList -> [EquationSet] [ctor format (r o)] .
eq equationError(QIL) equationError(QIL') = equationError(QIL QIL') .
*** extended rules
op ruleError : QidList -> [RuleSet] [ctor format (r o)] .
eq ruleError(QIL) ruleError(QIL') = ruleError(QIL QIL') .
*** The function \verb~_in_~ checks whether a given operator
*** declaration is in a set of operator declarations.
op _in_ : OpDecl OpDeclSet -> Bool .
eq OPD in (OPD OPDS) = true .
eq OPD in OPDS = false [owise] .
ops lhs rhs : Rule -> Term .
op cond : Rule -> Condition .
op atts : Rule -> AttrSet .
op label : Rule -> [Qid] .
eq lhs(rl LHS => RHS [AtS] .) = LHS .
eq lhs(crl LHS => RHS if Cond [AtS] .) = LHS .
eq rhs(rl LHS => RHS [AtS] .) = RHS .
eq rhs(crl LHS => RHS if Cond [AtS] .) = RHS .
eq cond(rl LHS => RHS [AtS] .) = nil .
eq cond(crl LHS => RHS if Cond [AtS] .) = Cond .
eq atts(rl LHS => RHS [AtS] .) = AtS .
eq atts(crl LHS => RHS if Cond [AtS] .) = AtS .
eq label(rl LHS => RHS [label(QI) AtS] .) = QI .
eq label(crl LHS => RHS if Cond [label(QI) AtS] .) = QI .
ops lhs rhs : Equation -> Term .
op cond : Equation -> Condition .
op atts : Equation -> AttrSet .
op label : Equation -> [Qid] .
eq lhs(eq LHS = RHS [AtS] .) = LHS .
eq lhs(ceq LHS = RHS if Cond [AtS] .) = LHS .
eq rhs(eq LHS = RHS [AtS] .) = RHS .
eq rhs(ceq LHS = RHS if Cond [AtS] .) = RHS .
eq cond(eq LHS = RHS [AtS] .) = nil .
eq cond(ceq LHS = RHS if Cond [AtS] .) = Cond .
eq atts(eq LHS = RHS [AtS] .) = AtS .
eq atts(ceq LHS = RHS if Cond [AtS] .) = AtS .
eq label(eq LHS = RHS [label(QI) AtS] .) = QI .
eq label(ceq LHS = RHS if Cond [label(QI) AtS] .) = QI .
op cond : MembAx -> Condition .
op atts : MembAx -> AttrSet .
eq cond(mb T : S [AtS] .) = nil .
eq cond(cmb T : S if Cond [AtS] .) = Cond .
eq atts(mb T : S [AtS] .) = AtS .
eq atts(cmb T : S if Cond [AtS] .) = AtS .
op rulify : EquationSet -> RuleSet .
---- takes a set of equations and turn them into rules
eq rulify(eq LHS = RHS [AtS] . EqS) = (rl LHS => RHS [AtS] .) rulify(EqS) .
eq rulify(ceq LHS = RHS if Cond [AtS] . EqS) = (crl LHS => RHS if Cond [AtS] .) rulify(EqS) .
eq rulify((none).EquationSet) = none .
endfm
**** The module EXT-TERM extends META-LEVEL with definitions of several
**** operations that manipulate terms: definitions for positions and operations
**** to get the subterm of a given term at a given position, to replace the
**** subterm of a term at a given position by another term, to get all the
**** nonvariable positions in a term, to apply a substitution to a term, and to
**** get a copy of a term in which all the variables in it have been renamed.
fmod EXT-TERM is
pr META-LEVEL .
pr EXT-BOOL .
pr EXT-DECL .
vars T T' : Term .
vars F X : Qid .
var TL : TermList .
var N : Nat .
vars NL NL' : NatList .
vars V V' W : Variable .
var Subst : Substitution .
vars C Ct : Constant .
var NTL : NeTermList .
var M : Module .
var Tp : Type .
vars TpL TpL' : TypeList .
vars AtS AtS' : AttrSet .
var ODS : OpDeclSet .
var Cd : Condition .
var S : Sort .
**** vars returns the set of variables in a term
op vars : Term -> QidSet .
op vars : TermList -> QidSet .
eq vars(V) = V .
eq vars(C) = none .
eq vars(F[TL]) = vars(TL) .
eq vars(empty) = none .
eq vars((T, TL)) = vars(T) ; vars(TL) .
**** varlist returns the list of variables in a term
op varlist : Term -> QidList .
op varlist : TermList -> QidList .
eq varlist(V) = V .
eq varlist(C) = nil .
eq varlist(F[TL]) = varlist(TL) .
eq varlist(empty) = nil .
eq varlist((T, TL)) = varlist(T) varlist(TL) .
**** occurs? checks whether a variable name occurs in a term or not.
op occurs? : Variable Term -> Bool .
op occurs? : Variable TermList -> Bool .
eq occurs?(V, V') = V == V' .
eq occurs?(V, C) = false .
eq occurs?(V, F[TL]) = occurs?(V, TL) .
eq occurs?(V, (T, TL)) = occurs?(V, T) or-else occurs?(V, TL) .
**** occurrences checks whether a variable name occurs in a term or not.
op occurrences : Variable Term -> Nat .
op occurrences : Variable TermList -> Nat .
eq occurrences(V, V') = if V == V' then 1 else 0 fi .
eq occurrences(V, C) = 0 .
eq occurrences(V, F[TL]) = occurrences(V, TL) .
eq occurrences(V, (T, TL)) = occurrences(V, T) + occurrences(V, TL) .
op frozen : Module Term Nat -> Bool .
op frozen : Module OpDeclSet Qid TypeList Nat -> Bool .
eq frozen(M, F[TL], N)
= frozen(M, getOps(M), F, eLeastSort(M, TL), N) .
ceq frozen(M, op F : TpL -> Tp [AtS] . ODS, F, TpL', N)
= true
if sameKind(M, TpL, TpL')
/\ not ctor(M, op F : TpL -> Tp [AtS] . ODS, F, TpL') .
ceq frozen(M, op F : TpL -> Tp [AtS] . ODS, F, TpL', N)
= true
if sameKind(M, TpL, TpL')
/\ ctor(M, op F : TpL -> Tp [AtS] . ODS, F, TpL')
/\ frozen(NL N NL') AtS' := AtS .
eq frozen(M, ODS, F, TpL, N) = false [owise] .
---- ctor check whether the operator at the top is a constructor
---- in any of its overloadings
op ctor : Module OpDeclSet Term -> Bool .
op ctor : Module OpDeclSet Qid TypeList -> Bool .
eq ctor(M, ODS, Ct) = ctor(M, ODS, Ct, nil) .
eq ctor(M, ODS, F[TL]) = ctor(M, ODS, F, eLeastSort(M, TL)) .
eq ctor(M, ODS, T) = false [owise] .
ceq ctor(M, op F : TpL -> Tp [AtS] . ODS, F, TpL')
= ctor in AtS or-else ctor(M, ODS, F, TpL')
if sameKind(M, TpL, TpL') .
eq ctor(M, ODS, F, TpL) = false [owise] .
**** The function \texttt{substitute} takes a term $t$ and a substitution
**** $\sigma$ and returns the term $t\sigma$.
op substitute : Module Term Substitution -> Term .
op substitute : Module TermList Substitution -> TermList .
eq substitute(M, T, none) = T .
eq substitute(M, V, ((W <- T) ; Subst))
= if getName(V) == getName(W) and-then sameKind(M, getType(V), getType(W))
then T
else substitute(M, V, Subst)
fi .
eq substitute(M, C, ((W <- T); Subst)) = C .
eq substitute(M, F[TL], Subst) = F[substitute(M, TL, Subst)] .
eq substitute(M, (T, TL), Subst)
= (substitute(M, T, Subst), substitute(M, TL, Subst)) .
op substitute : Module EqCondition Substitution -> EqCondition .
eq substitute(M, T = T' /\ Cd, Subst)
= substitute(M, T, Subst) = substitute(M, T', Subst) /\ substitute(M, Cd, Subst) .
eq substitute(M, T := T' /\ Cd, Subst)
= substitute(M, T, Subst) := substitute(M, T', Subst) /\ substitute(M, Cd, Subst) .
eq substitute(M, T : S /\ Cd, Subst)
= substitute(M, T, Subst) : S /\ substitute(M, Cd, Subst) .
eq substitute(M, (nil).EqCondition, Subst) = nil .
endfm
***(
red substitute('f['X:Foo, 'g['Y:Foo, 'Z:Foo]], ('Y:Foo <- 'h['W:Foo])) .
red rename('f['X:Foo, 'g['Y:Foo, 'Z:Foo]]) .
red allNonVarPos(
substitute('f['X:Foo, 'g['Y:Foo, 'Z:Foo]], ('Y:Foo <- 'h['W:Foo]))) .
)
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
***
*** Declarations for Object-Oriented Modules
***
*** In the \texttt{O-O-DECL} module we introduce the sorts and constructors
*** for declarations of classes, subclass relations, and messages in
*** object-oriented units.
*** Note that we follow the same naming conventions for classes as for
*** extended sorts (see Section~\ref{parameterized-modules}), and therefore
*** we use the sort \texttt{Sort} for class identifiers, and
*** \texttt{TypeList} and \texttt{SortSet} for lists and sTS of class
*** identifiers, respectively. We use the operator \verb~attr_:_~ as a
*** constructor for declarations of attributes. Since the operator name
*** \texttt{\_\,:\_\,} is used for sort tests in the \texttt{META-LEVEL}
*** module, we use \texttt{attr\_\,:\_\,} as constructor for declarations of
*** attributes to satisfy the preregularity condition.
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
fmod O-O-DECL is
pr EXT-SORT .
vars QIL QIL' : QidList .
sorts AttrDecl AttrDeclSet .
subsort AttrDecl < AttrDeclSet .
op attr_:_ : Qid Sort -> AttrDecl .
op none : -> AttrDeclSet .
op _`,_ : AttrDeclSet AttrDeclSet -> AttrDeclSet [assoc comm id: none] .
eq AD:AttrDecl, AD:AttrDecl = AD:AttrDecl .
sorts ClassDecl ClassDeclSet .
subsort ClassDecl < ClassDeclSet .
op class_|_. : Sort AttrDeclSet -> ClassDecl .
op none : -> ClassDeclSet .
op __ : ClassDeclSet ClassDeclSet -> ClassDeclSet [assoc comm id: none] .
op classDeclError : QidList -> [ClassDeclSet] [ctor format (r o)] .
eq classDeclError(QIL) classDeclError(QIL') = classDeclError(QIL QIL') .
eq CD:ClassDecl CD:ClassDecl = CD:ClassDecl .
sorts SubclassDecl SubclassDeclSet .
subsort SubclassDecl < SubclassDeclSet .
op subclass_<_. : Sort Sort -> SubclassDecl .
op none : -> SubclassDeclSet .
op __ : SubclassDeclSet SubclassDeclSet -> SubclassDeclSet
[assoc comm id: none] .
eq SCD:SubclassDecl SCD:SubclassDecl = SCD:SubclassDecl .
op subclassDeclError : QidList -> [SubclassDeclSet] [ctor format (r o)] .
eq subclassDeclError(QIL) subclassDeclError(QIL')
= subclassDeclError(QIL QIL') .
sorts MsgDecl MsgDeclSet .
subsort MsgDecl < MsgDeclSet .
op msg_:_->_. : Qid TypeList Sort -> MsgDecl .
op none : -> MsgDeclSet .
op __ : MsgDeclSet MsgDeclSet -> MsgDeclSet [assoc comm id: none] .
eq MD:MsgDecl MD:MsgDecl = MD:MsgDecl .
op msgDeclError : QidList -> [MsgDeclSet] [ctor format (r o)] .
eq msgDeclError(QIL) msgDeclError(QIL') = msgDeclError(QIL QIL') .
*** The function \texttt{classSet} returns the set of class identifiers in
*** the set of class declarations given as argument.
op classSet : ClassDeclSet -> SortSet .
eq classSet((class S:Sort | ADS:AttrDeclSet .) CDS:ClassDeclSet)
= (S:Sort ; classSet(CDS:ClassDeclSet)) .
eq classSet(none) = none .
endfm
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
***
*** Renaming Maps
***
*** We introduce the different types of renaming maps in the module
*** \texttt{FMAP} below. A sort is introduced for each of these types of maps,
*** with the appropriate constructors for each sort (see
*** Section~\ref{module-expressions}). All these sorts are declared to be
*** subsorts of the sort \texttt{Map}. A sort for sTS of
*** maps (\texttt{RenamingSet}) is then declared as supersort of \texttt{Map}
*** with constructors \texttt{none} and \verb~_,_~.
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
fmod FMAP is
inc META-MODULE .
pr EXT-SORT .
*** renamings
op class_to_ : Sort Sort -> Renaming .
op attr_._to_ : Qid Sort Qid -> Renaming .
op msg_to_ : Qid Qid -> Renaming .
op msg_:_->_to_ : Qid TypeList Sort Qid -> Renaming .
op none : -> RenamingSet .
eq (MAP, MAP) = MAP .
eq (MAPS, none) = MAPS .
---- eq attr A . qidError(QIL) to A' = none .
*** Given a set of maps, the function \texttt{sortMaps} returns the
*** subset of sort maps in it.
var MAP : Renaming .
var MAPS : RenamingSet .
vars S S' A A' : Sort .
var QIL : QidList .
op sortMaps : RenamingSet -> RenamingSet .
eq sortMaps(sort S to S') = sort S to S' .
eq sortMaps(((sort S to S'), MAPS))
= ((sort S to S'), sortMaps(MAPS)) .
eq sortMaps(MAP) = none [owise] .
eq sortMaps((MAP, MAPS)) = sortMaps(MAPS) [owise] .
eq sortMaps(none) = none .
endfm
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
***
*** Module Expressions and Module Names
***
*** The abstract syntax for writing specifications in Maude can be seen as
*** given by module expressions, where the notion of module expression is
*** understood as an expression that defines a new module out of previously
*** defined modules by combining and/or modifying them according to a specific
*** set of operations. All module expressions will be evaluated generating
*** modules with such module expressions as names. In the case of parameterized
*** modules, each of the parameters in an interface will be used as the name
*** of a new module created as a renamed copy of the parameter theory.
***
*** Module Expressions
***
*** The \texttt{TUPLE} and \texttt{POWER} are declared to be new types of
*** \texttt{ModuleExpression}s.
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
fmod MOD-EXPR is
inc META-MODULE .
pr FMAP .
op TUPLE`[_`] : NzNat -> ModuleExpression .
op POWER`[_`] : NzNat -> ModuleExpression .
eq ME:ModuleExpression * ( none ) = ME:ModuleExpression .
endfm
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
***
*** Module Names
***
*** As we shall see in the coming sections, the evaluation of module
*** expressions may produce the creation of new modules, whose \emph{names}
*** are given by the module expressions themselves. If there is already a
*** module in the database with the module expression being evaluated as name,
*** the evaluation of such module expression does not produce any change in
*** the database. However, the evaluation of a module expression may involve
*** the evaluation of some other module expressions contained in the modules
*** involved, which in turn may generate new modules.
*** Given a parameterized module $\texttt{N\{L}_1\texttt{\ ::\ T}_1
*** \texttt{\ ,\ }\ldots\texttt{\ ,\ L}_n\texttt{\ ::\ T}_n\texttt{\}}$, with
*** $\texttt{L}_1\ldots\texttt{L}_n$ labels and
*** $\texttt{T}_1\ldots\texttt{T}_n$ theory identifiers, we say that
*** \texttt{N} is the name of the module and that
*** $\texttt{\{L}_1\texttt{\ ::\ T}_1\texttt{\ ,\ }
*** \ldots\texttt{\ ,\ L}_n\texttt{\ ::\ T}_n\texttt{\}}$
*** is its \emph{interface}.
*** As we shall see in Sections~\ref{instantiation} and~\ref{unit-processing},
*** for each parameter $\texttt{L}_i\texttt{\ ::\ T}_i$ in the interface of a
*** module, a new module is generated with such a parameter expression as its
*** name, and a declaration importing it in the parameterized module is added.
*** We regard the relationship between the body of a parameterized module and
*** the parameters in its interface, not as an inclusion, but as mediated by
*** a module constructor that generates renamed copies of the parameters,
*** which are then included. Therefore, the sort \texttt{ViewExp} is
*** declared as a subsort of \texttt{Header}, that is, terms of sort
*** \texttt{ViewExp} are considered to be module names. The constructor
*** operator for the sort \texttt{ViewExp} is \verb~par_::_~.
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
fmod MOD-NAME is
inc MOD-EXPR .
pr EXT-BOOL .
op parameterError : QidList -> [ParameterDecl] .
sort ModuleName .
subsorts ModuleExpression < ModuleName < Header .
op _{_} : ModuleExpression ParameterDeclList -> Header .
op pd : ParameterDecl -> ModuleName .
op nullHeader : -> Header .
op getName : Header -> ModuleExpression .
op getParDecls : Header -> ParameterDeclList .
vars QI QI' : Qid .
var ME : ModuleExpression .
vars PDL PDL' : ParameterDeclList .
var PL : NeParameterList .
var MN : ModuleName .
eq getName(ME{PDL}) = ME .
eq getName(MN) = MN .
eq getParDecls(ME{PDL}) = PDL .
eq getParDecls(MN) = nil .
op including_. : ModuleName -> Import [ctor] .
op extending_. : ModuleName -> Import [ctor] .
op protecting_. : ModuleName -> Import [ctor] .
op fth_is_sorts_.____endfth : Header ImportList SortSet SubsortDeclSet
OpDeclSet MembAxSet EquationSet -> FTheory [ctor gather (& & & & & & &)
format (d d d n++i ni d d ni ni ni ni n--i d)] .
op th_is_sorts_._____endth : Header ImportList SortSet SubsortDeclSet
OpDeclSet MembAxSet EquationSet RuleSet -> STheory
[ctor gather (& & & & & & & &)
format (d d d n++i ni d d ni ni ni ni ni n--i d)] .
*** The function \texttt{labelInParameterDeclList} checks whether the quoted
*** identifier given as first argument is used as a label in the list of
*** parameters given as second argument.
op labelInParameterDeclList : Sort ParameterDeclList -> Bool .
eq labelInParameterDeclList(QI, (PDL, (QI :: ME), PDL')) = true .
eq labelInParameterDeclList(QI, PDL) = false [owise] .
endfm
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
*** Since the Core Maude engine assumes that module names are identifiers and
*** does not know about term-structured module names (such as parameterized
*** module interfaces or module expressions), for evaluation purposes we need
*** to transform them into quoted identifiers. The functions
*** \texttt{header2Qid} and \texttt{header2QidList} in the module
*** \texttt{MOD-NAME-TO-QID} below accomplish this transformation. In any
*** language extensions, new equations for the function
*** \texttt{header2QidList} should be added for each new module expression
*** constructor introduced. In Sections~\ref{renaming} and~\ref{instantiation}
*** we shall see how the corresponding equalities are added for renaming and
*** instantiation expressions, and in Section~\ref{extension} for other new
*** module expressions in extensions of Full Maude.
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
fmod MOD-NAME-TO-QID is
pr MOD-NAME .
pr EXT-QID-LIST .
op header2Qid : -> Qid .
op header2QidList : Header -> QidList .
op parameterDecl2Qid : ParameterDecl -> Qid .
op parameterDecl2QidList : ParameterDecl -> QidList .
op parameterDeclList2Qid : ParameterDeclList -> Qid .
op parameterDeclList2QidList : ParameterDeclList -> QidList .
vars QI X : Qid .
var QIL : QidList .
vars ME ME' : ModuleExpression .
var PDL : ParameterDeclList .
var PD : ParameterDecl .
eq header2Qid(QI) = QI .
eq header2Qid(nullHeader) = ' .
eq header2Qid(pd(X :: ME)) = qidList2Qid(header2QidList(pd(X :: ME))) .
eq header2QidList(pd(X :: ME)) = X ':: header2QidList(ME) .
eq header2QidList(QI) = QI .
eq header2QidList(nullHeader) = ' .
eq header2Qid((ME { PDL })) = qidList2Qid(header2QidList((ME { PDL }))) .
ceq header2QidList((ME { PDL }))
= (if QI == '\s then QIL else QIL QI fi
'`{ parameterDecl2QidList(PDL) '`} '\s)
if QIL QI := header2QidList(ME) .
eq parameterDecl2Qid(X :: ME) = qidList2Qid(X ':: header2Qid(ME)) .
eq parameterDeclList2Qid(PDL)
= qidList2Qid(parameterDeclList2QidList(PDL)) .
eq parameterDeclList2QidList(X :: ME) = X ':: header2QidList(ME) .
eq parameterDeclList2QidList((X :: ME, PDL))
= parameterDeclList2QidList(X :: ME) '`, parameterDeclList2QidList(PDL)
[owise] .
endfm
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
***
*** Modules
***
*** We handle six different types of units: functional, system, and
*** object-oriented modules, and functional, system, and object-oriented
*** theories. Modules and theories of any kind are considered to be elements
*** in specific subsorts of the sort \texttt{Module}. A constructor
*** \texttt{error} is also included to represent incorrect units.
*** \texttt{error} has a list of quoted identifiers as argument, which is
*** used to report the error. Besides considering functional and system
*** theories and object-oriented theories and modules, the declarations
*** presented in the following module extend the declarations for sort
*** \texttt{Module} in the \texttt{META-LEVEL} module in three different ways:
*** \begin{itemize}
*** \item the name of a module can be any term of sort \texttt{Header},
*** \item parameterized modules are handled, for which a list of
*** parameters is added to the constructors of modules,
*** \item the importation declaration is extended to module names, and
*** \item parameterized sorts are supported.
*** \end{itemize}
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
fmod UNIT is
pr EXT-DECL .
pr O-O-DECL .
pr MOD-NAME-TO-QID .
inc META-LEVEL .
op moduleName : Import -> ModuleName .
eq moduleName(protecting MN .) = MN .
eq moduleName(protecting ME{PL} .) = ME .
eq moduleName(extending MN .) = MN .
eq moduleName(extending ME{PL} .) = ME .
eq moduleName(including MN .) = MN .
eq moduleName(including ME{PL} .) = ME .
op importError : QidList -> [ImportList] [ctor format (r o)] .
eq importError(QIL) importError(QIL') = importError(QIL QIL') .
sorts OModule OTheory .
subsorts SModule < OModule < Module .
subsorts STheory < OTheory < Module .
op noModule : -> Module . *** Module
op unitError : QidList -> [Module] [ctor format (r o)] .
op getMsg : [Module] -> QidList .
eq getMsg(unitError(QIL)) = QIL .
op omod_is_sorts_.________endom : Header ImportList
SortSet SubsortDeclSet ClassDeclSet SubclassDeclSet OpDeclSet
MsgDeclSet MembAxSet EquationSet RuleSet -> OModule
[ctor
gather (& & & & & & & & & & &)
format (r! o r! n++io ni d d ni ni ni ni ni ni ni ni n--ir! o)] .
op oth_is_sorts_.________endoth : Header ImportList
SortSet SubsortDeclSet ClassDeclSet SubclassDeclSet OpDeclSet
MsgDeclSet MembAxSet EquationSet RuleSet -> OTheory
[ctor
gather (& & & & & & & & & & &)
format (r! o r! n++io ni d d ni ni ni ni ni ni ni ni n--ir! o)] .
*** In addition to the constructor operators, the following functions are
*** introduced in the \texttt{UNIT} module:
*** \begin{itemize}
*** \item A function \verb~_in_~ to check whether a given importation
*** declaration is in a set of importation declarations or not.
op _in_ : Import ImportList -> Bool .
*** \item Selector functions for the different components of a Module.
op getName : Module -> Header .
op getPars : Module -> ParameterDeclList .
op getClasses : Module -> ClassDeclSet .
op getSubclasses : Module -> SubclassDeclSet .
op getMsgs : Module -> MsgDeclSet .
*** \item Functions to change the value of each of the components of a Module.
op setName : Module ModuleExpression -> Module .
op setName : Module ParameterDecl -> Module .
op setPars : Module ParameterDeclList -> Module .
op setImports : Module ImportList -> Module .
op setSorts : Module SortSet -> Module .
op setSubsorts : Module SubsortDeclSet -> Module .
op setOps : Module OpDeclSet -> Module .
op setMbs : Module MembAxSet -> Module .
op setEqs : Module EquationSet -> Module .
op setRls : Module RuleSet ~> Module .
op setClasses : Module ClassDeclSet -> Module .
op setSubclasses : Module SubclassDeclSet -> Module .
op setMsgs : Module MsgDeclSet -> Module .
*** \item Functions to add new declarations to the set of declarations
*** already in a unit.
op addImports : ImportList Module -> Module .
op addSorts : SortSet Module -> Module .
op addSubsorts : [SubsortDeclSet] Module -> Module .
op addOps : [OpDeclSet] Module -> Module .
op addMbs : MembAxSet Module -> Module .
op addEqs : EquationSet Module -> Module .
op addRls : RuleSet Module -> Module .
op addClasses : ClassDeclSet Module -> Module .
op addSubclasses : SubclassDeclSet Module -> Module .
op addMsgs : MsgDeclSet Module -> Module .
*** \item There are functions and constants to create empty modules of the
*** different types. For example, the function \texttt{emptyFTheory}
*** returns an empty functional theory. There is also a
*** function \texttt{empty} which takes a module as argument and returns
*** an empty module of the same type.
op emptyFModule : Header -> FModule .
op emptyFModule : -> FModule .
op emptySModule : -> SModule .
op emptyOModule : -> OModule .
op emptyFTheory : -> FModule .
op emptySTheory : -> SModule .
op emptyOTheory : -> OModule .
op empty : Module -> Module .
*** \item A function \texttt{addDecls} which returns the module resulting from
*** adding all the declarations in the module passed as second argument
*** to the module passed as first argument.
op addDecls : Module Module -> Module .
*** \end{itemize}
*** Note that some of the `set' and `add' functions are partial functions.
vars M M' M'' : Module .
vars QI V : Qid .
var S : Sort .
vars SSDS SSDS' SSDS'' : SubsortDeclSet .
vars OPD OPD' : OpDecl .
vars OPDS OPDS' : OpDeclSet .
var OPDS? : [OpDeclSet] .
var At : Attr .
var AtS : AttrSet .
vars MAS MAS' MbS : MembAxSet .
vars Eq Eq' : Equation .
vars EqS EqS' : EquationSet .
vars Rl Rl' : Rule .
vars RlS RlS' : RuleSet .
vars SS SS' : SortSet .
vars IL IL' : ImportList .
vars QIL QIL' : QidList .
vars PL PL' : ParameterList .
vars CDS CDS' : ClassDeclSet .
vars SCD SCD' : SubclassDecl .
vars SCDS SCDS' : SubclassDeclSet .
vars U U' : Module .
vars MDS MDS' : MsgDeclSet .
vars I I' : Import .
vars T T' T1 T1' T2 T2' : Term .
vars ME ME' : ModuleExpression .
vars PD PD' : ParameterDecl .
vars PDL PDL' : ParameterDeclList .
var H : Header .
vars MN MN' : ModuleName .
var Cd Cond Cond1 Cond2 : Condition .
eq I in (IL I IL') = true .
eq I in IL = false [owise] .
op theory : Module -> Bool .
eq theory(unitError(QIL)) = false .
eq theory(mod H is IL sorts SS . SSDS OPDS MAS EqS RlS endm) = false .
eq theory(th MN is IL sorts SS . SSDS OPDS MAS EqS RlS endth) = true .
eq theory(fmod H is IL sorts SS . SSDS OPDS MAS EqS endfm) = false .
eq theory(fth MN is IL sorts SS . SSDS OPDS MAS EqS endfth) = true .
eq theory(omod H is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endom)
= false .
eq theory(oth MN is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endoth)
= true .
*** Selection functions for units
eq getName(unitError(QIL)) = ' .
eq getName(noModule) = ' .
eq getName(mod ME is IL sorts SS . SSDS OPDS MAS EqS RlS endm) = ME .
eq getName(mod ME{PDL} is IL sorts SS . SSDS OPDS MAS EqS RlS endm) = ME .
eq getName(th MN is IL sorts SS . SSDS OPDS MAS EqS RlS endth) = MN .
----eq getName(th PD is IL sorts SS . SSDS OPDS MAS EqS RlS endth) = PD .
eq getName(fmod ME is IL sorts SS . SSDS OPDS MAS EqS endfm) = ME .
eq getName(fmod ME{PDL} is IL sorts SS . SSDS OPDS MAS EqS endfm) = ME .
eq getName(fth MN is IL sorts SS . SSDS OPDS MAS EqS endfth) = MN .
eq getName(
omod ME is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endom)
= ME .
eq getName(
omod ME{PDL} is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endom)
= ME .
eq getName(
oth MN is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endoth)
= MN .
eq getImports(unitError(QIL)) = nil .
eq getImports(noModule) = nil .
eq getImports(mod H is IL sorts SS . SSDS OPDS MAS EqS RlS endm) = IL .
eq getImports(th H is IL sorts SS . SSDS OPDS MAS EqS RlS endth) = IL .
eq getImports(fmod H is IL sorts SS . SSDS OPDS MAS EqS endfm) = IL .
eq getImports(fth H is IL sorts SS . SSDS OPDS MAS EqS endfth) = IL .
eq getImports(
omod H is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endom)
= IL .
eq getImports(
oth H is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endoth)
= IL .
eq getPars(unitError(QIL)) = nil .
eq getPars(noModule) = nil .
eq getPars(mod ME is IL sorts SS . SSDS OPDS MAS EqS RlS endm) = nil .
eq getPars(mod ME{PDL} is IL sorts SS . SSDS OPDS MAS EqS RlS endm) = PDL .
eq getPars(mod nullHeader is IL sorts SS . SSDS OPDS MAS EqS RlS endm)
= nil .
eq getPars(th MN is IL sorts SS . SSDS OPDS MAS EqS RlS endth) = nil .
eq getPars(th MN is IL sorts SS . SSDS OPDS MAS EqS RlS endth) = nil .
eq getPars(fmod ME is IL sorts SS . SSDS OPDS MAS EqS endfm) = nil .
eq getPars(fmod ME{PDL} is IL sorts SS . SSDS OPDS MAS EqS endfm) = PDL .
eq getPars(fmod nullHeader is IL sorts SS . SSDS OPDS MAS EqS endfm) = nil .
eq getPars(fth MN is IL sorts SS . SSDS OPDS MAS EqS endfth) = nil .
eq getPars(
omod ME is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endom)
= nil .
eq getPars(
omod ME{PDL} is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS
endom)
= PDL .
eq getPars(
omod nullHeader is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS
endom)
= nil .
eq getPars(
oth MN is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endoth)
= nil .
eq getSorts(unitError(QIL)) = none .
eq getSorts(mod H is IL sorts SS . SSDS OPDS MAS EqS RlS endm) = SS .
eq getSorts(th H is IL sorts SS . SSDS OPDS MAS EqS RlS endth) = SS .
eq getSorts(fmod H is IL sorts SS . SSDS OPDS MAS EqS endfm) = SS .
eq getSorts(fth H is IL sorts SS . SSDS OPDS MAS EqS endfth) = SS .
eq getSorts(
omod H is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endom)
= SS .
eq getSorts(
oth H is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endoth)
= SS .
op getAllSorts : Module -> SortSet .
eq getAllSorts(M) = getSorts(M) .
eq getSubsorts(unitError(QIL)) = none .
eq getSubsorts(mod H is IL sorts SS . SSDS OPDS MAS EqS RlS endm) = SSDS .
eq getSubsorts(th H is IL sorts SS . SSDS OPDS MAS EqS RlS endth) = SSDS .
eq getSubsorts(fmod H is IL sorts SS . SSDS OPDS MAS EqS endfm) = SSDS .
eq getSubsorts(fth H is IL sorts SS . SSDS OPDS MAS EqS endfth) = SSDS .
eq getSubsorts(
omod H is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endom)
= SSDS .
eq getSubsorts(
oth H is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endoth)
= SSDS .
eq getOps(unitError(QIL)) = none .
eq getOps(noModule) = none .
eq getOps(mod H is IL sorts SS . SSDS OPDS MAS EqS RlS endm) = OPDS .
eq getOps(th H is IL sorts SS . SSDS OPDS MAS EqS RlS endth) = OPDS .
eq getOps(fmod H is IL sorts SS . SSDS OPDS MAS EqS endfm) = OPDS .
eq getOps(fth H is IL sorts SS . SSDS OPDS MAS EqS endfth) = OPDS .
eq getOps(omod H is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endom)
= OPDS .
eq getOps(oth H is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endoth)
= OPDS .
eq getMbs(unitError(QIL)) = none .
eq getMbs(mod H is IL sorts SS . SSDS OPDS MAS EqS RlS endm) = MAS .
eq getMbs(th H is IL sorts SS . SSDS OPDS MAS EqS RlS endth) = MAS .
eq getMbs(fmod H is IL sorts SS . SSDS OPDS MAS EqS endfm) = MAS .
eq getMbs(fth H is IL sorts SS . SSDS OPDS MAS EqS endfth) = MAS .
eq getMbs(omod H is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endom)
= MAS .
eq getMbs(oth H is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endoth)
= MAS .
eq getEqs(unitError(QIL)) = none .
eq getEqs(mod H is IL sorts SS . SSDS OPDS MAS EqS RlS endm) = EqS .
eq getEqs(th H is IL sorts SS . SSDS OPDS MAS EqS RlS endth) = EqS .
eq getEqs(fmod H is IL sorts SS . SSDS OPDS MAS EqS endfm) = EqS .
eq getEqs(fth H is IL sorts SS . SSDS OPDS MAS EqS endfth) = EqS .
eq getEqs(omod H is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endom)
= EqS .
eq getEqs(oth H is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endoth)
= EqS .
eq getRls(unitError(QIL)) = none .
eq getRls(mod H is IL sorts SS . SSDS OPDS MAS EqS RlS endm) = RlS .
eq getRls(th H is IL sorts SS . SSDS OPDS MAS EqS RlS endth) = RlS .
eq getRls(fmod H is IL sorts SS . SSDS OPDS MAS EqS endfm) = none .
eq getRls(fth H is IL sorts SS . SSDS OPDS MAS EqS endfth) = none .
eq getRls(omod H is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endom)
= RlS .
eq getRls(oth H is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endoth)
= RlS .
eq getClasses(unitError(QIL)) = none .
eq getClasses(mod H is IL sorts SS . SSDS OPDS MAS EqS RlS endm) = none .
eq getClasses(th H is IL sorts SS . SSDS OPDS MAS EqS RlS endth) = none .
eq getClasses(fmod H is IL sorts SS . SSDS OPDS MAS EqS endfm) = none .
eq getClasses(fth H is IL sorts SS . SSDS OPDS MAS EqS endfth) = none .
eq getClasses(
omod H is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endom)
= CDS .
eq getClasses(
oth H is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endoth)
= CDS .
eq getSubclasses(unitError(QIL)) = none .
eq getSubclasses(mod H is IL sorts SS . SSDS OPDS MAS EqS RlS endm) = none .
eq getSubclasses(th H is IL sorts SS . SSDS OPDS MAS EqS RlS endth) = none .
eq getSubclasses(fmod H is IL sorts SS . SSDS OPDS MAS EqS endfm) = none .
eq getSubclasses(fth H is IL sorts SS . SSDS OPDS MAS EqS endfth) = none .
eq getSubclasses(
omod H is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endom)
= SCDS .
eq getSubclasses(
oth H is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endoth)
= SCDS .
eq getMsgs(unitError(QIL)) = none .
eq getMsgs(mod H is IL sorts SS . SSDS OPDS MAS EqS RlS endm) = none .
eq getMsgs(th H is IL sorts SS . SSDS OPDS MAS EqS RlS endth) = none .
eq getMsgs(fmod H is IL sorts SS . SSDS OPDS MAS EqS endfm) = none .
eq getMsgs(fth H is IL sorts SS . SSDS OPDS MAS EqS endfth) = none .
eq getMsgs(omod H is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endom)
= MDS .
eq getMsgs(oth H is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endoth)
= MDS .
*** Set functions
eq setImports(unitError(QIL), IL) = unitError(QIL) .
eq setImports(noModule, IL) = noModule .
eq setImports(mod H is IL sorts SS . SSDS OPDS MAS EqS RlS endm, IL')
= mod H is IL' sorts SS . SSDS OPDS MAS EqS RlS endm .
eq setImports(th H is IL sorts SS . SSDS OPDS MAS EqS RlS endth, IL')
= th H is IL' sorts SS . SSDS OPDS MAS EqS RlS endth .
eq setImports(fmod H is IL sorts SS . SSDS OPDS MAS EqS endfm, IL')
= fmod H is IL' sorts SS . SSDS OPDS MAS EqS endfm .
eq setImports(fth H is IL sorts SS . SSDS OPDS MAS EqS endfth, IL')
= fth H is IL' sorts SS . SSDS OPDS MAS EqS endfth .
eq setImports(
omod H is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endom, IL')
= omod H is IL' sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endom .
eq setImports(
oth H is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endoth, IL')
= oth H is IL' sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endoth .
eq setOps(unitError(QIL), OPDS) = unitError(QIL) .
eq setOps(noModule, OPDS) = noModule .
eq setOps(U, opDeclError(QIL) OPDS) = unitError(QIL) .
eq setOps(unitError(QIL), opDeclError(QIL') OPDS) = unitError(QIL QIL') .
eq setOps(mod H is IL sorts SS . SSDS OPDS MAS EqS RlS endm, OPDS')
= mod H is IL sorts SS . SSDS OPDS' MAS EqS RlS endm .
eq setOps(th MN is IL sorts SS . SSDS OPDS MAS EqS RlS endth, OPDS')
= th MN is IL sorts SS . SSDS OPDS' MAS EqS RlS endth .
eq setOps(fmod H is IL sorts SS . SSDS OPDS MAS EqS endfm, OPDS')
= fmod H is IL sorts SS . SSDS OPDS' MAS EqS endfm .
eq setOps(fth MN is IL sorts SS . SSDS OPDS MAS EqS endfth, OPDS')
= fth MN is IL sorts SS . SSDS OPDS' MAS EqS endfth .
eq setOps(omod H is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endom,
OPDS')
= omod H is IL sorts SS . SSDS CDS SCDS OPDS' MDS MAS EqS RlS endom .
eq setOps(oth MN is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endoth,
OPDS')
= oth MN is IL sorts SS . SSDS CDS SCDS OPDS' MDS MAS EqS RlS endoth .
eq setSubsorts(unitError(QIL), SSDS) = unitError(QIL) .
eq setSubsorts(mod H is IL sorts SS . SSDS OPDS MAS EqS RlS endm, SSDS')
= mod H is IL sorts SS . SSDS' OPDS MAS EqS RlS endm .
eq setSubsorts(th MN is IL sorts SS . SSDS OPDS MAS EqS RlS endth, SSDS')
= th MN is IL sorts SS . SSDS' OPDS MAS EqS RlS endth .
eq setSubsorts(fmod H is IL sorts SS . SSDS OPDS MAS EqS endfm, SSDS')
= fmod H is IL sorts SS . SSDS' OPDS MAS EqS endfm .
eq setSubsorts(fth MN is IL sorts SS . SSDS OPDS MAS EqS endfth, SSDS')
= fth MN is IL sorts SS . SSDS' OPDS MAS EqS endfth .
eq setSubsorts(
omod H is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endom,
SSDS')
= omod H is IL sorts SS . SSDS' CDS SCDS OPDS MDS MAS EqS RlS endom .
eq setSubsorts(
oth MN is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endoth,
SSDS')
= oth MN is IL sorts SS . SSDS' CDS SCDS OPDS MDS MAS EqS RlS endoth .
eq setMbs(unitError(QIL), membAxError(QIL') MAS) = unitError(QIL QIL') .
eq setMbs(unitError(QIL), MAS) = unitError(QIL) .
eq setMbs(U, membAxError(QIL) MAS) = unitError(QIL) .
eq setMbs(mod H is IL sorts SS . SSDS OPDS MAS EqS RlS endm, MAS')
= mod H is IL sorts SS . SSDS OPDS MAS' EqS RlS endm .
eq setMbs(th MN is IL sorts SS . SSDS OPDS MAS EqS RlS endth, MAS')
= th MN is IL sorts SS . SSDS OPDS MAS' EqS RlS endth .
eq setMbs(fmod H is IL sorts SS . SSDS OPDS MAS EqS endfm, MAS')
= fmod H is IL sorts SS . SSDS OPDS MAS' EqS endfm .
eq setMbs(fth MN is IL sorts SS . SSDS OPDS MAS EqS endfth, MAS')
= fth MN is IL sorts SS . SSDS OPDS MAS' EqS endfth .
eq setMbs(
omod H is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endom, MAS')
= omod H is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS' EqS RlS endom .
eq setMbs(
oth MN is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endoth, MAS')
= oth MN is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS' EqS RlS endoth .
eq setEqs(unitError(QIL), EqS) = unitError(QIL) .
eq setEqs(U, equationError(QIL) EqS?:[EquationSet]) = unitError(QIL) .
eq setEqs(unitError(QIL), equationError(QIL') EqS?:[EquationSet])
= unitError(QIL QIL') .
eq setEqs(mod H is IL sorts SS . SSDS OPDS MAS EqS RlS endm, EqS')
= mod H is IL sorts SS . SSDS OPDS MAS EqS' RlS endm .
eq setEqs(th MN is IL sorts SS . SSDS OPDS MAS EqS RlS endth, EqS')
= th MN is IL sorts SS . SSDS OPDS MAS EqS' RlS endth .
eq setEqs(fmod H is IL sorts SS . SSDS OPDS MAS EqS endfm, EqS')
= fmod H is IL sorts SS . SSDS OPDS MAS EqS' endfm .
eq setEqs(fth MN is IL sorts SS . SSDS OPDS MAS EqS endfth, EqS')
= fth MN is IL sorts SS . SSDS OPDS MAS EqS' endfth .
eq setEqs(
omod H is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endom, EqS')
= omod H is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS' RlS endom .
eq setEqs(
oth MN is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endoth, EqS')
= oth MN is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS' RlS endoth .
var U? : [Module] .
var RlS? : [RuleSet] .
eq setRls(unitError(QIL), RlS?) = unitError(QIL) .
eq setRls(U?, ruleError(QIL) RlS?) = unitError(QIL) .
eq setRls(mod H is IL sorts SS . SSDS OPDS MAS EqS RlS endm, RlS')
= mod H is IL sorts SS . SSDS OPDS MAS EqS RlS' endm .
eq setRls(th MN is IL sorts SS . SSDS OPDS MAS EqS RlS endth, RlS')
= th MN is IL sorts SS . SSDS OPDS MAS EqS RlS' endth .
eq setRls(fmod H is IL sorts SS . SSDS OPDS MAS EqS endfm, RlS)
= if RlS == none
then fmod H is IL sorts SS . SSDS OPDS MAS EqS endfm
else mod H is IL sorts SS . SSDS OPDS MAS EqS RlS endm
fi .
eq setRls(fth MN is IL sorts SS . SSDS OPDS MAS EqS endfth, RlS)
= if RlS == none
then fth MN is IL sorts SS . SSDS OPDS MAS EqS endfth
else th MN is IL sorts SS . SSDS OPDS MAS EqS RlS endth
fi .
eq setRls(omod H is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endom,
RlS')
= omod H is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS' endom .
eq setRls(oth MN is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endoth,
RlS')
= oth MN is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS' endoth .
eq setSorts(unitError(QIL), SS) = unitError(QIL) .
eq setSorts(mod H is IL sorts SS . SSDS OPDS MAS EqS RlS endm, SS')
= mod H is IL sorts SS' . SSDS OPDS MAS EqS RlS endm .
eq setSorts(th MN is IL sorts SS . SSDS OPDS MAS EqS RlS endth, SS')
= th MN is IL sorts SS' . SSDS OPDS MAS EqS RlS endth .
eq setSorts(fmod H is IL sorts SS . SSDS OPDS MAS EqS endfm, SS')
= fmod H is IL sorts SS' . SSDS OPDS MAS EqS endfm .
eq setSorts(fth MN is IL sorts SS . SSDS OPDS MAS EqS endfth, SS')
= fth MN is IL sorts SS' . SSDS OPDS MAS EqS endfth .
eq setSorts(
omod H is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endom, SS')
= omod H is IL sorts SS' . SSDS CDS SCDS OPDS MDS MAS EqS RlS endom .
eq setSorts(
oth MN is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endoth, SS')
= oth MN is IL sorts SS' . SSDS CDS SCDS OPDS MDS MAS EqS RlS endoth .
eq setPars(mod ME is IL sorts SS . SSDS OPDS MAS EqS RlS endm, PDL)
= if PDL == nil
then mod ME is IL sorts SS . SSDS OPDS MAS EqS RlS endm
else mod ME{PDL} is IL sorts SS . SSDS OPDS MAS EqS RlS endm
fi .
eq setPars(mod ME{PDL} is IL sorts SS . SSDS OPDS MAS EqS RlS endm, PDL')
= if PDL' == nil
then mod ME is IL sorts SS . SSDS OPDS MAS EqS RlS endm
else mod ME{PDL'} is IL sorts SS . SSDS OPDS MAS EqS RlS endm
fi .
eq setPars(th MN is IL sorts SS . SSDS OPDS MAS EqS RlS endth, PDL)
= th MN is IL sorts SS . SSDS OPDS MAS EqS RlS endth .
eq setPars(fmod ME is IL sorts SS . SSDS OPDS MAS EqS endfm, PDL)
= if PDL == nil
then fmod ME is IL sorts SS . SSDS OPDS MAS EqS endfm
else fmod ME{PDL} is IL sorts SS . SSDS OPDS MAS EqS endfm
fi .
eq setPars(fmod ME{PDL} is IL sorts SS . SSDS OPDS MAS EqS endfm, PDL')
= if PDL' == nil
then fmod ME is IL sorts SS . SSDS OPDS MAS EqS endfm
else fmod ME{PDL'} is IL sorts SS . SSDS OPDS MAS EqS endfm
fi .
eq setPars(fth MN is IL sorts SS . SSDS OPDS MAS EqS endfth, PDL)
= fth MN is IL sorts SS . SSDS OPDS MAS EqS endfth .
eq setPars(
omod ME is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endom,
PDL)
= if PDL == nil
then omod ME is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endom
else omod ME{PDL} is
IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS
endom
fi .
eq setPars(
omod ME{PDL} is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endom,
PDL')
= if PDL' == nil
then omod ME is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endom
else omod ME{PDL'} is
IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS
endom
fi .
eq setPars(
oth MN is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endoth,
PDL)
= oth MN is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endoth .
eq setClasses(fmod H is IL sorts SS . SSDS OPDS MAS EqS endfm, CDS)
= if CDS == none
then fmod H is IL sorts SS . SSDS OPDS MAS EqS endfm
else omod H is IL sorts SS . SSDS CDS none OPDS none MAS EqS none endom
fi .
eq setClasses(fth H is IL sorts SS . SSDS OPDS MAS EqS endfth, CDS)
= if CDS == none
then fth H is IL sorts SS . SSDS OPDS MAS EqS endfth
else oth H is IL sorts SS . SSDS CDS none OPDS none MAS EqS none endoth
fi .
eq setClasses(mod H is IL sorts SS . SSDS OPDS MAS EqS RlS endm, CDS)
= if CDS == none
then mod H is IL sorts SS . SSDS OPDS MAS EqS RlS endm
else omod H is IL sorts SS . SSDS CDS none OPDS none MAS EqS RlS endom
fi .
eq setClasses(th H is IL sorts SS . SSDS OPDS MAS EqS RlS endth, CDS)
= if CDS == none
then th H is IL sorts SS . SSDS OPDS MAS EqS RlS endth
else oth H is IL sorts SS . SSDS CDS none OPDS none MAS EqS RlS endoth
fi .
eq setClasses(
omod H is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endom,
CDS')
= omod H is IL sorts SS . SSDS CDS' SCDS OPDS MDS MAS EqS RlS endom .
eq setClasses(
oth H is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endoth,
CDS')
= oth H is IL sorts SS . SSDS CDS' SCDS OPDS MDS MAS EqS RlS endoth .
eq setClasses(M, CDS)
= unitError(header2QidList(getName(M)) 'not 'an 'object-oriented 'module)
[owise] .
eq setSubclasses(fmod H is IL sorts SS . SSDS OPDS MAS EqS endfm, SCDS)
= if SCDS == none
then fmod H is IL sorts SS . SSDS OPDS MAS EqS endfm
else omod H is IL sorts SS . SSDS none SCDS OPDS none MAS EqS none endom
fi .
eq setSubclasses(fth H is IL sorts SS . SSDS OPDS MAS EqS endfth, SCDS)
= if SCDS == none
then fth H is IL sorts SS . SSDS OPDS MAS EqS endfth
else oth H is IL sorts SS . SSDS none SCDS OPDS none MAS EqS none endoth
fi .
eq setSubclasses(mod H is IL sorts SS . SSDS OPDS MAS EqS RlS endm, SCDS)
= if SCDS == none
then mod H is IL sorts SS . SSDS OPDS MAS EqS RlS endm
else omod H is IL sorts SS . SSDS none SCDS OPDS none MAS EqS RlS endom
fi .
eq setSubclasses(th H is IL sorts SS . SSDS OPDS MAS EqS RlS endth, SCDS)
= if SCDS == none
then th H is IL sorts SS . SSDS OPDS MAS EqS RlS endth
else oth H is IL sorts SS . SSDS none SCDS OPDS none MAS EqS RlS endoth
fi .
eq setSubclasses(
omod H is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endom, SCDS')
= omod H is IL sorts SS . SSDS CDS SCDS' OPDS MDS MAS EqS RlS endom .
eq setSubclasses(
oth H is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endoth,
SCDS')
= oth H is IL sorts SS . SSDS CDS SCDS' OPDS MDS MAS EqS RlS endoth .
eq setSubclasses(M, SCDS)
= unitError(header2QidList(getName(M)) 'not 'an 'object-oriented 'module)
[owise] .
eq setMsgs(
fmod H is IL sorts SS . SSDS OPDS MAS EqS endfm, MDS)
= if MDS == none
then fmod H is IL sorts SS . SSDS OPDS MAS EqS endfm
else omod H is IL sorts SS . SSDS none none OPDS MDS MAS EqS none endom
fi .
eq setMsgs(
fth H is IL sorts SS . SSDS OPDS MAS EqS endfth, MDS)
= if MDS == none
then fth H is IL sorts SS . SSDS OPDS MAS EqS endfth
else oth H is IL sorts SS . SSDS none none OPDS MDS MAS EqS none endoth
fi .
eq setMsgs(
mod H is IL sorts SS . SSDS OPDS MAS EqS RlS endm, MDS)
= if MDS == none
then mod H is IL sorts SS . SSDS OPDS MAS EqS RlS endm
else omod H is IL sorts SS . SSDS none none OPDS MDS MAS EqS RlS endom
fi .
eq setMsgs(
th H is IL sorts SS . SSDS OPDS MAS EqS RlS endth, MDS)
= if MDS == none
then th H is IL sorts SS . SSDS OPDS MAS EqS RlS endth
else oth H is IL sorts SS . SSDS none none OPDS MDS MAS EqS RlS endoth
fi .
eq setMsgs(
omod H is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endom, MDS')
= omod H is IL sorts SS . SSDS CDS SCDS OPDS MDS' MAS EqS RlS endom .
eq setMsgs(
oth H is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endoth, MDS')
= oth H is IL sorts SS . SSDS CDS SCDS OPDS MDS' MAS EqS RlS endoth .
eq setMsgs(M, MDS)
= unitError(header2QidList(getName(M)) 'not 'an 'object-oriented 'module)
[owise] .
eq setName(mod ME is IL sorts SS . SSDS OPDS MAS EqS RlS endm, ME')
= mod ME' is IL sorts SS . SSDS OPDS MAS EqS RlS endm .
eq setName(mod ME{PDL} is IL sorts SS . SSDS OPDS MAS EqS RlS endm, ME')
= mod ME'{PDL} is IL sorts SS . SSDS OPDS MAS EqS RlS endm .
eq setName(fmod ME is IL sorts SS . SSDS OPDS MAS EqS endfm, ME')
= fmod ME' is IL sorts SS . SSDS OPDS MAS EqS endfm .
eq setName(fmod ME{PDL} is IL sorts SS . SSDS OPDS MAS EqS endfm, ME')
= fmod ME'{PDL} is IL sorts SS . SSDS OPDS MAS EqS endfm .
eq setName(fth MN is IL sorts SS . SSDS OPDS MAS EqS endfth, MN')
= fth MN' is IL sorts SS . SSDS OPDS MAS EqS endfth .
eq setName(th MN is IL sorts SS . SSDS OPDS MAS EqS RlS endth, MN')
= th MN' is IL sorts SS . SSDS OPDS MAS EqS RlS endth .
eq setName(
omod ME is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endom,
ME')
= omod ME' is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endom .
eq setName(
omod ME{PDL} is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endom,
ME')
= omod ME'{PDL} is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endom .
eq setName(
oth MN is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endoth,
MN')
= oth MN' is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endoth .
eq setName(noModule, ME) = noModule .
eq setName(unitError(QIL), ME) = unitError(QIL) .
eq setName(mod nullHeader is IL sorts SS . SSDS OPDS MAS EqS RlS endm, ME')
= mod ME' is IL sorts SS . SSDS OPDS MAS EqS RlS endm .
eq setName(fmod nullHeader is IL sorts SS . SSDS OPDS MAS EqS endfm, ME')
= fmod ME' is IL sorts SS . SSDS OPDS MAS EqS endfm .
eq setName(fth nullHeader is IL sorts SS . SSDS OPDS MAS EqS endfth, MN)
= fth MN is IL sorts SS . SSDS OPDS MAS EqS endfth .
eq setName(th nullHeader is IL sorts SS . SSDS OPDS MAS EqS RlS endth, MN)
= th MN is IL sorts SS . SSDS OPDS MAS EqS RlS endth .
eq setName(
omod nullHeader is
IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS
endom,
ME')
= omod ME' is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endom .
eq setName(
oth nullHeader is
IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endoth,
MN)
= oth MN is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endoth .
eq setName(noModule, ME) = noModule .
eq setName(unitError(QIL), ME) = unitError(QIL) .
*** Add functions
eq addSorts(SS, U) = setSorts(U, (SS ; getSorts(U))) .
eq addSorts(SS, unitError(QIL)) = unitError(QIL) .
eq addSubsorts(SSDS, U) = setSubsorts(U, (SSDS getSubsorts(U))) .
eq addSubsorts(subsortDeclError(QIL), U) = unitError(QIL) .
eq addSubsorts(SSDS, unitError(QIL)) = unitError(QIL) .
eq addOps(OPDS, U) = setOps(U, (OPDS getOps(U))) .
eq addOps(OPDS?, unitError(QIL)) = unitError(QIL) .
eq addOps(OPDS?, U) = U [owise] .
eq addMbs(MAS, U) = setMbs(U, (MAS getMbs(U))) .
eq addMbs(MAS, unitError(QIL)) = unitError(QIL) .
eq addEqs(EqS, U) = setEqs(U, (EqS getEqs(U))) .
eq addEqs(EqS, unitError(QIL)) = unitError(QIL) .
eq addRls(RlS, U) = setRls(U, (RlS getRls(U))) .
eq addRls(RlS, unitError(QIL)) = unitError(QIL) .
eq addRls(ruleError(QIL), U) = unitError(QIL) .
eq addImports(IL, U) = setImports(U, (getImports(U) IL)) .
eq addImports(IL, unitError(QIL)) = unitError(QIL) .
eq addClasses(CDS, U) = setClasses(U, (getClasses(U) CDS)) .
eq addClasses(CDS, unitError(QIL)) = unitError(QIL) .
eq addSubclasses(SCDS, U) = setSubclasses(U, (getSubclasses(U) SCDS)) .
eq addSubclasses(SCDS, unitError(QIL)) = unitError(QIL) .
eq addMsgs(MDS, U) = setMsgs(U, (getMsgs(U) MDS)) .
eq addMsgs(MDS, unitError(QIL)) = unitError(QIL) .
*** Creation of empty units
eq emptyFModule(ME)
= fmod header2Qid(ME) is nil sorts none . none none none none endfm .
eq emptyFModule
= fmod nullHeader is nil sorts none . none none none none endfm .
eq emptySModule
= mod nullHeader is nil sorts none . none none none none none endm .
eq emptyOModule
= omod nullHeader is
nil sorts none . none none none none none none none none
endom .
eq emptyFTheory
= fth nullHeader is nil sorts none . none none none none endfth .
eq emptySTheory
= th nullHeader is nil sorts none . none none none none none endth .
eq emptyOTheory
= oth nullHeader is
nil sorts none . none none none none none none none none
endoth .
*** \texttt{empty} returns an empty unit of the same type of the one given as
*** argument.
eq empty(mod H is IL sorts SS . SSDS OPDS MAS EqS RlS endm)
= (mod H is nil sorts none . none none none none none endm) .
eq empty(th MN is IL sorts SS . SSDS OPDS MAS EqS RlS endth)
= (th MN is nil sorts none . none none none none none endth) .
eq empty(fmod H is IL sorts SS . SSDS OPDS MAS EqS endfm)
= (fmod H is nil sorts none . none none none none endfm) .
eq empty(fth MN is IL sorts SS . SSDS OPDS MAS EqS endfth)
= (fth MN is nil sorts none . none none none none endfth) .
eq empty(omod H is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endom)
= (omod H is
nil sorts none . none none none none none none none none
endom) .
eq empty(oth MN is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endoth)
= (oth MN is
nil sorts none . none none none none none none none none
endoth) .
*** In the following \texttt{addDecls} function, the declarations of the unit
*** given as second argument are added to the unit given as first argument.
eq addDecls(noModule, U) = U .
eq addDecls(U, noModule) = U .
eq addDecls(unitError(QIL), U) = unitError(QIL) .
eq addDecls(U, unitError(QIL)) = unitError(QIL) .
eq addDecls(U, U')
= addImports(getImports(U'),
addSorts(getSorts(U'),
addSubsorts(getSubsorts(U'),
addOps(getOps(U'),
addMbs(getMbs(U'),
addEqs(getEqs(U'),
if U' :: FModule or U' :: FTheory
then U
else addRls(getRls(U'),
if U' :: SModule or U' :: STheory
then U
else addClasses(getClasses(U'),
addSubclasses(getSubclasses(U'),
addMsgs(getMsgs(U'), U)))
fi)
fi))))))
[owise] .
op removeNonExecs : Module -> Module .
op removeNonExecs : MembAxSet -> MembAxSet .
op removeNonExecs : EquationSet -> EquationSet .
op removeNonExecs : RuleSet -> RuleSet .
ceq removeNonExecs(M)
= setRls(M'', removeNonExecs(getRls(M)))
if M' := setMbs(M, removeNonExecs(getMbs(M)))
/\ M'' := setEqs(M', removeNonExecs(getEqs(M))) .
eq removeNonExecs(unitError(QIL)) = unitError(QIL) .
eq removeNonExecs(mb T : S [nonexec AtS] . MbS) = removeNonExecs(MbS) .
eq removeNonExecs(cmb T : S if Cd [nonexec AtS] . MbS) = removeNonExecs(MbS) .
eq removeNonExecs(MbS) = MbS [owise] .
eq removeNonExecs(eq T = T' [nonexec AtS] . EqS) = removeNonExecs(EqS) .
eq removeNonExecs(ceq T = T' if Cd [nonexec AtS] . EqS) = removeNonExecs(EqS) .
eq removeNonExecs(EqS) = EqS [owise] .
eq removeNonExecs(rl T => T' [nonexec AtS] . RlS) = removeNonExecs(RlS) .
eq removeNonExecs(crl T => T' if Cd [nonexec AtS] . RlS) = removeNonExecs(RlS) .
eq removeNonExecs(RlS) = RlS [owise] .
*** moreGeneralEqs ******************************
op moreGeneralEqs : Module -> Module .
op moreGeneralRls : Module -> Module .
op $moreGeneralEqs : Module EquationSet EquationSet -> Module .
op $moreGeneralRls : Module RuleSet RuleSet -> Module .
op $moreGeneral : Module Equation Equation -> Bool .
op $moreGeneral : Module Rule Rule -> Bool .
op $moreGeneral : Module Condition Condition -> Bool .
eq moreGeneralEqs(M) = $moreGeneralEqs(M, getEqs(M), getEqs(M)) .
eq moreGeneralRls(M) = $moreGeneralRls(M, getRls(M), getRls(M)) .
ceq $moreGeneralEqs(M, Eq EqS, Eq Eq' EqS')
= $moreGeneralEqs(M, EqS, Eq' EqS')
if $moreGeneral(M, Eq', Eq) .
eq $moreGeneralEqs(M, EqS, EqS') = setEqs(M, EqS') [owise] .
ceq $moreGeneralRls(M, Rl RlS, Rl Rl' RlS')
= $moreGeneralRls(M, RlS, Rl' RlS')
if $moreGeneral(M, Rl', Rl) .
eq $moreGeneralRls(M, RlS, RlS') = setRls(M, RlS') [owise] .
eq $moreGeneral(M, Eq, Eq')
= metaMatch(M, lhs(Eq), lhs(Eq'), nil, 0) =/= noMatch
and-then
metaMatch(M, rhs(Eq), rhs(Eq'), nil, 0) =/= noMatch
and-then
$moreGeneral(M, cond(Eq), cond(Eq')) .
eq $moreGeneral(M, Rl, Rl')
= metaMatch(M, lhs(Rl), lhs(Rl'), nil, 0) =/= noMatch
and-then
metaMatch(M, rhs(Rl), rhs(Rl'), nil, 0) =/= noMatch
and-then
$moreGeneral(M, cond(Rl), cond(Rl')) .
eq $moreGeneral(M, T1 = T1' /\ Cond1, T2 = T2' /\ Cond2)
= metaMatch(M, T1, T2, nil, 0) =/= noMatch
and-then
metaMatch(M, T1', T2', nil, 0) =/= noMatch
and-then
$moreGeneral(M, Cond1, Cond2) .
eq $moreGeneral(M, T1 := T1' /\ Cond1, T2 := T2' /\ Cond2)
= metaMatch(M, T1, T2, nil, 0) =/= noMatch
and-then
metaMatch(M, T1', T2', nil, 0) =/= noMatch
and-then
$moreGeneral(M, Cond1, Cond2) .
eq $moreGeneral(M, T1 => T1' /\ Cond1, T2 => T2' /\ Cond2)
= metaMatch(M, T1, T2, nil, 0) =/= noMatch
and-then
metaMatch(M, T1', T2', nil, 0) =/= noMatch
and-then
$moreGeneral(M, Cond1, Cond2) .
eq $moreGeneral(M, T1 : S /\ Cond1, T2 : S /\ Cond2)
= metaMatch(M, T1, T2, nil, 0) =/= noMatch
and-then
$moreGeneral(M, Cond1, Cond2) .
eq $moreGeneral(M, nil, nil) = true .
eq $moreGeneral(M, Cond1, Cond2) = false [owise] .
op rmVariantAttrs : Module -> Module .
op $rmVariants : EquationSet -> EquationSet .
op $rmVariants : RuleSet -> RuleSet .
op $rmVariants : MembAxSet -> MembAxSet .
eq rmVariantAttrs(M) = setRls(setEqs(setMbs(M, $rmVariants(getMbs(M))), $rmVariants(getEqs(M))), $rmVariants(getRls(M))) .
eq $rmVariants(eq T = T' [variant AtS] . EqS) = (eq T = T' [metadata("variant") AtS] .) $rmVariants(EqS) .
eq $rmVariants(ceq T = T' if Cond [variant AtS] . EqS) = (ceq T = T' if Cond [metadata("variant") AtS] .) $rmVariants(EqS) .
eq $rmVariants(EqS) = EqS [owise] .
eq $rmVariants(rl T => T' [variant AtS] . RlS) = (rl T => T' [metadata("variant") AtS] .) $rmVariants(RlS) .
eq $rmVariants(crl T => T' if Cond [variant AtS] . RlS) = (crl T => T' if Cond [metadata("variant") AtS] .) $rmVariants(RlS) .
eq $rmVariants(RlS) = RlS [owise] .
eq $rmVariants(mb T : S [variant AtS] . MbS) = (mb T : S [metadata("variant") AtS] .) $rmVariants(MbS) .
eq $rmVariants(cmb T : S if Cond [variant AtS] . MbS) = (cmb T : S if Cond [metadata("variant") AtS] .) $rmVariants(MbS) .
eq $rmVariants(MbS) = MbS [owise] .
endfm
*** To parse some input using the built-in function \texttt{metaParse}, we
*** need to give the metarepresentation of the signature in which the input is
*** going to be parsed.
*** But we do not need to give the complete metarepresentation of such a
*** module. In modules including \texttt{META-LEVEL} it is possible to define
*** terms of sort \texttt{Module} that import built-in modules or any module
*** introduced at the ``object level'' of Core Maude. In this way, it is
*** possible to get the equivalent effect of having the explicit
*** metarepresentation of a module by declaring a constant and adding an
*** equation identifying such a constant with the metarepresentation of an
*** extended module that imports the original module at the object level.
*** The declaration of constructors for bubble sorts at the object level is
*** not supported in the current version of Core Maude. The \texttt{special}
*** attributes linking the constructors for the bubble sorts to the built-in
*** ones are only supported at the metalevel, that is, the declarations of the
*** constructor operators for bubble sorts have to be given in the
*** metarepresentation of a module.
*** To allow the greatest generality and flexibility in future extensions of
*** Full Maude, we have declared its signature as a module
*** \texttt{FULL-MAUDE-SIGN}. Then, in the following module
*** \texttt{META-FULL-MAUDE-SIGN} we declare a constant \texttt{GRAMMAR} of
*** sort \texttt{FModule}, and we give an equation identifying such constant
*** with the metarepresentation of a module \texttt{GRAMMAR} in which there is
*** a declaration importing \texttt{FULL-MAUDE-SIGN}. Declarations for the
*** constructors of the bubble sorts are also included in this module. Note
*** that the bubble sorts \texttt{@Token@}, \texttt{@Bubble@},
*** \texttt{@SortToken@}, and \texttt{@NeTokenList@} are declared in the
*** module \texttt{SIGN\&VIEW-EXPR}, which is imported by
*** \texttt{FULL-MAUDE-SIGN}. These sorts are used in the declarations
*** describing the syntax of the system.
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
fmod META-FULL-MAUDE-SIGN is
including META-LEVEL .
including UNIT .
op BUBBLES : -> FModule .
op GRAMMAR : -> FModule [memo] .
eq BUBBLES
= (fmod 'GRAMMAR is
including 'QID-LIST .
sorts none .
none
op 'token : 'Qid -> '@Token@
[special(
(id-hook('Bubble, '1 '1)
op-hook('qidSymbol, '<Qids>, nil, 'Qid)))] .
op 'viewToken : 'Qid -> '@ViewToken@
[special(
(id-hook('Bubble, '1 '1)
op-hook('qidSymbol, '<Qids>, nil, 'Qid)))] .
op 'sortToken : 'Qid -> '@SortToken@
[special(
(id-hook('Bubble, '1 '1)
op-hook('qidSymbol, '<Qids>, nil, 'Qid)
id-hook('Exclude, '`[ '`] '< 'to '`, '. '`( '`) '`{ '`} ':
'ditto 'precedence 'prec 'gather
'assoc 'associative 'comm 'commutative
'ctor 'constructor 'id: 'strat 'strategy
'poly 'memo 'memoization 'iter 'frozen
'config 'object 'msg 'metadata 'nonexec 'variant)))] .
op 'neTokenList : 'QidList -> '@NeTokenList@
[special(
(id-hook('Bubble, '1 '-1 '`( '`))
op-hook('qidListSymbol, '__, 'QidList 'QidList, 'QidList)
op-hook('qidSymbol, '<Qids>, nil, 'Qid)
id-hook('Exclude, '.)))] .
op 'bubble : 'QidList -> '@Bubble@
[special(
(id-hook('Bubble, '1 '-1 '`( '`))
op-hook('qidListSymbol, '__, 'QidList 'QidList, 'QidList)
op-hook('qidSymbol, '<Qids>, nil, 'Qid)))] .
none
none
endfm) .
eq GRAMMAR = addImports((including 'FULL-MAUDE-SIGN .), BUBBLES) .
endfm
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
*** The \texttt{GRAMMAR} module will be used in calls to the \texttt{metaParse}
*** function in order to get the input parsed in this signature. Note that
*** this module is not the data type in which we shall represent the inputs.
*** From the call to \texttt{metaParse} we shall get a term representing the
*** parse tree of the input. This term will then be transformed into terms of
*** other appropriate data types if necessary.
*** Future extensions to Full Maude will require extending the signature as
*** well. The addition of new commands, new module expressions, or additions
*** of any other kind will require adding new declarations to the present Full
*** Maude signature and defining the corresponding extensions to the data
*** types and functions to deal with the new cases introduced by the
*** extensions.
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
***
*** The Abstract Data Type \texttt{View}
***
*** In this section we present the data type \texttt{View} for views.
*** Basically, the data elements of sort \texttt{View} are composed by the
*** name of the view, the names of the source and target units, and a set of
*** maps representing the maps asserting how the given target unit is claimed
*** to satisfy the source theory (see Section~\ref{Views}).
*** Internally, renaming maps are considered to be a particular case of view
*** maps. The sort \texttt{ViewMap} is declared as a supersort of
*** \texttt{Map}. The only kind of maps in sort \texttt{ViewMap} not in sort
*** \texttt{Map} are maps of operators going to derived operators. We start
*** introducing the declarations for renaming maps and sTS of renaming maps
*** in Section~\ref{renaming-maps}, we then introduce view maps and sTS of
*** view maps in Section~\ref{view-maps}, and finally we introduce the sort
*** \texttt{View}, its constructor, and some operations on it in
*** Section~\ref{viewADT}.
***
*** View Maps
***
*** In addition to the maps of sort \texttt{Renaming},
*** in views there can also be maps from operators to derived
*** operators, that is, terms with variables (see Section~\ref{Views}). Maps
*** of this kind are given with the constructor \texttt{termMap}, which, in
*** addition to the source and target terms, takes the set of variable
*** declarations for the variables used in the map. The source term must be of
*** the form $\texttt{F(X}_1\texttt{,}\ldots,\texttt{X}_n\texttt{)}$, where
*** \texttt{F} is an operator name declared with $n$ arguments of sorts in the
*** connected components of the variables $\texttt{X}_1\ldots\texttt{X}_n$,
*** respectively. We will see in Section~\ref{view-processing} how in the
*** initial processing of a view the variables declared in it are associated
*** to each of the maps in which they are used.
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
fmod VIEW-MAP is
pr FMAP .
pr EXT-DECL .
op termMap : Term Term -> ViewMap .
sorts ViewMap Set{ViewMap} .
subsorts Renaming < ViewMap .
subsorts ViewMap RenamingSet < Set{ViewMap} .
op _`,_ : Set{ViewMap} Set{ViewMap} -> Set{ViewMap} [ditto] .
eq (VMAP, none) = VMAP .
eq (VMAP, VMAP) = VMAP .
var MAP : Renaming .
var VMAP : ViewMap .
var VMAPS : Set{ViewMap} .
vars T T' : Term .
vars S S' : Sort .
*** As for sTS of maps, \texttt{SortRenamingSet} returns the subset of sort
*** maps in a set of view maps.
op sortMaps : Set{ViewMap} -> RenamingSet .
eq sortMaps((sort S to S')) = (sort S to S') .
eq sortMaps(((sort S to S'), VMAPS)) = ((sort S to S'), sortMaps(VMAPS)) .
eq sortMaps(VMAP) = none [owise] .
eq sortMaps((VMAP, VMAPS)) = none [owise] .
eq sortMaps(none) = none .
endfm
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
***
*** Views
***
*** The \texttt{View} sort is introduced in the following module
*** \texttt{VIEW}. In addition to the constructor for views (\texttt{view}),
*** selector functions are added for each of the components of a
*** view (\texttt{name}, \texttt{source}, \texttt{target}, and
*** \texttt{mapSet}), and a constant \texttt{emptyView}, which is identified
*** in an equation with the empty view, is defined.
*** Although the declaration of the constructor for views includes an argument
*** for the list of parameters, parameterized views are not handled yet, so at
*** present this argument must be set to the \texttt{nil}.
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
fmod VIEW is
pr META-MODULE .
pr VIEW-EXPR .
pr VIEW-MAP .
sorts ViewHeader . ---- View .
subsort ViewExp Header < ViewHeader .
op view_from_to_is_endv :
ViewHeader ModuleExpression ModuleExpression Set{ViewMap} -> View
[ctor format (nir! o r! o r! o r! o r! o)] .
op null : -> View [ctor] .
op viewError : QidList -> [View] [ctor format (r o)] .
eq VE{(nil).ParameterDeclList} = VE .
var QI : Qid .
vars VE VE' : ViewExp .
vars PDL PDL' : ParameterDeclList .
vars ME ME' ME'' : ModuleExpression .
vars VMAPS VMAPS' : Set{ViewMap} .
var QIL : QidList .
var VH : ViewHeader .
op name : View -> ViewExp .
op getPars : [View] -> ParameterDeclList .
op source : View -> ModuleExpression .
op target : View -> ModuleExpression .
op mapSet : View -> RenamingSet .
eq name(view VE from ME to ME' is VMAPS endv) = VE .
eq name(view VE{PDL} from ME to ME' is VMAPS endv) = VE .
eq getPars(view VE from ME to ME' is VMAPS endv) = nil .
eq getPars(view VE{PDL} from ME to ME' is VMAPS endv) = PDL .
eq getPars(viewError(QIL)) = nil .
eq source(view VH from ME to ME' is VMAPS endv) = ME .
eq target(view VH from ME to ME' is VMAPS endv) = ME' .
eq mapSet(view VH from ME to ME' is VMAPS endv) = VMAPS .
op setName : View ViewExp ~> View .
op setPars : View ParameterDeclList ~> View .
op setTarget : View ModuleExpression ~> View .
op sTSource : View ModuleExpression ~> View .
op setMaps : View RenamingSet ~> View .
eq setName(view VE from ME to ME' is VMAPS endv, VE')
= view VE' from ME to ME' is VMAPS endv .
eq setName(view VE{PDL} from ME to ME' is VMAPS endv, VE')
= view VE'{PDL} from ME to ME' is VMAPS endv .
eq setName(viewError(QIL), VE) = viewError(QIL) .
eq setPars(view VE from ME to ME' is VMAPS endv, PDL)
= view VE{PDL} from ME to ME' is VMAPS endv .
eq setPars(view VE{PDL} from ME to ME' is VMAPS endv, PDL')
= view VE{PDL'} from ME to ME' is VMAPS endv .
eq setPars(viewError(QIL), PDL) = viewError(QIL) .
eq sTSource(view VH from ME to ME' is VMAPS endv, ME'')
= view VH from ME'' to ME' is VMAPS endv .
eq sTSource(viewError(QIL), ME) = viewError(QIL) .
eq setTarget(view VH from ME to ME' is VMAPS endv, ME'')
= view VH from ME to ME'' is VMAPS endv .
eq setTarget(viewError(QIL), ME) = viewError(QIL) .
eq setMaps(view VH from ME to ME' is VMAPS endv, VMAPS')
= view VH from ME to ME' is VMAPS' endv .
eq setMaps(viewError(QIL), VMAPS) = viewError(QIL) .
op emptyView : Qid ModuleExpression ModuleExpression -> View .
eq emptyView(QI, ME, ME') = view QI from ME to ME' is none endv .
endfm
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
***
*** The Abstract Data Type \texttt{Database}
***
*** In this section we present the data type \texttt{Database}, which will be
*** used to store information about the units and views in the system. Before
*** discussing this data type in Section~\ref{databaseADT}, we present the
*** predefined units added in Full Maude to those already available in Core
*** Maude.
***
*** Non-Built-In Predefined Modules
***
*** As we shall see in the following section, except for the
*** \texttt{LOOP-MODE} module, all the predefined modules that are available
*** in Core Maude are also available in Full Maude. In addition to these Core
*** Maude predefined modules, in Full Maude there are some additional
*** predefined units. In the present system, the only units with which the
*** database is initialized are the functional theory \texttt{TRIV}, the
*** module \texttt{CONFIGURATION}, and the module \texttt{UP}, which will be
*** used to evaluate the \texttt{up} functions. We shall see in
*** Section~\ref{main-module} how new predefined modules can be added to the
*** initial database.
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
fmod PREDEF-UNITS is
pr UNIT .
*** The following module \texttt{UP} contains the necessary declarations to
*** be able to parse the \texttt{up} functions presented in
*** Section~\ref{structured-specifications}. We shall see in
*** Section~\ref{evaluation} how a declaration importing the following module
*** \texttt{UP} is added to all the modules importing the predefined module
*** \texttt{META-LEVEL}. With this declaration, it is possible to parse the
*** \texttt{up} commands in the bubbles of such modules or in commands being
*** evaluated in such modules. We shall see in Section~\ref{bubble-parsing}
*** how these commands are then evaluated.
op #UP# : -> FModule [memo] .
eq #UP#
= (fmod '#UP# is
including 'QID-LIST .
including 'MOD-EXPRS .
sorts none .
none
op 'upTerm : '@ModExp@ '@Bubble@ -> 'Term [none] .
op 'upModule : '@ModExp@ -> 'Module [none] .
op '`[_`] : '@Token@ -> 'Module [none] .
op 'token : 'Qid -> '@Token@
[special(
(id-hook('Bubble, '1 '1)
op-hook('qidSymbol, '<Qids>, nil, 'Qid)))] .
op 'viewToken : 'Qid -> '@ViewToken@
[special(
(id-hook('Bubble, '1 '1)
op-hook('qidSymbol, '<Qids>, nil, 'Qid)))] .
op 'sortToken : 'Qid -> '@SortToken@
[special(
(id-hook('Bubble, '1 '1)
op-hook('qidSymbol, '<Qids>, nil, 'Qid)
id-hook('Exclude, '`[ '`] '< 'to '`, '. '`( '`) '`{ '`} ':
'ditto 'precedence 'prec 'gather
'assoc 'associative 'comm 'commutative
'ctor 'constructor 'id: 'strat 'strategy
'poly 'memo 'memoization 'iter 'frozen
'config 'object 'msg 'metadata 'nonexec 'variant)))] .
op 'neTokenList : 'QidList -> '@NeTokenList@
[special(
(id-hook('Bubble, '1 '-1 '`( '`))
op-hook('qidListSymbol, '__, 'QidList 'QidList, 'QidList)
op-hook('qidSymbol, '<Qids>, nil, 'Qid)
id-hook('Exclude, '.)))] .
op 'bubble : 'QidList -> '@Bubble@
[special(
(id-hook('Bubble, '1 '-1 '`( '`))
op-hook('qidListSymbol, '__, 'QidList 'QidList, 'QidList)
op-hook('qidSymbol, '<Qids>, nil, 'Qid)))] .
none
none
endfm) .
endfm
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
***
*** 7 The Evaluation of Views
***
*** Before being entered into the database, besides containing bubbles, views
*** have a somewhat different structure from that of the views given in
*** Section~\ref{viewADT}. We introduce in the following module a sort
*** \texttt{PreView} with constructor \texttt{view}, which is declared as the
*** constructor for views of sort \texttt{View}, but with an additional
*** argument, namely, a set of variable declarations to hold the declarations
*** of variables in the view. During the processing of views (see
*** Section~\ref{view-processing}), which takes place once the parsing process
*** has concluded, these variables are associated with the corresponding maps
*** where they are used, generating a term of sort \texttt{View}.
*** We start by introducing in the following module \texttt{PRE-VIEW-MAP} the
*** sorts \texttt{TermPreMap}, \texttt{PreViewMap}, and
*** \texttt{Set{PreViewMap}}. A preview map is a view map with bubbles. Note
*** that the bubbles can only appear in term maps. Elements of sort
*** \texttt{TermPreMap} are built with the constructor \texttt{preTermMap},
*** which takes two terms of sort \texttt{Term}, that is, two bubbles. In the
*** processing of views (see Section~\ref{view-processing}), elements of sort
*** \texttt{PreTermMap} will be converted into elements of sort
*** \texttt{TermMap} by parsing the bubbles in them, and by associating to
*** them the variables in them defined in the view in which the maps appear.
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
fmod PRE-VIEW-MAP is
pr VIEW-MAP .
sort PreViewMap .
subsorts Renaming < PreViewMap .
op preTermMap : Term Term -> PreViewMap .
sort Set{PreViewMap} .
subsorts PreViewMap RenamingSet < Set{PreViewMap} .
op _`,_ : Set{PreViewMap} Set{PreViewMap} -> Set{PreViewMap} [ditto] .
eq (PVMAPS, none) = PVMAPS .
var PVMAP : PreViewMap .
var PVMAPS : Set{PreViewMap} .
vars S S' : Sort .
*** Given a set of maps, the function \texttt{sortMaps} returns the subset
*** of sort maps in it.
op sortMaps : Set{PreViewMap} -> RenamingSet .
eq sortMaps(((sort S to S'), PVMAPS)) = ((sort S to S'), sortMaps(PVMAPS)) .
eq sortMaps((PVMAP, PVMAPS)) = none [owise] .
eq sortMaps(none) = none .
endfm
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
fmod PRE-VIEW is
pr VIEW .
pr PRE-VIEW-MAP .
sort PreView .
op preview_from_to_is__endpv : ViewHeader ModuleExpression
ModuleExpression OpDeclSet Set{PreViewMap} -> PreView
[ctor format (nir! o r! o r! o r! o o r! o)] .
op null : -> PreView .
op name : PreView -> ViewExp .
op getPars : PreView -> ParameterDeclList .
op source : PreView -> ModuleExpression .
op target : PreView -> ModuleExpression .
op vars : PreView -> OpDeclSet .
op mapSet : PreView -> Set{PreViewMap} .
var QI : Qid .
vars ME ME' : ModuleExpression .
var VE : ViewExp .
var VH : ViewHeader .
vars PDL PDL' : ParameterDeclList .
vars VDS VDS' : OpDeclSet .
vars PVMAPS PVMAPS' : Set{PreViewMap} .
eq name(preview VE from ME to ME' is VDS PVMAPS endpv) = VE .
eq name(preview VE{PDL} from ME to ME' is VDS PVMAPS endpv) = VE .
eq getPars(preview VE from ME to ME' is VDS PVMAPS endpv) = nil .
eq getPars(preview VE{PDL} from ME to ME' is VDS PVMAPS endpv) = PDL .
eq source(preview VH from ME to ME' is VDS PVMAPS endpv) = ME .
eq target(preview VH from ME to ME' is VDS PVMAPS endpv) = ME' .
eq vars(preview VH from ME to ME' is VDS PVMAPS endpv) = VDS .
eq mapSet(preview VH from ME to ME' is VDS PVMAPS endpv) = PVMAPS .
*** The following functions can be used to add new declarations to the set of
*** declarations already in a preview.
op addMaps : Set{PreViewMap} PreView -> PreView .
op addVars : OpDeclSet PreView -> PreView .
eq addMaps(PVMAPS, preview VH from ME to ME' is VDS PVMAPS' endpv)
= preview VH from ME to ME' is VDS (PVMAPS, PVMAPS') endpv .
eq addVars(VDS, preview VH from ME to ME' is VDS' PVMAPS' endpv)
= preview VH from ME to ME' is (VDS VDS') PVMAPS' endpv .
op setPars : PreView ParameterDeclList -> PreView .
eq setPars(preview VE from ME to ME' is VDS PVMAPS endpv, PDL)
= preview VE{PDL} from ME to ME' is VDS PVMAPS endpv .
eq setPars(preview VE{PDL} from ME to ME' is VDS PVMAPS endpv, PDL')
= preview VE{PDL'} from ME to ME' is VDS PVMAPS endpv .
op emptyPreView : Qid ModuleExpression ModuleExpression -> PreView .
eq emptyPreView(QI, ME, ME')
= preview QI from ME to ME' is none none endpv .
endfm
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
***
*** The Database
***
*** In order to be able to refer to modules by name, which is extremely useful
*** for module definition purposes at the user level, the evaluation of module
*** expressions takes place in the context of a database, in which we keep
*** information about the modules already introduced in the system, and also
*** about those modules generated internally. This information is stored as
*** a set of elements of sort \texttt{ModuleInfo} and \texttt{ViewInfo}, in
*** which we hold, respectively, the information concerning units and views.
*** For each unit we save:
*** \begin{itemize}
*** \item Its original form, as introduced by the user, or, in case of an
*** internally generated unit, as generated from the original form of
*** some other unit.
*** \item Its internal representation, in which variables have been renamed
*** to avoid collisions with the names of variables in other units in
*** the same hierarchy. In the case of object-oriented units, we store
*** its equivalent system module, that is, the result of transforming
*** it into a system module.
*** \item Its signature, which is given as a functional module of sort
*** \texttt{FModule} with no axioms, ready to be used in calls to
*** \texttt{metaParse}. There can only be importation declarations
*** including built-in modules in this module. These are the only
*** inclusions handled by the Core Maude engine.
*** \item Its flattened version, for which, as for signatures, only the
*** importation of built-in modules is left unevaluated.
*** \end{itemize}
*** For each view we keep its name and the view itself.
*** As a simple mechanism to keep the database consistent, for each unit we
*** maintain the list of names of all the units and views ``depending'' on it.
*** Similarly, for each view we maintain the list of names of all the units
*** ``depending'' on it. The idea is that if a unit or view is redefined or
*** removed, all those units and/or views depending on it will also be
*** removed. This dependency does not only mean direct importation. For
*** example, the module resulting from the renaming of some module also
*** depends on the module being renamed; the instantiation of a parameterized
*** module also depends on the parameterized module and on all the views used
*** in its instantiation; a view depends on its source and target units, etc.
*** This dependency is transitive: if a module, theory, or view has to be
*** removed, all the units and/or views depending on them will be removed as
*** well. The dependencies derived from the module expressions themselves are
*** established by the function \texttt{setUpModExpDeps}. The function
*** \texttt{setUpModuleDeps} calls \texttt{setUpModExpDeps},
*** and then \texttt{setUpImportSetDeps} to add the \emph{back
*** references} in the modules being imported. The function
*** \texttt{setUpViewDeps} sTS up the back references for the views
*** being introduced.
*** In addition to this set of information cells for units and views, we also
*** keep lists with the names of all the units and views in the database, and
*** a list of quoted identifiers in which we store the messages generated
*** during the process of treatment of the inputs in order to simplify the
*** communication with the read-eval-print loop process.
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
view ModuleName from TRIV to MOD-NAME is
sort Elt to ModuleName .
endv
view ViewExp from TRIV to VIEW-EXPR is
sort Elt to ViewExp .
endv
view ParameterDecl from TRIV to META-MODULE is
sort Elt to ParameterDecl .
endv
fmod INFO is
pr VIEW .
pr DEFAULT-VALUE{Term} .
pr (SET * (op _`,_ to _._,
op empty to emptyModuleNameSet,
op insert to insertModuleNameSet,
op delete to deleteModuleNameSet,
op _in_ to _inModuleNameSet_,
op |_| to |_|ModuleNameSet,
op $card to $cardModuleNameSet,
op union to unionModuleNameSet,
op intersection to intersectionModuleNameSet,
op $intersect to $intersectModuleNameSet,
op _\_ to _\ModuleNameSet_,
op $diff to $diffModuleNameSet,
op _subset_ to _subsetModuleNameSet_,
op _psubset_ to _psubsetModuleNameSet_)){ModuleName} .
pr (SET * (op _`,_ to _#_,
op empty to emptyViewExpSet,
op insert to insertViewExpSet,
op delete to deleteViewExpSet,
op _in_ to _inViewExpSet_,
op |_| to |_|ViewExprSet,
op $card to $cardViewExprSet,
op union to unionViewExprSet,
op intersection to intersectionViewExprSet,
op $intersect to $intersectViewExprSet,
op _\_ to _\ViewExprSet_,
op $diff to $diffViewExprSet,
op _subset_ to _subsetViewExprSet_,
op _psubset_ to _psubsetViewExprSet_)){ViewExp} .
pr (SET * (op _`,_ to _._)){ParameterDecl} .
var MN : ModuleName .
var MNS : Set{ModuleName} .
op remove : Set{ModuleName} ModuleName -> Set{ModuleName} .
eq remove(MN . MNS, MN) = remove(MNS, MN) .
eq remove(MNS, MN) = MNS [owise] .
sort ModuleInfo .
op <_;_;_;_;_;_;_;_> : ModuleName Default{Term} Module Module Module
OpDeclSet Set{ModuleName} Set{ViewExp} -> ModuleInfo
[ctor
format
(nig o g n+++io g nio g nio g nio g nio g nio g nio n---ig o)] .
op <_;_;_;_;_;_;_;_> : ModuleName Module Module Module Module
OpDeclSet Set{ModuleName} Set{ViewExp} -> ModuleInfo
[ctor
format
(nig ur! g n+++io g nio g nio g nio g nio g nio g nio n---ig o)] .
*** - Modules can be introduced by the user or can be generated internally.
*** When introduced by the user the 2nd arg. keeps the term representation
*** of the module as given, so that it can be recompiled later. If the
*** module is generated internally as the result of the evaluation of a
*** module expression, then this second arg. will be null, the default
*** term value. The user can also enter modules with the procModule
*** function, providing then the metarepresentation of a module, which
*** is directly stored in the database as the 2nd arg. of one of these
*** ModuleInfo units of the second kind. This is useful for the ITP for
*** example, where the interaction with the database takes place at the
*** metalevel and the modules given by the "user" are already at the
*** metalevel but still wants the same treatment.
*** - The sixth arg. stores the variables (corresponding ops.) in the top
*** module.
sort ViewInfo .
op <_;_;_;_;_> : ViewExp Default{Term} View Set{ModuleName}
Set{ViewExp} -> ViewInfo
[ctor format (nig o g n+++io g nio g nio g nio n---ig o)] .
op <_;_;_;_;_> :
ViewExp View View Set{ModuleName} Set{ViewExp} -> ViewInfo
[ctor format (nig o g n+++io g nio g nio g nio n---ig o)] .
endfm
view ModuleInfo from TRIV to INFO is
sort Elt to ModuleInfo .
endv
view ViewInfo from TRIV to INFO is
sort Elt to ViewInfo .
endv
fmod DATABASE-DECLS is
pr (SET * (op _`,_ to __, op empty to emptyInfoSet)){ModuleInfo} .
pr (SET * (op _`,_ to __, op empty to emptyInfoSet)){ViewInfo} .
sort Database .
op db :
Set{ModuleInfo} *** module info tuples
Set{ModuleName} *** names of the modules in the database
Set{ViewInfo} *** view info tuples
Set{ViewExp} *** names of the views in the db
Set{ModuleName} *** modules with set protect on (by default empty)
Set{ModuleName} *** modules with set extend on (by default empty)
Set{ModuleName} *** modules with set include on (by default empty)
QidList
-> Database
[ctor
format (nib i++o)] .
ops getDefPrs getDefExs getDefIncs : Database -> Set{ModuleName} .
eq getDefPrs(
db(MIS:Set{ModuleInfo}, MNS:Set{ModuleName}, VIS:Set{ViewInfo},
VES:Set{ViewExp}, MNS':Set{ModuleName}, MNS'':Set{ModuleName},
MNS3:Set{ModuleName}, QIL:QidList))
= MNS':Set{ModuleName} .
eq getDefExs(
db(MIS:Set{ModuleInfo}, MNS:Set{ModuleName}, VIS:Set{ViewInfo},
VES:Set{ViewExp}, MNS':Set{ModuleName}, MNS'':Set{ModuleName},
MNS3:Set{ModuleName}, QIL:QidList))
= MNS'':Set{ModuleName} .
eq getDefIncs(
db(MIS:Set{ModuleInfo}, MNS:Set{ModuleName}, VIS:Set{ViewInfo},
VES:Set{ViewExp}, MNS':Set{ModuleName}, MNS'':Set{ModuleName},
MNS3:Set{ModuleName}, QIL:QidList))
= MNS3:Set{ModuleName} .
endfm
view Database from TRIV to DATABASE-DECLS is
sort Elt to Database .
endv
view ModuleExpression from TRIV to META-MODULE is
sort Elt to ModuleExpression .
endv
fmod DATABASE is
pr (2TUPLE * (op `(_`,_`) to <_;_>,
op p1_ to database,
op p2_ to modExp)) {Database, ModuleExpression} .
pr PRE-VIEW .
pr UNIT .
pr VIEW-EXPR-TO-QID .
op evalModule : Module OpDeclSet Database -> Database .
*** its definition is in the module EVALUATION
op procModule : Qid Database -> Database .
op procView : Qid Database -> Database .
*** their definitions are in the modules UNIT-PROCESSING and VIEW-PROCESSING
op evalModExp : ModuleExpression Database -> Tuple{Database, ModuleExpression} .
*** its definition is in the module MOD-EXPR-EVAL
vars QI X Y F : Qid .
vars QIL QIL' : QidList .
vars NQIL NQIL' : NeQidList .
vars VE VE' VE'' : ViewExp .
vars VES VES' VES'' VES3 : Set{ViewExp} .
vars MIS MIS' : Set{ModuleInfo} .
var VIS : Set{ViewInfo} .
vars MNS MNS' MNS'' MNS3 MNS4 MNS5 MNS6 : Set{ModuleName} .
vars PL PL' : ParameterList .
vars PDS PDS' PDS'' : Set{ParameterDecl} .
var PDL : ParameterDeclList .
var PD : ParameterDecl .
vars ME ME' : ModuleExpression .
vars VI VI' : View .
var VMAPS : Set{ViewMap} .
var PVMAPS : Set{PreViewMap} .
vars PU PU' U U' U'' U3 U4 : Module .
var M : Module .
var DB : Database .
vars IL IL' : ImportList .
var VIf : ViewInfo .
var UIf : ModuleInfo .
vars OPDS VDS VDS' : OpDeclSet .
var PV : PreView .
vars T T' : Term .
var DT : Default{Term} .
var NL : IntList .
var TyL : TypeList .
var Ty : Type .
var AtS : AttrSet .
var B : Bool .
var I : Import .
var MN MN' : ModuleName .
ops dincluded : ModuleExpression ImportList -> Bool .
eq dincluded(ME, IL (protecting ME .) IL') = true .
eq dincluded(ME, IL (extending ME .) IL') = true .
eq dincluded(ME, IL (including ME .) IL') = true .
eq dincluded(ME, IL) = false [owise] .
ops included includedAux : ModuleExpression ImportList Database -> Bool .
eq included(ME, IL (protecting ME .) IL', DB) = true .
eq included(ME, IL (extending ME .) IL', DB) = true .
eq included(ME, IL (including ME .) IL', DB) = true .
eq included(ME, nil, DB) = false .
eq included(ME, IL, DB) = includedAux(ME, IL, DB) [owise] .
eq includedAux(ME, I IL, DB)
= included(ME, getImports(getTopModule(moduleName(I), DB)), DB)
or-else includedAux(ME, IL, DB) .
eq includedAux(ME, nil, DB) = false .
op defImports : Module Database -> ImportList .
op defImports : ImportList ImportList Set{ModuleName} Set{ModuleName}
Set{ModuleName} -> ImportList .
eq defImports(M, DB)
= if theory(M)
then nil
else defImports(getImports(M), nil,
getDefPrs(DB), getDefExs(DB), getDefIncs(DB))
fi .
eq defImports(IL, IL', MN . MNS, MNS', MNS'')
= if dincluded(MN, IL IL')
then defImports(IL, IL', MNS, MNS', MNS'')
else defImports(IL, IL' (protecting MN .), MNS, MNS', MNS'')
fi .
eq defImports(IL, IL', MNS, MN . MNS', MNS'')
= if dincluded(MN, IL IL')
then defImports(IL, IL', MNS, MNS', MNS'')
else defImports(IL, IL' (extending MN .), MNS, MNS', MNS'')
fi .
eq defImports(IL, IL', MNS, MNS', MN . MNS'')
= if dincluded(MN, IL IL')
then defImports(IL, IL', MNS, MNS', MNS'')
else defImports(IL, IL' (including MN .), MNS, MNS', MNS'')
fi .
eq defImports(IL, IL',
emptyModuleNameSet, emptyModuleNameSet, emptyModuleNameSet)
= IL' .
*** The constant \texttt{emptyDatabase} denotes the empty database, and there
*** are predicates \texttt{viewInDatabase} and \texttt{unitInDb} to check,
*** respectively, whether a view and a unit are in a database or not.
op emptyDatabase : -> Database .
eq emptyDatabase
= db(emptyInfoSet, emptyModuleNameSet, emptyInfoSet, emptyViewExpSet,
emptyModuleNameSet, emptyModuleNameSet, 'BOOL, nil) .
op unitInDb : ModuleName Database -> Bool .
eq unitInDb(MN, db(MIS, MNS, VIS, VES, MNS', MNS'', MNS3, QIL))
= MN inModuleNameSet MNS .
op viewInDb : ViewExp Database -> Bool .
eq viewInDb(VE, db(MIS, MNS, VIS, VES, MNS', MNS'', MNS3, QIL))
= VE inViewExpSet VES .
op includeBOOL : Database -> Bool .
eq includeBOOL(db(MIS, MNS, VIS, VES, MNS', MNS'', MNS3, QIL))
= 'BOOL inModuleNameSet MNS' .
*** If a module, theory, or view is being redefined, that is, if there was
*** already in the database a module, theory, or view with the same name,
*** then all the units and/or views depending on it are removed using the
*** functions \texttt{delModules} and \texttt{delViews}. Removing a view
*** or a unit from the database means removing its info cell from the set of
*** cells in the database. Those entered by the user are not completely
*** removed, their term form is saved so that it can be recompiled later.
op delModules : Set{ModuleName} Database -> Database .
op delViews : Set{ViewExp} Database -> Database .
eq delModules((MN . MNS),
db(< MN ; T ; U ; U' ; U'' ; VDS ; MNS' ; VES > MIS,
MN . MNS'', VIS, VES', MNS3, MNS4, MNS5, QIL))
= delModules((MNS . MNS'),
delViews(VES,
db(< MN ; T ; noModule ; noModule ; noModule ; VDS ;
emptyModuleNameSet ; emptyViewExpSet > MIS,
MN . MNS'', VIS, VES', MNS3, MNS4, MNS5, QIL))) .
eq delModules((MN . MNS),
db(< MN ; U ; U' ; U'' ; U3 ; VDS ; MNS' ; VES > MIS,
MN . MNS'', VIS, VES', MNS3, MNS4, MNS5, QIL))
= delModules((MNS . MNS'),
delViews(VES,
db(< MN ; U ; noModule ; noModule ; noModule ; VDS ;
emptyModuleNameSet ; emptyViewExpSet > MIS,
MN . MNS'', VIS, VES', MNS3, MNS4, MNS5, QIL))) .
eq delModules((MN . MNS),
db(< MN ; null ; U ; U' ; U'' ; VDS ; MNS' ; VES > MIS,
MN . MNS'', VIS, VES', MNS3, MNS4, MNS5, QIL))
= delModules((MNS . MNS'),
delViews(VES,
db(MIS, MNS'', VIS, VES', MNS3, MNS4, MNS5, QIL))) .
eq delModules(emptyModuleNameSet, DB) = DB .
eq delModules((MN . MNS), DB) = delModules(MNS, DB) [owise] .
eq delViews(VE # VES,
db(MIS, MNS, < VE ; T ; VI ; MNS' ; VES' > VIS, VE # VES'',
MNS'', MNS3, MNS4, QIL))
= delViews(VES # VES',
delModules(MNS',
db(MIS, MNS,
< VE ; T ; null ; emptyModuleNameSet ; emptyViewExpSet > VIS,
VE # VES'', MNS'', MNS3, MNS4, QIL))) .
eq delViews(VE # VES,
db(MIS, MNS,
< VE ; (null).Default{Term} ; VI ; MNS' ; VES' > VIS, VE # VES'',
MNS'', MNS3, MNS4, QIL))
= delViews(VES # VES',
delModules(MNS',
db(MIS, MNS, VIS, VES'', MNS'', MNS3, MNS4, QIL))) .
eq delViews(VE # VES,
db(MIS, MNS, < VE ; VI ; VI' ; MNS' ; VES' > VIS, VE # VES'',
MNS'', MNS3, MNS4, QIL))
= delViews(VES # VES',
delModules(MNS',
db(MIS, MNS,
< VE ; VI ; null ; emptyModuleNameSet ; emptyViewExpSet > VIS,
VE # VES'', MNS'', MNS3, MNS4, QIL))) .
eq delViews(emptyViewExpSet, DB) = DB .
eq delViews(VE # VES, DB) = delViews(VES, DB) [owise] .
*** The \texttt{warning} function allows us to place messages (warning, error,
*** or any other kind of messages) in the last argument of the database
*** constructor. These messages are given in the form of quoted identifier
*** lists, and will be passed to the third argument of the read-eval-print
*** loop, to be printed in the terminal.
op warning : Database QidList -> Database .
eq warning(db(MIS, MNS, VIS, VES, MNS', MNS'', MNS3, nil), QIL)
= db(MIS, MNS, VIS, VES, MNS', MNS'', MNS3, QIL) .
eq warning(db(MIS, MNS, VIS, VES, MNS', MNS'', MNS3, NQIL), QIL)
= db(MIS, MNS, VIS, VES, MNS', MNS'', MNS3, NQIL QIL) .
op getMsg : Database -> QidList .
eq getMsg(db(MIS, MNS, VIS, VES, MNS', MNS'', MNS3, QIL)) = QIL .
*** Core Maude built-in modules are handled in a special way in the current
*** version of the system. They are not explicitly defined in the Full Maude
*** database; their importation is directly handled by Core Maude. This has
*** some drawbacks: Core Maude built-in modules cannot be renamed; they cannot
*** be directly used with built-in functions, such as \texttt{metaReduce} or
*** \texttt{sameComponent}, although they can be imported in modules being
*** used in the calls to these functions; and, in general, any function taking
*** as argument or returning as result the metarepresentation of a module
*** cannot take one of these built-in modules as argument. This is the case,
*** for example, for the \texttt{up} function presented in
*** Section~\ref{changing-levels}, or for functions or commands in which the
*** name of a module has to be specified, as the \texttt{select} or
*** \texttt{down} commands, or the \texttt{up} function presented in
*** Section~\ref{structured-specifications}. Nevertheless, there are also
*** some advantages: The flattening of the built-in part of the structure is
*** accomplished more efficiently, and, since these modules do not have to be
*** stored in the database of Full Maude, the size of the database is reduced.
*** Our plan is to have in the future a hybrid solution. Once we have some way
*** of storing the modules entered to Full Maude in Core Maude's database, it
*** will be enough to keep in the Full Maude database just the original form
*** of the top of all the modules, including built-ins, leaving all the
*** importation declarations to be resolved by the engine. The structures will
*** be normalized as they are now, so that the engine will have to deal just
*** with inclusions, but it will be possible to use the predefined modules as
*** any other module. Moreover, the Full Maude database will be relatively
*** smaller and the flattening will be computed more efficiently.
*** When a new module or theory is entered, the names of all the modules,
*** theories, and views depending on it are included in its lists of
*** dependencies with functions \texttt{setUpModuleDeps} and
*** \texttt{setUpViewDeps}. Notice that if new module expressions are
*** defined, the function \texttt{setUpModExpDeps} will have to be
*** extended accordingly.
op setUpModuleDeps : Module Database -> Database .
op setUpModExpDeps : ModuleName Database -> Database .
op setUpModExpDeps : ModuleName Header Database -> Database .
op setUpModExpDeps : ModuleName ViewExp Database -> Database .
op setUpImportDeps : ModuleName ImportList Database -> Database .
eq setUpModuleDeps(U, DB)
= setUpImportDeps(getName(U), getImports(U),
setUpModExpDeps(getName(U), DB)) .
eq setUpModExpDeps(QI, DB) = DB .
eq setUpModExpDeps(pd(X :: ME),
db(< ME ; DT ; U ; U' ; U'' ; VDS ; MNS ; VES > MIS,
MNS', VIS, VES', MNS'', MNS3, MNS4, QIL))
= db(< ME ; DT ; U ; U' ; U'' ; VDS ; (MNS . pd(X :: ME)) ; VES > MIS,
MNS', VIS, VES', MNS'', MNS3, MNS4, QIL) .
eq setUpModExpDeps(pd(X :: ME),
db(< ME ; U ; U' ; U'' ; U3 ; VDS ; MNS ; VES > MIS,
MNS', VIS, VES', MNS'', MNS3, MNS4, QIL))
= db(< ME ; U ; U' ; U'' ; U3 ; VDS ; (MNS . pd(X :: ME)) ; VES > MIS,
MNS', VIS, VES', MNS'', MNS3, MNS4, QIL) .
eq setUpModExpDeps(pd(X :: ME), DB)
= warning(DB, ('\r 'Error: '\o 'Module header2QidList(ME) 'not 'in 'database. '\n))
[owise] .
---- This could be a bug in Core Maude.
---- It should work if the next 6 equations are replaced by this single equation.
---- ceq setUpImportDeps(MN, (I IL),
---- db((< MN' ; U ; U' ; U'' ; U3 ; VDS ; MNS ; VES > MIS),
---- MNS', VIS, VES', MNS'', MNS3, MNS4, QIL))
---- = setUpImportDeps(MN, IL,
---- db((< MN' ; U ; U' ; U'' ; U3 ; VDS ; MN . MNS ; VES > MIS),
---- MNS', VIS, VES', MNS'', MNS3, MNS4, QIL))
---- if MN' := moduleName(I) .
eq setUpImportDeps(MN, ((including MN' .) IL),
db((< MN' ; DT ; U ; U' ; U'' ; VDS ; MNS ; VES > MIS), MNS', VIS, VES', MNS'', MNS3, MNS4, QIL))
= setUpImportDeps(MN, IL,
db((< MN' ; DT ; U ; U' ; U'' ; VDS ; MN . MNS ; VES > MIS), MNS', VIS, VES', MNS'', MNS3, MNS4, QIL)) .
eq setUpImportDeps(MN, ((including MN' .) IL),
db((< MN' ; U ; U' ; U'' ; U3 ; VDS ; MNS ; VES > MIS), MNS', VIS, VES', MNS'', MNS3, MNS4, QIL))
= setUpImportDeps(MN, IL,
db((< MN' ; U ; U' ; U'' ; U3 ; VDS ; MN . MNS ; VES > MIS), MNS', VIS, VES', MNS'', MNS3, MNS4, QIL)) .
eq setUpImportDeps(MN, ((extending MN' .) IL),
db((< MN' ; DT ; U ; U' ; U'' ; VDS ; MNS ; VES > MIS), MNS', VIS, VES', MNS'', MNS3, MNS4, QIL))
= setUpImportDeps(MN, IL,
db((< MN' ; DT ; U ; U' ; U'' ; VDS ; MN . MNS ; VES > MIS), MNS', VIS, VES', MNS'', MNS3, MNS4, QIL)) .
eq setUpImportDeps(MN, ((extending MN' .) IL),
db((< MN' ; U ; U' ; U'' ; U3 ; VDS ; MNS ; VES > MIS), MNS', VIS, VES', MNS'', MNS3, MNS4, QIL))
= setUpImportDeps(MN, IL,
db((< MN' ; U ; U' ; U'' ; U3 ; VDS ; MN . MNS ; VES > MIS), MNS', VIS, VES', MNS'', MNS3, MNS4, QIL)) .
eq setUpImportDeps(MN, ((protecting MN' .) IL),
db((< MN' ; DT ; U ; U' ; U'' ; VDS ; MNS ; VES > MIS), MNS', VIS, VES', MNS'', MNS3, MNS4, QIL))
= setUpImportDeps(MN, IL,
db((< MN' ; DT ; U ; U' ; U'' ; VDS ; MN . MNS ; VES > MIS), MNS', VIS, VES', MNS'', MNS3, MNS4, QIL)) .
eq setUpImportDeps(MN, ((protecting MN' .) IL),
db((< MN' ; U ; U' ; U'' ; U3 ; VDS ; MNS ; VES > MIS), MNS', VIS, VES', MNS'', MNS3, MNS4, QIL))
= setUpImportDeps(MN, IL,
db((< MN' ; U ; U' ; U'' ; U3 ; VDS ; MN . MNS ; VES > MIS), MNS', VIS, VES', MNS'', MNS3, MNS4, QIL)) .
eq setUpImportDeps(MN, I IL, DB)
= warning(DB, '\r 'Error: '\o 'Module header2QidList(moduleName(I)) 'not 'in 'database. '\n)
[owise] .
eq setUpImportDeps(MN, nil, DB) = DB .
op setUpViewDeps : ModuleExpression ViewExp Database -> Database .
op setUpViewExpDeps : ViewExp Database -> Database .
op setUpViewExpDeps : ViewExp ParameterList Database -> Database .
eq setUpViewDeps(ME, VE,
db((< ME ; DT ; U ; U' ; U'' ; VDS ; MNS ; VES > MIS), MNS', VIS, VES', MNS'', MNS3, MNS4, QIL))
= db((< ME ; DT ; U ; U' ; U'' ; VDS ; MNS ; VE # VES > MIS), MNS', VIS, VES', MNS'', MNS3, MNS4, QIL) .
eq setUpViewDeps(ME, VE,
db((< ME ; U ; U' ; U'' ; U3 ; VDS ; MNS ; VES > MIS), MNS', VIS, VES', MNS'', MNS3, MNS4, QIL))
= db((< ME ; U ; U' ; U'' ; U3 ; VDS ; MNS ; VE # VES > MIS), MNS', VIS, VES', MNS'', MNS3, MNS4, QIL) .
eq setUpViewDeps(ME, VE, DB)
= warning(DB, '\r 'Error: '\o 'Module header2QidList(ME) 'not 'in 'database. '\n)
[owise] .
eq setUpViewExpDeps(QI, DB) = DB .
eq setUpViewExpDeps(QI{PL}, DB) = setUpViewExpDeps(QI{PL}, PL, DB) .
eq setUpViewExpDeps(VE, (QI, PL),
db(MIS, MNS, < QI ; DT ; VI ; MNS' ; VES > VIS, VES', MNS'', MNS3, MNS4, QIL))
= setUpViewExpDeps(VE, PL,
db(MIS, MNS, < QI ; DT ; VI ; MNS' ; VE # VES > VIS, VES', MNS'', MNS3, MNS4, QIL)) .
eq setUpViewExpDeps(VE, (QI, PL),
db(MIS, MNS, < QI ; VI ; VI' ; MNS' ; VES > VIS, VES', MNS'', MNS3, MNS4, QIL))
= setUpViewExpDeps(VE, PL,
db(MIS, MNS, < QI ; VI ; VI' ; MNS' ; VE # VES > VIS, VES', MNS'', MNS3, MNS4, QIL)) .
eq setUpViewExpDeps(QI{PL}, PL',
db(MIS, MNS, < QI ; DT ; VI ; MNS' ; VES > VIS, VES', MNS'', MNS3, MNS4, QIL))
= db(MIS, MNS, < QI ; DT ; VI ; MNS' ; QI{PL} # VES > VIS, VES', MNS'', MNS3, MNS4, QIL)
[owise] .
eq setUpViewExpDeps(QI{PL}, PL',
db(MIS, MNS, < QI ; VI ; VI' ; MNS' ; VES > VIS, VES', MNS'', MNS3, MNS4, QIL))
= db(MIS, MNS, < QI ; VI ; VI' ; MNS' ; QI{PL} # VES > VIS, VES', MNS'', MNS3, MNS4, QIL)
[owise] .
eq setUpViewExpDeps(VE, (QI{PL}, PL'),
db(MIS, MNS, < QI{PL} ; DT ; VI ; MNS' ; VES > VIS, VES', MNS'', MNS3, MNS4, QIL))
= setUpViewExpDeps(VE, PL',
db(MIS, MNS, < QI{PL} ; DT ; VI ; MNS' ; VE # VES > VIS, VES', MNS'', MNS3, MNS4, QIL)) .
eq setUpViewExpDeps(VE, (QI{PL}, PL'),
db(MIS, MNS, < QI{PL} ; VI ; VI' ; MNS' ; VES > VIS, VES', MNS'', MNS3, MNS4, QIL))
= setUpViewExpDeps(VE, PL',
db(MIS, MNS, < QI{PL} ; VI ; VI' ; MNS' ; VE # VES > VIS, VES', MNS'', MNS3, MNS4, QIL)) .
eq setUpViewExpDeps(VE, (QI{PL}, PL'), DB)
= setUpViewExpDeps(VE, PL', DB)
[owise] .
eq setUpViewExpDeps(VE, empty, DB) = DB .
op compiledModule : ModuleExpression Database -> Bool .
op compiledModule : ParameterDecl Database -> Bool .
op compiledView : ViewExp Database -> Bool .
eq compiledView(VE,
db(MIS, MNS, < VE ; DT ; VI ; MNS' ; VES > VIS, VES', MNS'', MNS3, MNS4, QIL))
= VI =/= null .
eq compiledView(ME, DB) = false [owise] .
eq compiledModule(MN,
db(< MN ; DT ; U ; U' ; U'' ; VDS ; MNS ; VES > MIS, MNS',
VIS, VES', MNS'', MNS3, MNS4, QIL))
= U'' =/= noModule .
eq compiledModule(MN,
db(< MN ; U ; U' ; U'' ; U3 ; VDS ; MNS ; VES > MIS, MNS',
VIS, VES', MNS'', MNS3, MNS4, QIL))
= U3 =/= noModule .
eq compiledModule(MN, DB) = false [owise] .
op insertTermView : ViewExp Term Database -> Database .
op insertView : View Database -> Database .
op getTermView : ViewExp Database -> Default{Term} .
op getView : ViewExp Database -> [View] .
eq insertTermView(VE, T,
db(MIS, MNS, < VE ; DT ; VI ; MNS' ; VES > VIS, VES',
MNS'', MNS3, MNS4, QIL))
= delViews(VES,
delModules(MNS',
db(MIS, MNS,
< VE ; T ; null ; emptyModuleNameSet ; emptyViewExpSet > VIS, VES',
MNS'', MNS3, MNS4,
QIL
'\g 'Advisory: '\o 'View viewExp2QidList(VE) 'redefined. '\n))) .
eq insertTermView(VE, T,
db(MIS, MNS, VIS, VES, MNS', MNS'', MNS3, QIL))
= db(MIS, MNS,
< VE ; T ; null ; emptyModuleNameSet ; emptyViewExpSet > VIS,
(VE # VES), MNS', MNS'', MNS3, QIL)
[owise] .
eq insertView(view VE from ME to ME' is VMAPS endv,
db(MIS, MNS, < VE ; DT ; VI ; MNS' ; VES > VIS, VES', MNS'', MNS3, MNS4, QIL))
= setUpViewExpDeps(VE,
setUpViewDeps(ME, VE,
setUpViewDeps(ME', VE,
db(MIS, MNS,
< VE ; DT ;
view VE from ME to ME' is VMAPS endv ;
MNS' ; VES > VIS,
VES', MNS'', MNS3, MNS4, QIL)))) .
eq insertView(view VE{PDL} from ME to ME' is VMAPS endv,
db(MIS, MNS, < VE ; DT ; VI ; MNS' ; VES > VIS, VES', MNS'', MNS3, MNS4, QIL))
= setUpViewExpDeps(VE,
setUpViewDeps(ME, VE,
setUpViewDeps(ME', VE,
db(MIS, MNS,
< VE ; DT ;
view VE{PDL} from ME to ME' is VMAPS endv ;
MNS' ; VES > VIS,
VES', MNS'', MNS3, MNS4, QIL)))) .
eq insertView(view VE from ME to ME' is VMAPS endv,
db(MIS, MNS, VIS, VES', MNS'', MNS3, MNS4, QIL))
= setUpViewExpDeps(VE,
setUpViewDeps(ME, VE,
setUpViewDeps(ME', VE,
db(MIS, MNS,
< VE ; (null).Default{Term} ;
view VE from ME to ME' is VMAPS endv ;
emptyModuleNameSet ; emptyViewExpSet > VIS,
VE # VES', MNS'', MNS3, MNS4, QIL))))
[owise] .
eq insertView(view VE{PDL} from ME to ME' is VMAPS endv,
db(MIS, MNS, VIS, VES', MNS'', MNS3, MNS4, QIL))
= setUpViewExpDeps(VE,
setUpViewDeps(ME, VE,
setUpViewDeps(ME', VE,
db(MIS, MNS,
< VE ; (null).Default{Term} ;
view VE{PDL} from ME to ME' is VMAPS endv ;
emptyModuleNameSet ; emptyViewExpSet > VIS,
VE # VES', MNS'', MNS3, MNS4, QIL))))
[owise] .
eq insertView(viewError(QIL), DB) = warning(DB, QIL) .
ceq insertView(view VE:[ViewExp] from ME:[ModuleExpression] to ME':[ModuleExpression] is VMAPS:[RenamingSet] endv, DB)
= warning(DB, 'The 'view QIL QI if QI == '`) then '\s else nil fi 'contains 'errors.)
if not view VE:[ViewExp] from ME:[ModuleExpression] to ME':[ModuleExpression] is VMAPS:[RenamingSet] endv :: View
/\ QIL QI := eMetaPrettyPrint(VE:[ViewExp])
[owise] .
ceq insertView(view VE:[ViewExp]{PDL:[ParameterDeclList]} from ME:[ModuleExpression] to ME':[ModuleExpression] is VMAPS:[RenamingSet] endv, DB)
= warning(DB, 'The 'view QIL QI if QI == '`) then '\s else nil fi 'contains 'errors.)
if not view VE:[ViewExp]{PDL:[ParameterDeclList]} from ME:[ModuleExpression] to ME':[ModuleExpression] is VMAPS:[RenamingSet] endv :: View
/\ QIL QI := eMetaPrettyPrint(VE:[ViewExp])
[owise] .
eq getTermView(VE,
db(MIS, MNS, (< VE ; DT ; VI ; MNS' ; VES > VIS), VES', MNS'', MNS3, MNS4, QIL))
= DT .
eq getTermView(VE, db(MIS, MNS, VIS, VES, MNS', MNS'', MNS3, QIL))
= qidError('\r 'Error: '\o 'View viewExp2QidList(VE) 'not 'in 'database. '\n)
[owise] .
eq getView(VE,
db(MIS, MNS, < VE ; DT ; VI ; MNS' ; VES > VIS, VES', MNS'', MNS3, MNS4, QIL))
= VI .
eq getView(VE,
db(MIS, MNS, < VE ; VI ; VI' ; MNS' ; VES > VIS, VES', MNS'', MNS3, MNS4, QIL))
= VI' .
eq getView(VE, db(MIS, MNS, VIS, VES, MNS', MNS'', MNS3, QIL))
= viewError('\r 'Error: '\o 'View viewExp2QidList(VE) 'not 'in 'database. '\n)
[owise] .
*** There are functions to insert the different versions of a unit, and to
*** extract them. We only give here the equations for the insertion of top
*** units to illustrate the way in which the consistency of the database is
*** maintained. We assume that when the internal version, the signature, or
*** the flat version of a module is entered in the database, its corresponding
*** top module is already present in it.
pr 3TUPLE{Term,OpDeclSet,Module}
* (op ((_,_,_)) to <_;_;_>) .
---- sort Tuple{Term,OpDeclSet,Module} .
---- op <_;_;_> : Default{Term} OpDeclSet Module -> Tuple{Term,OpDeclSet,Module} .
op error : QidList -> [Tuple{Term,OpDeclSet,Module}] .
op insTermModule : ModuleName Module Database -> Database .
op insTermModule : ModuleName Term Database -> Database .
op insertTopModule : ModuleExpression [Module] Database -> Database .
op insertInternalModule : ModuleExpression [Module] Database -> Database .
op insertFlatModule : ModuleExpression [Module] Database -> Database .
op insertVars : ModuleExpression [OpDeclSet] Database -> Database .
op getTermModule : ModuleExpression Database -> [Tuple{Term,OpDeclSet,Module}] .
op getTopModule : ModuleExpression Database -> [Module] .
op getInternalModule : ModuleExpression Database -> [Module] .
op getFlatModule : ModuleExpression Database -> [Module] .
op getFlatModuleNeg : ModuleExpression Database -> [Module] .
op getVars : ModuleExpression Database -> [OpDeclSet] .
op insertTopModule : ParameterDecl [Module] Database -> Database .
op insertInternalModule : ParameterDecl [Module] Database -> Database .
op insertFlatModule : ParameterDecl [Module] Database -> Database .
op insertVars : ParameterDecl [OpDeclSet] Database -> Database .
op getTermModule : ParameterDecl Database -> [Tuple{Term,OpDeclSet,Module}] .
op getTopModule : ParameterDecl Database -> [Module] .
op getInternalModule : ParameterDecl Database -> [Module] .
op getFlatModule : ParameterDecl Database -> [Module] .
op getFlatModuleNeg : ParameterDecl Database -> [Module] .
op getVars : ParameterDecl Database -> [OpDeclSet] .
eq insTermModule(MN, T,
db(< MN ; DT ; U ; U' ; U'' ; VDS ; MNS ; VES > MIS, MNS',
VIS, VES', MNS'', MNS3, MNS4, QIL))
= delModules(MNS,
delViews(VES,
db(< MN ; T ; noModule ; noModule ; noModule ; none ;
emptyModuleNameSet ; emptyViewExpSet > MIS,
MNS', VIS, VES', MNS'', MNS3, MNS4,
QIL
'\g 'Advisory: '\o 'Module header2QidList(MN) 'redefined. '\n))).
eq insTermModule(MN, T,
db(< MN ; U ; U' ; U'' ; U3 ; VDS ; MNS ; VES > MIS, MNS',
VIS, VES', MNS'', MNS3, MNS4, QIL))
= delModules(MNS,
delViews(VES,
db(< MN ; T ; noModule ; noModule ; noModule ; none ;
emptyModuleNameSet ; emptyViewExpSet > MIS,
MNS', VIS, VES', MNS'', MNS3, MNS4,
QIL
'\g 'Advisory: '\o 'Module header2QidList(MN) 'redefined. '\n))).
eq insTermModule(MN, T,
db(MIS, MNS, VIS, VES, MNS', MNS'', MNS3, QIL))
= db(< MN ; T ; noModule ; noModule ; noModule ; none ;
emptyModuleNameSet ; emptyViewExpSet > MIS,
MN . MNS, VIS, VES, MNS', MNS'', MNS3, QIL)
[owise] .
eq insTermModule(MN, qidError(QIL), DB) = warning(DB, QIL) .
eq insTermModule(MN, unitError(QIL), DB) = warning(DB, QIL) .
eq insTermModule(MN, U,
db(< MN ; DT ; U' ; U'' ; U3 ; VDS ; MNS ; VES > MIS, MNS',
VIS, VES', MNS'', MNS3, MNS4, QIL))
= delModules(MNS,
delViews(VES,
db(< MN ; U ; noModule ; noModule ; noModule ; none ;
emptyModuleNameSet ; emptyViewExpSet > MIS,
MNS', VIS, VES', MNS'', MNS3, MNS4,
QIL
'\g 'Advisory:
'\o 'Module header2QidList(MN) 'redefined. '\n))).
eq insTermModule(MN, U,
db(< MN ; U' ; U'' ; U3 ; U4 ; VDS ; MNS ; VES > MIS, MNS',
VIS, VES', MNS'', MNS3, MNS4, QIL))
= delModules(MNS,
delViews(VES,
db(< MN ; U ; noModule ; noModule ; noModule ; none ;
emptyModuleNameSet ; emptyViewExpSet > MIS,
MNS', VIS, VES', MNS'', MNS3, MNS4,
QIL
'\g 'Advisory:
'\o 'Module header2QidList(MN) 'redefined. '\n))).
eq insTermModule(MN, U,
db(MIS, MNS, VIS, VES, MNS', MNS'', MNS3, QIL))
= db(< MN ; U ; noModule ; noModule ; noModule ; none ;
emptyModuleNameSet ; emptyViewExpSet > MIS,
MN . MNS, VIS, VES, MNS', MNS'', MNS3, QIL)
[owise] .
eq insTermModule(MN, qidError(QIL), DB) = warning(DB, QIL) .
eq insTermModule(MN, unitError(QIL), DB) = warning(DB, QIL) .
eq insertTopModule(MN, U,
db(< MN ; null ; U' ; U'' ; U3 ; VDS ; MNS ; VES > MIS,
MNS', VIS, VES', MNS'', MNS3, MNS4, QIL))
= db(< MN ; null ; U ; noModule ; noModule ; VDS ; MNS ; VES > MIS,
MNS', VIS, VES', MNS'', MNS3, MNS4,
QIL
'\r 'ERROR: '\o
'Internally 'generated 'module header2QidList(MN) 'redefined. '\n) .
eq insertTopModule(MN, U,
db(< MN ; T ; U' ; U'' ; U3 ; VDS ; MNS ; VES > MIS,
MNS', VIS, VES', MNS'', MNS3, MNS4, QIL))
= setUpModuleDeps(U,
db(< MN ; T ; U ; noModule ; noModule ; VDS ; MNS ; VES > MIS,
MNS', VIS, VES', MNS'', MNS3, MNS4, QIL)) .
eq insertTopModule(MN, U,
db(< MN ; U' ; U'' ; U3 ; U4 ; VDS ; MNS ; VES > MIS,
MNS', VIS, VES', MNS'', MNS3, MNS4, QIL))
= setUpModuleDeps(U,
db(< MN ; U' ; U ; noModule ; noModule ; VDS ; MNS ; VES > MIS,
MNS', VIS, VES', MNS'', MNS3, MNS4, QIL)) .
eq insertTopModule(MN, U,
db(MIS, MNS, VIS, VES, MNS', MNS'', MNS3, QIL))
= setUpModuleDeps(U,
db(< MN ; null ; U ; noModule ; noModule ;
none ; emptyModuleNameSet ; emptyViewExpSet > MIS,
MN . MNS, VIS, VES, MNS', MNS'', MNS3, QIL))
[owise] .
eq insertTopModule(MN, unitError(QIL), DB) = warning(DB, QIL) .
eq insertInternalModule(MN, U,
db(< MN ; DT ; U' ; U'' ; U3 ; VDS ; MNS ; VES > MIS,
MNS', VIS, VES', MNS'', MNS3, MNS4, QIL))
= db(< MN ; DT ; U' ; U ; U3 ; VDS ; MNS ; VES > MIS,
MNS', VIS, VES', MNS'', MNS3, MNS4, QIL) .
eq insertInternalModule(MN, U,
db(< MN ; U' ; U'' ; U3 ; U4 ; VDS ; MNS ; VES > MIS,
MNS', VIS, VES', MNS'', MNS3, MNS4, QIL))
= db(< MN ; U' ; U'' ; U ; U4 ; VDS ; MNS ; VES > MIS,
MNS', VIS, VES', MNS'', MNS3, MNS4, QIL) .
eq insertInternalModule(MN, unitError(QIL), DB) = warning(DB, QIL) .
eq insertFlatModule(MN, U,
db(< MN ; DT ; U' ; U'' ; U3 ; VDS ; MNS ; VES > MIS,
MNS', VIS, VES', MNS'', MNS3, MNS4, QIL))
= db(< MN ; DT ; U' ; U'' ; U ; VDS ; MNS ; VES > MIS,
MNS', VIS, VES', MNS'', MNS3, MNS4, QIL) .
eq insertFlatModule(MN, U,
db(< MN ; U' ; U'' ; U3 ; U4 ; VDS ; MNS ; VES > MIS,
MNS', VIS, VES', MNS'', MNS3, MNS4, QIL))
= db(< MN ; U' ; U'' ; U3 ; U ; VDS ; MNS ; VES > MIS,
MNS', VIS, VES', MNS'', MNS3, MNS4, QIL) .
eq insertFlatModule(MN, unitError(QIL), DB) = warning(DB, QIL) .
eq insertVars(MN, VDS,
db(< MN ; DT ; U' ; U'' ; U3 ; VDS' ; MNS ; VES > MIS,
MNS', VIS, VES', MNS'', MNS3, MNS4, QIL))
= db(< MN ; DT ; U' ; U'' ; U3 ; VDS ; MNS ; VES > MIS,
MNS', VIS, VES', MNS'', MNS3, MNS4, QIL) .
eq insertVars(MN, VDS,
db(< MN ; U' ; U'' ; U3 ; U4 ; VDS' ; MNS ; VES > MIS,
MNS', VIS, VES', MNS'', MNS3, MNS4, QIL))
= db(< MN ; U' ; U'' ; U3 ; U4 ; VDS ; MNS ; VES > MIS,
MNS', VIS, VES', MNS'', MNS3, MNS4, QIL) .
eq insertVars(MN, opDeclError(QIL), DB) = warning(DB, QIL) .
eq getTermModule(MN,
db(< MN ; null ; U ; U' ; U'' ; VDS ; MNS ; VES > MIS,
MNS', VIS, VES', MNS'', MNS3, MNS4, QIL))
= error('\r 'Error: '\o header2QidList(MN) 'is 'an 'internal 'module. '\n) .
eq getTermModule(MN,
db(< MN ; DT ; U ; U' ; U'' ; VDS ; MNS ; VES > MIS,
MNS', VIS, VES', MNS'', MNS3, MNS4, QIL))
= < DT ; none ; noModule > .
eq getTermModule(MN,
db(< MN ; U ; U' ; U'' ; U3 ; VDS ; MNS ; VES > MIS,
MNS', VIS, VES', MNS'', MNS3, MNS4, QIL))
= < null ; VDS ; U > .
eq getTermModule(MN, DB)
= error('\r 'Error: '\o 'Module header2QidList(MN) '\n)
[owise] .
eq getTopModule(MN,
db(< MN ; DT ; U ; U' ; U'' ; VDS ; MNS ; VES > MIS,
MNS', VIS, VES', MNS'', MNS3, MNS4, QIL))
= U .
eq getTopModule(MN,
db(< MN ; U ; U' ; U'' ; U3 ; VDS ; MNS ; VES > MIS,
MNS', VIS, VES', MNS'', MNS3, MNS4, QIL))
= U' .
eq getTopModule(MN, DB)
= unitError('\r 'Error: '\o 'Module header2QidList(MN) 'not 'in 'database. '\n)
[owise] .
eq getInternalModule(MN,
db(< MN ; DT ; U ; U' ; U'' ; VDS ; MNS ; VES > MIS,
MNS', VIS, VES', MNS'', MNS3, MNS4, QIL))
= U' .
eq getInternalModule(MN,
db(< MN ; U ; U' ; U'' ; U3 ; VDS ; MNS ; VES > MIS,
MNS', VIS, VES', MNS'', MNS3, MNS4, QIL))
= U'' .
eq getInternalModule(MN, DB)
= unitError('\r 'Error: '\o 'Module header2QidList(MN) 'not 'in 'database. '\n)
[owise] .
eq getVars(MN,
db(< MN ; DT ; U ; U' ; M ; VDS ; MNS ; VES > MIS,
MNS', VIS, VES', MNS'', MNS3, MNS4, QIL))
= VDS .
eq getVars(MN,
db(< MN ; U ; U' ; U'' ; M ; VDS ; MNS ; VES > MIS,
MNS', VIS, VES', MNS'', MNS3, MNS4, QIL))
= VDS .
eq getVars(MN, DB) = none [owise] .
*** The name of the signature and the flattened module is not the
*** module expression used as the name of the module but the result of
*** converting it into a quoted identifier.
eq getFlatModule(MN,
db(< MN ; DT ; U ; U' ; M ; VDS ; MNS ; VES > MIS, MNS', VIS, VES', MNS'', MNS3, MNS4, QIL))
= if M == noModule
then unitError('\r 'Error: '\o 'Module header2QidList(MN) 'not 'compiled. '\n)
else remNegAnns(M)
fi .
eq getFlatModule(MN,
db(< MN ; U ; U' ; U'' ; M ; VDS ; MNS ; VES > MIS, MNS', VIS, VES', MNS'', MNS3, MNS4, QIL))
= if M == noModule
then unitError('\r 'Error: '\o 'Module header2QidList(MN) 'not 'compiled. '\n)
else remNegAnns(M)
fi .
eq getFlatModule(MN, DB)
= unitError('\r 'Error: '\o 'Module header2QidList(MN) 'not 'in 'database. '\n)
[owise] .
*** Handling of negative annotations (by Santiago Escobar)
eq getFlatModuleNeg(MN,
db(< MN ; DT ; U ; U' ; M ; VDS ; MNS ; VES > MIS,
MNS', VIS, VES', MNS'', MNS3, MNS4, QIL))
= M .
eq getFlatModuleNeg(MN,
db(< MN ; U ; U' ; U'' ; M ; VDS ; MNS ; VES > MIS,
MNS', VIS, VES', MNS'', MNS3, MNS4, QIL))
= M .
eq getFlatModuleNeg(MN,
db(< MN ; DT ; U ; U' ; noModule ; VDS ; MNS ; VES > MIS,
MNS', VIS, VES', MNS'', MNS3, MNS4, QIL))
= unitError('\r 'Error: '\o
'Module header2QidList(MN) 'not 'compiled. '\n) .
eq getFlatModuleNeg(MN,
db(< MN ; U ; U' ; U'' ; noModule ; VDS ; MNS ; VES > MIS,
MNS', VIS, VES', MNS'', MNS3, MNS4, QIL))
= unitError('\r 'Error: '\o
'Module header2QidList(MN) 'not 'compiled. '\n) .
eq getFlatModuleNeg(MN, DB)
= unitError('\r 'Error: '\o 'Module header2QidList(MN) 'not 'in 'database. '\n)
[owise] .
*** removeNegAnnotations
op remNegAnns : Module -> Module .
op remNegAnns : OpDeclSet -> OpDeclSet .
op remNegAnns : AttrSet -> AttrSet .
op remNegAnns : IntList -> IntList .
eq remNegAnns(M) = setOps(M, remNegAnns(getOps(M))) .
eq remNegAnns(op F : TyL -> Ty [AtS] . OPDS)
= op F : TyL -> Ty [remNegAnns(AtS)] . remNegAnns(OPDS) .
eq remNegAnns((none).OpDeclSet) = (none).OpDeclSet .
eq remNegAnns(strat(NL:NatList) AtS) = strat(NL:NatList) AtS .
eq remNegAnns(strat(IL:IntList) AtS) = AtS [owise] .
eq remNegAnns(AtS) = AtS [owise] .
endfm
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
***
*** The Evaluation of Modules
***
*** The general principle for the evaluation of units in our design consists in
*** first evaluating any module expression, reducing it to a canonical form in
*** which only unit inclusions appear, that is, to a unit hierarchy, which can
*** be seen as a partial order of unit inclusions. The design of the Full Maude
*** system has been based upon the principle of evaluating all module
*** expressions to irreducible structured units, and on using the flat version
*** of the units only for execution purposes. We have then two different
*** processes clearly distinguished: a first step in which the structured unit
*** is evaluated and reduced to its normal form, and a second step in which
*** this normal form is flattened.
*** As explained in Section~\ref{execution-environment}, the process of
*** evaluation to normal form is also responsible for the parsing of the
*** bubbles in the premodules, which is accomplished once the signature has
*** been built. The parsing of bubbles is discussed in
*** Section~\ref{bubble-parsing}. To be able to handle the \texttt{up}
*** function and the \texttt{down} command presented in
*** Section~\ref{structured-specifications}, it is necessary to be able to
*** move terms and modules from one level of reflection to another. The
*** functionality to move between levels is presented in
*** Section~\ref{changing-levels}, where functions \texttt{up} and
*** \texttt{down} on sorts \texttt{Module} and \texttt{Term} are defined. The
*** transformation of object-oriented modules into system modules in discussed
*** in Section~\ref{omod2modfunction}. The evaluation of module expressions is
*** discussed in Sections~\ref{evalModExp}, \ref{application-of-maps},
*** \ref{instantiation}, and~\ref{renaming}.
***
*** Changing Levels
***
*** Moving terms of sorts \texttt{Term} and \texttt{Module} from one
*** level of reflection to another is possible thanks to the
*** \texttt{up} and \texttt{down} functions, which are defined,
*** respectively, in the following modules \texttt{MOVE-UP} and
*** \texttt{MOVE-DOWN}.
***
*** The \texttt{up} Function
***
*** Given a term of sort \texttt{Module} or \texttt{Term}, the
*** \texttt{up} function, defined in the following module
*** \texttt{MOVE-UP}, returns the term metarepresenting it. The
*** function is just call the \texttt{upTerm} predefined function.
*** We shall see in Section~\ref{bubble-parsing} how the \texttt{up} function
*** is used to evaluate the homonymous function discussed in
*** Section~\ref{structured-specifications}. In Section~\ref{instantiation} we
*** shall discuss how the \texttt{up} function is used to evaluate the
*** \texttt{META-LEVEL} module expression (see
*** Section~\ref{structured-specifications}).
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
fmod MOVE-UP is
pr META-LEVEL .
pr CONVERSION .
op up : Module -> Term .
op up : Term -> Term .
op up : EquationSet -> Term .
eq up(M:Module) = upTerm(M:Module) .
eq up(T:Term) = upTerm(T:Term) .
eq up(EqS:EquationSet) = upTerm(EqS:EquationSet) .
endfm
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
***
*** The \texttt{down} Function
***
*** Given a term of sort \texttt{Term} metarepresenting a term of sort
*** \texttt{Term} or \texttt{Module}, the \texttt{down} function can be seen
*** as the inverse of the \texttt{up} function discussed in the previous
*** section, that is, it returns the original term that had been
*** metarepresented. There are also \texttt{down} functions for terms
*** metarepresenting terms in other sorts. We present here only some of them.
*** We assume that the \texttt{down} functions are called with valid
*** metarepresentations. In fact, these functions should be declared as
*** partial functions going to error sorts when their arguments are invalid.
*** The main application of the \texttt{down} functions is in the evaluation
*** of the \texttt{down} command (see
*** Section~\ref{structured-specifications}). However, they are also used in
*** other tasks, as for example in the parsing of some inputs.
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
fmod MOVE-DOWN is
pr UNIT .
pr CONVERSION .
pr INT-LIST .
op downTerm : Term -> [Term] .
op downModule : Term -> [Module] .
op downQid : Term -> [Qid] [memo] .
op downQidList : Term -> [QidList] .
op downTypes : Term -> [TypeList] .
op downSorts : Term -> [SortSet] .
op downSort : Term -> [Sort] .
op downModExp : Constant -> [Header] .
op downNat : Term -> [Int] .
op downString : Term -> [String] .
op downResultPair : Term -> [ResultPair] .
op downTerm : TermList -> [Term] .
op downImports : TermList -> [ImportList] .
op downSubsorts : TermList -> [SubsortDeclSet] .
op downOps : TermList -> [OpDeclSet] .
op downEqCond : TermList -> [EqCondition] .
op downCond : TermList -> [Condition] .
op downMbs : TermList -> [MembAxSet] .
op downEqs : TermList -> [EquationSet] .
op downRls : TermList -> [RuleSet] .
op downAttrs : TermList -> [AttrSet] .
op downAttr : Term -> [Attr] .
op downHooks : TermList -> [HookList] .
op downMetaNat : Term -> [Term] .
op downNat : TermList -> [IntList] .
op downClasses : TermList -> [ClassDeclSet] .
op downMsgs : TermList -> [MsgDeclSet] .
op downSubclasses : TermList -> [SubclassDeclSet] .
op downClassAttrs : TermList -> [AttrDeclSet] .
vars T T' T'' T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 T12 : Term .
vars TL TL' : TermList .
vars QI QI' F V L : Qid .
var Ct : Constant .
var M : Module .
var Tp : Type .
eq downResultPair('`{_`,_`}[T, T']) = {downTerm(T), downTerm(T')} .
eq downModule('fmod_is_sorts_.____endfm[T1, T2, T3, T4, T5, T6, T7])
= (fmod downModExp(T1) is
downImports(T2)
sorts downSorts(T3) .
downSubsorts(T4)
downOps(T5)
downMbs(T6)
downEqs(T7)
endfm) .
eq downModule('mod_is_sorts_._____endm[T1, T2, T3, T4, T5, T6, T7, T8])
= (mod downModExp(T1) is
downImports(T2)
sorts downSorts(T3) .
downSubsorts(T4)
downOps(T5)
downMbs(T6)
downEqs(T7)
downRls(T8)
endm) .
eq downModule('omod_is_sorts_.________endom[T1, T2, T3, T4, T5, T6, T7, T8, T9, T10, T11])
= (omod downModExp(T1) is
downImports(T2)
sorts downSorts(T3) .
downSubsorts(T4)
downClasses(T5)
downSubclasses(T6)
downOps(T7)
downMsgs(T8)
downMbs(T9)
downEqs(T10)
downRls(T11)
endom) .
eq downModExp(Ct) = downQid(Ct) .
eq downImports('nil.ImportList) = nil .
eq downImports('__[TL]) = downImports(TL) .
eq downImports('including_.[T]) = (including downModExp(T) .) .
eq downImports('extending_.[T]) = (extending downModExp(T) .) .
eq downImports('protecting_.[T]) = (protecting downModExp(T) .) .
ceq downImports((TL, TL')) = (downImports(TL) downImports(TL')) if TL =/= empty /\ TL' =/= empty .
eq downSubsorts('none.SubsortDeclSet) = none .
eq downSubsorts('__[TL]) = downSubsorts(TL) .
eq downSubsorts('subsort_<_.[T, T']) = (subsort downQid(T) < downQid(T') .) .
ceq downSubsorts((TL, TL')) = (downSubsorts(TL) downSubsorts(TL')) if TL =/= empty /\ TL' =/= empty .
eq downOps('none.OpDeclSet) = none .
eq downOps('__[TL]) = downOps(TL) .
eq downOps('op_:_->_`[_`].[Ct, T, T', T''])
= (op downQid(Ct) : downTypes(T) -> downQid(T') [downAttrs(T'')] .) .
ceq downOps((TL, TL')) = (downOps(TL) downOps(TL')) if TL =/= empty /\ TL' =/= empty .
eq downAttrs('none.AttrSet) = none .
eq downAttrs('__[TL]) = downAttrs(TL) .
ceq downAttrs((TL, TL')) = (downAttr(TL) downAttrs(TL')) if TL =/= empty /\ TL' =/= empty .
ceq downAttrs(T)
= downAttr(T)
if T =/= 'none.AttrSet .
eq downAttr('assoc.Attr) = assoc .
eq downAttr('comm.Attr) = comm .
eq downAttr('idem.Attr) = idem .
eq downAttr('id[T]) = id(downTerm(T)) .
eq downAttr('left-id[T]) = left-id(downTerm(T)) .
eq downAttr('right-id[T]) = right-id(downTerm(T)) .
eq downAttr('poly[T]) = poly(downNat(T)) .
eq downAttr('strat[T]) = strat(downNat(T)) .
eq downAttr('memo.Attr) = memo .
eq downAttr('prec[T]) = prec(downNat(T)) .
eq downAttr('gather[T]) = gather(downQidList(T)) .
eq downAttr('ctor.Attr) = ctor .
eq downAttr('special[T]) = special(downHooks(T)) .
eq downAttr('iter.Attr) = iter .
eq downAttr('frozen[T]) = frozen(downNat(T)) .
eq downAttr('label[T]) = label(downQid(T)) .
eq downAttr('config.Attr) = config .
eq downAttr('object.Attr) = object .
eq downAttr('msg.Attr) = msg .
eq downAttr('nonexec.Attr) = nonexec .
eq downAttr('variant.Attr) = variant .
eq downAttr('metadata`(_`)['token[T]]) = metadata(downString(downQid(T))) .
eq downHooks('__[TL]) = downHooks(TL) .
eq downHooks('id-hook[T, T']) = id-hook(downQid(T), downQidList(T')) .
eq downHooks('op-hook[T, T', T'', T3])
= op-hook(downQid(T), downQid(T'), downQidList(T''), downQid(T3)) .
eq downHooks('term-hook[T, T']) = term-hook(downQid(T), downTerm(T')) .
ceq downHooks((TL, TL')) = downHooks(TL) downHooks(TL') if TL =/= empty /\ TL' =/= empty .
---- eq downTerm(T) = downTerm(T, qidError('\r 'Error: '\o 'Incorrect 'term. '\n)) .
eq downTerm(QI) = downQid(QI) .
eq downTerm('_`[_`][T, T']) = downQid(T)[downTerm(T')] .
eq downTerm('_`,_[T, TL]) = (downTerm(T), downTerm(TL)) .
ceq downTerm((T, TL)) = (downTerm(T), downTerm(TL)) if TL =/= empty .
eq downTerm(F[TL])
= qidError('\r 'Error: '\o 'Incorrect 'term. '\n) [owise] .
eq downEqCond('_/\_[TL]) = downEqCond(TL) .
eq downEqCond('_=_[T, T']) = downTerm(T) = downTerm(T') .
eq downEqCond('_:_[T, T']) = downTerm(T) : downSort(T') .
eq downEqCond('_:=_[T, T']) = downTerm(T) := downTerm(T') .
ceq downEqCond((TL, TL')) = downEqCond(TL) /\ downEqCond(TL') if TL =/= empty /\ TL' =/= empty .
eq downCond('_/\_[TL]) = downCond(TL) .
eq downCond('_=_[T, T']) = downEqCond('_=_[T, T']) .
eq downCond('_:_[T, T']) = downEqCond('_:_[T, T']) .
eq downCond('_:=_[T, T']) = downEqCond('_:=_[T, T']) .
eq downCond('_=>_[T, T']) = downTerm(T) => downTerm(T') .
ceq downCond((TL, TL')) = downCond(TL) /\ downCond(TL') if TL =/= empty /\ TL' =/= empty .
eq downMbs('none.MembAxSet) = none .
eq downMbs('__[TL]) = downMbs(TL) .
eq downMbs('mb_:_`[_`].[T, T', T''])
= (mb downTerm(T) : downSort(T') [downAttrs(T'')] .) .
eq downMbs('cmb_:_if_`[_`].[T, T', T'', T3])
= (cmb downTerm(T) : downSort(T') if downEqCond(T'') [downAttrs(T3)] .) .
ceq downMbs((TL, TL')) = (downMbs(TL) downMbs(TL')) if TL =/= empty /\ TL' =/= empty .
eq downEqs('none.EquationSet) = none .
eq downEqs('__[TL]) = downEqs(TL) .
eq downEqs('eq_=_`[_`].[T, T', T''])
= (eq downTerm(T) = downTerm(T') [downAttrs(T'')] .) .
eq downEqs('ceq_=_if_`[_`].[T, T', T'', T3])
= (ceq downTerm(T) = downTerm(T') if downEqCond(T'') [downAttrs(T3)] .) .
ceq downEqs((TL, TL')) = (downEqs(TL) downEqs(TL')) if TL =/= empty /\ TL' =/= empty .
eq downRls('none.RuleSet) = none .
eq downRls('__[TL]) = downRls(TL) .
eq downRls('rl_=>_`[_`].[T, T', T''])
= (rl downTerm(T) => downTerm(T') [downAttrs(T'')] .) .
eq downRls('crl_=>_if_`[_`].[T, T', T'', T3])
= (crl downTerm(T) => downTerm(T') if downCond(T'') [downAttrs(T3)] .) .
ceq downRls((TL, TL')) = (downRls(TL) downRls(TL')) if TL =/= empty /\ TL' =/= empty .
eq downSorts('none.EmptyTypeSet) = none .
---- eq downSorts('none.SortSet) = none .
eq downSorts('_;_[TL]) = downSorts(TL) .
ceq downSorts((TL, TL')) = (downSorts(TL) ; downSorts(TL')) if TL =/= empty /\ TL' =/= empty .
eq downSorts(QI) = downSort(QI) [owise] .
eq downSort(Ct) = downQid(Ct) .
eq downTypes('nil.TypeList) = nil .
eq downTypes('__[TL]) = downTypes(TL) .
ceq downTypes((TL, TL'))
= (downTypes(TL) downTypes(TL'))
if TL =/= empty /\ TL' =/= empty .
eq downTypes(QI) = downSort(QI) [owise] .
eq downQidList('nil.TypeList) = nil .
eq downQidList('__[TL]) = downQidList(TL) .
ceq downQidList((TL, TL')) = (downQidList(TL) downQidList(TL')) if TL =/= empty /\ TL' =/= empty .
eq downQidList(QI) = downQid(QI) [owise] .
eq downQid(Ct)
= qid(substr(string(getName(Ct)), 1, length(string(getName(Ct))))) .
---- eq downQid(Ct) = downTerm(Ct) .
eq downMetaNat(QI)
= qid(substr(string(getName(QI)), 1, length(string(getName(QI))))
+ ".Nat") .
---- eq downNat(T) = downTerm(T, numberError('Error: 'non 'valid 'metaterm)) .
ceq downNat(QI)
= trunc(rat(string(getName(QI)), 10))
if getType(QI) == 'Nat or getType(QI) == 'NzNat .
ceq downNat(QI)
= if substr(string(getName(QI)), 0 ,1) == "-"
then - trunc(rat(substr(string(getName(QI)), 1,
length(string(getName(QI)))), 10))
else trunc(rat(string(getName(QI)), 10))
fi
if getType(QI) == 'Int or getType(QI) == 'NzInt .
eq downNat('0.Zero) = 0 .
eq downNat('s_['0.Zero]) = 1 .
ceq downNat(F['0.Zero])
= trunc(rat(substr(string(F), 3, 2), 10))
if substr(string(F), 0, 3) = "s_^" .
eq downString(QI) = substr(string(QI), 1, _-_(length(string(QI)), 2)) .
eq downNat('__[TL]) = downNat(TL) .
ceq downNat((TL, TL')) = (downNat(TL) downNat(TL')) if TL =/= empty /\ TL' =/= empty .
eq downClasses('none.ClassDeclSet) = none .
eq downClasses('__[TL]) = downClasses(TL) .
ceq downClasses((TL, TL')) = (downClasses(TL) downClasses(TL')) if TL =/= empty /\ TL' =/= empty .
eq downClasses('class_|_.[T, T']) = (class downSort(T) | downClassAttrs(T') .) .
eq downClassAttrs('none.AttrDeclSet) = none .
eq downClassAttrs('_`,_[TL]) = downClassAttrs(TL) .
ceq downClassAttrs((TL, TL')) = (downClassAttrs(TL), downClassAttrs(TL')) if TL =/= empty /\ TL' =/= empty .
eq downClassAttrs('attr_:_[T, T']) = (attr downQid(T) : downSort(T')) .
eq downSubclasses('none.SubclassDeclSet) = none .
eq downSubclasses('__[TL]) = downSubclasses(TL) .
ceq downSubclasses((TL, TL')) = (downSubclasses(TL) downSubclasses(TL')) if TL =/= empty /\ TL' =/= empty .
eq downSubclasses('subclass_<_.[T, T']) = (subclass downQid(T) < downQid(T') .) .
eq downMsgs('none.MsgDeclSet) = none .
eq downMsgs('__[TL]) = downMsgs(TL) .
ceq downMsgs((TL, TL')) = (downMsgs(TL) downMsgs(TL')) if TL =/= empty /\ TL' =/= empty .
eq downMsgs('msg_:_->_.[Ct, T, T'])
= (msg downQid(Ct) : downTypes(T) -> downQid(T') .) .
endfm
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
***
*** Parsing of Bubbles
***
*** As discussed in Section~\ref{implementation-introduction}, in Full Maude,
*** the parsing process is split into two phases. In a first stage, the input
*** is parsed using the top-level grammar for Full Maude modules, theories,
*** views, and commands. Once this first stage is completed, we get a term
*** with bubbles in it, which is converted into a module, theory, or view.
*** This unit or view may still have the bubbles in it. We say that a module
*** with bubbles is a premodule, a view with bubbles a preview, and so on. The
*** second stage of the process consists in taking this preunit or preview and
*** converting the bubbles in it into terms by parsing them in the appropriate
*** signatures, obtaining a `valid' unit or view out of it, or otherwise a
*** parsing error. In the case of commands, if they contain any bubble, the
*** same will have to be done. All bubbles have to be parsed in the
*** appropriate signature before any further processing can be done with the
*** module, view, or command in which they appear.
***
*** Parsing of Module Expressions
***
*** Before introducing the \texttt{parseDecl} function, we present some
*** auxiliary functions. For example, the following functions
*** \texttt{parseType}, \texttt{parseSortSet}, and \texttt{parseTypeList}
*** return, respectively, the sort, set of sorts, and list of sorts
*** represented by the term given as argument. Note that these functions, as
*** most of the functions in this module, are partial functions. We assume
*** that the term given as argument is in fact the representation of, for
*** example, a valid sort, or set of sorts, etc. In the case of
*** \texttt{parseDecl} we assume that the term is the representation of a
*** predeclaration.
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
fmod MOD-EXP-PARSING is
pr MOVE-DOWN .
pr INT-LIST .
pr VIEW-EXPR-TO-QID .
vars T T' T'' T3 T4 : Term .
vars T? T?' : [Term] .
var TL TL' : TermList .
var QIL : QidList .
var Ct : Constant .
var AtS : AttrSet .
vars QI F : Qid .
var CD? : [Condition] .
vars S S' : Sort .
var TyL : TypeList .
op parseSort : Term ~> Sort .
op parseType : Term ~> Type .
op parseSortSet : Term ~> SortSet .
op parseTypeList : Term ~> TypeList .
op parseViewExp : Term ~> ViewExp .
op parseParameterList : Term ~> ParameterList .
eq parseSort('sortToken[T])
= if downQid(T) :: Type
then downQid(T)
else qidError('\r 'Warning: '\o downQid(T) 'is 'not 'a 'valid 'sort. '\n)
fi .
eq parseSort('_`{_`}[T, T'])
= qid(string(parseSort(T))
+ "{" + string(parameterList2Qid(parseParameterList(T'))) + "}") .
eq parseSort(T) = qidError('\r 'Warning: '\o 'invalid 'sort. '\n) [owise] .
eq parseType('`[_`][T])
---- = kind(parseSort(T)) .
= qid("[" + string(parseSort(T)) + "]") .
eq parseType(T) = parseSort(T) [owise] .
eq parseSortSet('__[T, T']) = (parseSort(T) ; parseSortSet(T')) .
eq parseSortSet(T) = parseSort(T) [owise].
eq parseTypeList('__[T, T']) = (parseType(T) parseTypeList(T')) .
eq parseTypeList(T) = parseType(T) [owise] .
eq parseViewExp('viewToken[T])
= if downQid(T) :: Sort
then downQid(T)
else qidError('\r 'Warning: '\o downQid(T) 'is 'not 'a 'valid 'sort. '\n)
fi .
eq parseViewExp('_`{_`}[T, T'])
= parseViewExp(T){parseParameterList(T')} .
eq parseViewExp(T)
= qidError('\r 'Warning: '\o 'invalid 'view 'expression. '\n)
[owise] .
eq parseParameterList('_`,_[T, T'])
= parseViewExp(T), parseParameterList(T') .
eq parseParameterList(T) = parseViewExp(T) [owise] .
*** The function \texttt{parseModExp} takes a term representing a
*** module expression and returns the corresponding term in sort
*** \texttt{ModuleExpression}. In case of adding new constructors for module
*** expressions, as it will be done in Section~\ref{extension}, new equations d
*** efining the semantics of the function on them will have to be given.
op parseModExp : Term -> ModuleExpression .
op parseMaps : Term -> RenamingSet .
op parseAttrs : Term -> AttrSet .
eq parseModExp('token[T]) = downQid(T) .
eq parseModExp('`(_`)[T]) = parseModExp(T) .
eq parseModExp('_`{_`}[T, T'])
= _`{_`}(parseModExp(T), parseParameterList(T')) .
eq parseModExp('_*`(_`)[T, T']) = _*`(_`)(parseModExp(T), parseMaps(T')) .
eq parseModExp('_+_[T, T']) = parseModExp(T) + parseModExp(T') .
eq parseModExp('TUPLE`[_`]['token[T]]) = TUPLE[parseNat(T)] .
eq parseModExp('POWER`[_`]['token[T]]) = POWER[parseNat(T)] .
eq parseMaps('_`,_[T, T']) = (parseMaps(T), parseMaps(T')) .
eq parseMaps('sort_to_[T, T']) = (sort parseType(T) to parseType(T')) .
eq parseMaps('label_to_['token[T], 'token[T']])
= (label downQid(T) to downQid(T')) .
eq parseMaps('class_to_[T, T']) = (class parseType(T) to parseType(T')) .
eq parseMaps('attr_._to_[T, 'token[T'], 'token[T'']])
= (attr downQid(T') . parseType(T) to downQid(T'')) .
eq parseMaps('msg_to_['token[T], 'token[T']])
= (msg downQid(T) to downQid(T')) .
eq parseMaps('msg_:_->_to_['token[T], T', T'', 'token[T3]])
= (msg downQid(T) : parseTypeList(T') -> parseType(T'') to downQid(T3)) .
eq parseMaps('msg_:`->_to_['token[T], T', 'token[T'']])
= (msg downQid(T) : nil -> parseType(T') to downQid(T'')) .
eq parseMaps('op_to_`[_`]['token[T], 'token[T'], T''])
= (op downQid(T) to downQid(T') [parseAttrs(T'')]) .
eq parseMaps('op_:_->_to_`[_`]['token[T], T', T'', 'token[T3], T4])
= (op downQid(T) : parseTypeList(T') -> parseType(T'') to downQid(T3)
[parseAttrs(T4)]) .
eq parseMaps('op_:`->_to_`[_`]['token[T], T', 'token[T''], T3])
= (op downQid(T) : nil -> parseType(T') to downQid(T'')
[parseAttrs(T3)]) .
eq parseMaps('op_:_~>_to_`[_`]['token[T], T', T'', 'token[T3], T4])
= (op downQid(T) : kind(parseTypeList(T')) -> kind(parseType(T''))
to downQid(T3) [parseAttrs(T4)]) .
eq parseMaps('op_:`~>_to_`[_`]['token[T], T', 'token[T''], T3])
= (op downQid(T) : nil -> kind(parseType(T')) to downQid(T'')
[parseAttrs(T3)]) .
eq parseMaps('op_to_['token[T], 'token[T']])
= (op downQid(T) to downQid(T') [none]) .
eq parseMaps('op_:_->_to_['token[T], T', T'', 'token[T3]])
= (op downQid(T) : parseTypeList(T') -> parseType(T'') to downQid(T3)
[none]) .
eq parseMaps('op_:`->_to_['token[T], T', 'token[T'']])
= (op downQid(T) : nil -> parseType(T') to downQid(T'') [none]) .
eq parseMaps('op_:_~>_to_['token[T], T', T'', 'token[T3]])
= (op downQid(T) : kind(parseTypeList(T')) -> kind(parseType(T''))
to downQid(T3) [none]) .
eq parseMaps('op_:`~>_to_['token[T], T', 'token[T'']])
= (op downQid(T) : nil -> kind(parseType(T')) to downQid(T'') [none]) .
eq parseAttrs('__[T, T']) = (parseAttrs(T) parseAttrs(T')) .
eq parseAttrs('assoc.@Attr@) = assoc .
eq parseAttrs('associative.@Attr@) = assoc .
eq parseAttrs('comm.@Attr@) = comm .
eq parseAttrs('commutative.@Attr@) = comm .
eq parseAttrs('idem.@Attr@) = idem .
eq parseAttrs('idempotent.@Attr@) = idem .
eq parseAttrs('id:_[T]) = none .
eq parseAttrs('identity:_[T]) = none .
eq parseAttrs('left`id:_[T]) = none .
eq parseAttrs('left`identity:_[T]) = none .
eq parseAttrs('right`id:_[T]) = none .
eq parseAttrs('right`identity:_[T]) = none .
eq parseAttrs('poly`(_`)[T]) = poly(parseInt(T)) .
eq parseAttrs('strat`(_`)[T]) = none .
eq parseAttrs('strategy`(_`)[T]) = none .
eq parseAttrs('memo.@Attr@) = none .
eq parseAttrs('memoization.@Attr@) = none .
eq parseAttrs('prec_['token[T]]) = prec(parseNat(T)) .
eq parseAttrs('precedence_['token[T]]) = prec(parseNat(T)) .
eq parseAttrs('prec_['`(_`)['token[T]]]) = prec(parseNat(T)) .
eq parseAttrs('precedence_['`(_`)['token[T]]]) = prec(parseNat(T)) .
eq parseAttrs('gather`(_`)['neTokenList[T]]) = gather(downQidList(T)) .
eq parseAttrs('gathering`(_`)['neTokenList[T]]) = gather(downQidList(T)) .
eq parseAttrs('format`(_`)['neTokenList[T]]) = none .
eq parseAttrs('ctor.@Attr@) = ctor .
eq parseAttrs('constructor.@Attr@) = ctor .
eq parseAttrs('frozen.@Attr@) = none .
eq parseAttrs('frozen`(_`)[T]) = none .
eq parseAttrs('iter.@Attr@) = iter .
eq parseAttrs('ditto.@Attr@) = ditto .
eq parseAttrs('special`(_`)[T]) = parseSpecial(parseHookList(T)) .
eq parseAttrs('config.@Attr@) = config .
eq parseAttrs('object.@Attr@) = object .
eq parseAttrs('msg.@Attr@) = msg .
eq parseAttrs('message.@Attr@) = msg .
eq parseAttrs('metadata_['token[T]]) = metadata(downString(downQid(T))) .
eq parseAttrs('variant.@Attr@) = variant .
eq parseAttrs('nonexec.@Attr@) = nonexec .
op parseSpecial : Set<Hook> -> Attr .
op parseHookList : Term -> Set<Hook> .
op hookList : Set<Hook> -> HookList .
sort Set<Hook> .
subsort Hook < Set<Hook> .
op none : -> Set<Hook> .
op _._ : Set<Hook> Set<Hook> -> Set<Hook> [assoc comm id: none] .
var SH : Set<Hook> .
var H : Hook .
eq parseSpecial(none) = none .
eq parseSpecial(SH) = special(hookList(SH)) [owise] .
eq parseHookList('__[T, TL]) = parseHookList(T) . parseHookList(TL) .
eq parseHookList('id-hook_['token[T]]) = id-hook(downQid(T), nil) .
eq parseHookList('id-hook_`(_`)['token[T], 'neTokenList[T']])
= id-hook(downQid(T), downQidList(T')) .
eq parseHookList(
'op-hook_`(_:_->_`)[
'token[T], 'token[T'], 'neTokenList[T''], 'token[T3]])
= op-hook(downQid(T), downQid(T'), downTypes(T''), downQid(T3)) .
eq parseHookList('op-hook_`(_:`->_`)['token[T], 'token[T'], 'token[T'']])
= op-hook(downQid(T), downQid(T'), nil, downQid(T'')) .
eq parseHookList(
'op-hook_`(_:_~>_`)[
'token[T], 'token[T'], 'neTokenList[T''], 'token[T3]])
= op-hook(downQid(T), downQid(T'), downTypes(T''), downQid(T3)) .
eq parseHookList('op-hook_`(_:`~>_`)['token[T], 'token[T'], 'token[T'']])
= op-hook(downQid(T), downQid(T'), nil, downQid(T'')) .
eq parseHookList('term-hook_`(_`)['token[T], T']) = none .
eq hookList(H) = H .
eq hookList(H . SH) = H hookList(SH) [owise] .
*** Given a term representing a machine integer, the function
*** \texttt{parseInt} returns the corresponding integer.
op parseNat : Term -> Nat .
op parseInt : Term -> Int .
op parseInt : TermList -> IntList .
eq parseInt(('neTokenList['__[TL]], TL')) = parseInt(TL) parseInt(TL') .
eq parseInt(('neTokenList[QI], TL)) = parseInt(QI) parseInt(TL) .
eq parseInt(empty) = nil .
eq parseInt((T, TL)) = parseInt(T) parseInt(TL) [owise] .
eq parseInt(nil) = nil .
eq parseInt(Ct)
= downNat(
qid(substr(string(getName(Ct)), 1, length(string(getName(Ct))))
+ ".Int")) .
eq parseNat(Ct)
= downNat(
qid(substr(string(getName(Ct)), 1, length(string(getName(Ct))))
+ ".Nat")) .
endfm
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
***
*** Parsing of Bubbles
***
*** In the following module \texttt{BUBBLE-PARSING}, the definitions for the
*** basic processing of bubbles are introduced. In it we declare a function
*** \texttt{solveBubbles} which takes a bubble and some other arguments and
*** returns the term resulting from parsing it.
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
fmod BUBBLE-PARSING is
pr DATABASE .
pr MOVE-UP .
pr MOVE-DOWN .
pr MOD-EXP-PARSING .
pr PRINT-SYNTAX-ERROR .
vars T T' : Term .
vars M M' : Module .
var B : Bool .
var QIL : QidList .
vars DB DB' : Database .
var TL : TermList .
var S : Sort .
vars QI QI' F : Qid .
var VDS : OpDeclSet .
var C : Constant .
var V : Variable .
var N : Nat .
var Tp : Type .
var RP : [ResultPair] .
var MN : ModuleName .
var ME : ModuleExpression .
var U : Module .
var Cond : Condition .
op resultPairError : QidList -> [ResultPair] [ctor] .
*** As we shall see in Section~\ref{evaluation}, a declaration importing the
*** predefined module \texttt{UP} (see Section~\ref{non-built-in-predefined})
*** is added to all modules importing the \texttt{META-LEVEL} module. The
*** \texttt{solveBubbles} function is called with a `flag' indicating whether
*** the module can contain calls to the \texttt{up} function or not. Thus,
*** when we call \texttt{metaParse} with some bubble and the module in which
*** such bubble has to be parsed, if there are occurrences of the function
*** \texttt{up} in it, they will be of the form \verb~'token[T]]~ or
*** \verb~'up['token[T], 'bubble[T']]~ for terms \texttt{T} and \texttt{T'}.
*** The function \texttt{solveUps} will evaluate them.
op solveBubbles : Term Module Bool OpDeclSet Database -> [Term] .
op solveUps : TermList Database -> [TermList] .
op solveUpsCondition : Condition Database -> Condition .
op solveUpsModExp : TermList Database -> [TermList] .
op constsToVars : Term OpDeclSet -> Term [memo] .
op constsToVars : TermList OpDeclSet -> TermList [memo] .
op constsToVarsAux : Constant OpDeclSet -> Qid [memo] .
eq constsToVars(F[TL], VDS) = F[constsToVars(TL, VDS)] .
eq constsToVars(C, VDS) = constsToVarsAux(C, VDS) .
eq constsToVars(V, VDS) = V .
eq constsToVars(qidError(QIL), VDS) = qidError(QIL) .
ceq constsToVars((T, TL), VDS)
= (constsToVars(T, VDS), constsToVars(TL, VDS))
if TL =/= empty .
eq constsToVarsAux(C, (op F : nil -> Tp [none] .) VDS)
= if getName(C) == F
then qid(string(F) + ":" + string(Tp))
else constsToVarsAux(C, VDS)
fi .
eq constsToVarsAux(C, none) = C .
ceq solveBubbles('bubble[T], M, true, VDS, DB)
*** if META-LEVEL is a submodule the ups need to be solved
= if RP :: ResultPair
then solveUps(constsToVars(getTerm(RP), VDS), DB)
else qidError('\r 'Warning: '\o printSyntaxError(RP, QIL) '\n
'\r 'Error: '\o 'no 'parse 'for QIL '\n)
fi
if M' := addOps(VDS, M)
/\ QIL := downQidList(T)
/\ RP := metaParse(M', QIL, anyType) .
ceq solveBubbles('bubble[T], M, false, VDS, DB)
= if RP :: ResultPair
then constsToVars(getTerm(RP), VDS)
else qidError('\r 'Warning: '\o printSyntaxError(RP, QIL) '\n
'\r 'Error: '\o 'no 'parse 'for QIL '\n)
fi
if M' := addOps(VDS, M)
/\ QIL := downQidList(T)
/\ RP := metaParse(M', QIL, anyType) .
*** The \texttt{solveBubbles1} function is in charge of calling the function
*** \texttt{metaParse}. The flag indicating the inclusion of the module
*** \texttt{META-LEVEL} in the module in which the term appears decides
*** whether the function \texttt{solveUps} is called or not, so the extra
*** price of searching for calls to the \texttt{up} function is paid only
*** when an occurrence of the function is possible. This function takes care
*** of the occurrences of the \texttt{up} function that may exist in such
*** bubbles.
*** The function \texttt{solveUps} goes through the term looking for a term
*** with \texttt{'up} as top operator and \texttt{'token} as top operator of
*** its unique argument if there is only one argument, or with \texttt{'token}
*** and \texttt{'bubble} as top operators of its first and second arguments,
*** respectively, if there are two. If a term of the form
*** \mbox{\texttt{'up['token[T]]}} is reached, it is replaced by the
*** metarepresentation of the flat version of the module in the database with
*** the name given by the token. If a term of form
*** \mbox{\texttt{'up['token[T], 'bubble[T']]}} is reached, the
*** metarepresentation of the result of parsing the bubble in the signature
*** of the module with the name given by the token, after solving possible
*** nested calls to the \texttt{up} function, is returned.
eq solveUps(QI, DB) = QI .
eq solveUps(F[TL], DB) = F[solveUps(TL, DB)] [owise] .
ceq solveUps((T, TL), DB)
= (solveUps(T, DB), solveUps(TL, DB))
if TL =/= empty .
eq solveUps('upModule['token[T]], DB)
= solveUpsModExp('upModule['token[T]], DB) .
eq solveUps('upModule['`(_`)[T]], DB)
= solveUpsModExp('upModule['`(_`)[T]], DB) .
eq solveUps('upModule['_`{_`}[T, T']], DB)
= solveUpsModExp('upModule['_`{_`}[T, T']], DB) .
eq solveUps('upModule['_*`(_`)[T, T']], DB)
= solveUpsModExp('upModule['_*`(_`)[T, T']], DB) .
eq solveUps('upModule['_+_[T, T']], DB)
= solveUpsModExp('upModule['_+_[T, T']], DB) .
eq solveUps('upModule['TUPLE`[_`]['token[T]]], DB)
= solveUpsModExp('upModule['TUPLE`[_`]['token[T]]], DB) .
eq solveUps('upModule['POWER`[_`]['token[T]]], DB)
= solveUpsModExp('upModule['POWER`[_`]['token[T]]], DB) .
eq solveUpsCondition(T = T' /\ Cond, DB)
= solveUps(T, DB) = solveUps(T', DB) /\ solveUpsCondition(Cond, DB) .
eq solveUpsCondition(T : S /\ Cond, DB)
= solveUps(T, DB) : S /\ solveUpsCondition(Cond, DB) .
eq solveUpsCondition(T := T' /\ Cond, DB)
= T := solveUps(T', DB) /\ solveUpsCondition(Cond, DB) .
eq solveUpsCondition(T => T' /\ Cond, DB)
= solveUps(T, DB) => solveUps(T', DB) /\ solveUpsCondition(Cond, DB) .
eq solveUpsCondition(nil, DB) = nil .
ceq solveUpsModExp('upModule[T], DB)
= up(getFlatModule(MN, DB'))
if < DB' ; MN > := evalModExp(parseModExp(T), DB)
/\ unitInDb(MN, DB') .
ceq solveUpsModExp('upModule[T], DB)
= qidError('\r 'Error: '\o 'Module header2QidList(MN) 'not 'in 'database. '\n)
if MN := parseModExp(T)
[owise] .
eq solveUps('upTerm['token[T], 'bubble[T']], DB)
= solveUpsModExp('upTerm['token[T], 'bubble[T']], DB) .
eq solveUps('upTerm['`(_`)[T], 'bubble[T']], DB)
= solveUpsModExp('upTerm['`(_`)[T], 'bubble[T']], DB) .
eq solveUps('upTerm['_`{_`}[T, T'], 'bubble[T']], DB)
= solveUpsModExp('upTerm['_`{_`}[T, T'], 'bubble[T']], DB) .
eq solveUps('upTerm['_*`(_`)[T, T'], 'bubble[T']], DB)
= solveUpsModExp('upTerm['_*`(_`)[T, T'], 'bubble[T']], DB) .
eq solveUps('upTerm['_+_[T, T'], 'bubble[T']], DB)
= solveUpsModExp('upTerm['_+_[T, T'], 'bubble[T']], DB) .
eq solveUps('upTerm['TUPLE`[_`]['token[T]], 'bubble[T']], DB)
= solveUpsModExp('upTerm['TUPLE`[_`]['token[T]], 'bubble[T']], DB) .
eq solveUps('upTerm['POWER`[_`]['token[T]], 'bubble[T']], DB)
= solveUpsModExp('upTerm['POWER`[_`]['token[T]], 'bubble[T']], DB) .
ceq solveUpsModExp('upTerm[T, 'bubble[T']], DB)
= if included('META-MODULE, getImports(getInternalModule(MN, DB')), DB')
then if metaParse(U, QIL, anyType) :: ResultPair
then up(solveUps(getTerm(metaParse(U, QIL, anyType)), DB'))
else qidError('\r 'Warning: '\o
'No 'parse 'for 'argument 'of 'up
printSyntaxError(metaParse(U, QIL, anyType), QIL)
'\n)
fi
else if metaParse(U, QIL, anyType) :: ResultPair
then up(getTerm(metaParse(U, QIL, anyType)))
else qidError('\r 'Warning: '\o
'No 'parse 'for 'argument 'of 'up
printSyntaxError(metaParse(U, QIL, anyType), QIL)
'\n)
fi
fi
if < DB' ; MN > := evalModExp(parseModExp(T), DB)
/\ U := getFlatModule(MN, DB')
/\ QIL := downQidList(T').
ceq solveUpsModExp('upTerm[T, 'bubble[T']], DB)
= qidError('\r 'Error: 'op '\o 'Module header2QidList(ME) 'not 'in 'database. '\n)
if ME := parseModExp(T)
[owise] .
eq solveUps('`[_`][QI], DB) = '`[_`][QI] .
ceq solveUps('`[_`]['token[T]], DB)
= up(getFlatModule(QI, database(evalModExp(QI, DB))))
if QI := downQid(T) .
eq solveUps('`[_`][F[TL]], DB) = '`[_`][F[solveUps(TL, DB)]] [owise] .
endfm
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
***
*** Parsing the Bubbles in a Module
***
*** The \texttt{solveBubbles} function defined in the
*** \texttt{UNIT-BUBBLE-PARSING} module takes a term of sort \texttt{Module} (a
*** preunit in fact) and a signature, and returns the unit resulting from the
*** evaluation (parsing) of all the bubbles in it.
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
view AttrSet from TRIV to META-LEVEL is
sort Elt to AttrSet .
endv
fmod UNIT-BUBBLE-PARSING is
pr BUBBLE-PARSING .
pr DATABASE .
pr MOVE-UP .
pr MOVE-DOWN .
pr PRINT-SYNTAX-ERROR .
vars T T' T'' T3 T4 : Term .
vars T? T?' : [Term] .
vars TL TL' TL'' : TermList .
vars TL? TL?' : [TermList] .
var B : Bool .
vars M M' M'' : Module .
var DB : Database .
vars PU U U' : Module .
var K : Kind .
var KS : KindSet .
vars S S' : Sort .
var SS : SortSet .
var VE : ViewExp .
vars Ty Ty' Tp : Type .
vars TyL TyL' : TypeList .
var At : Attr .
vars AtS AtS' AtS'' : AttrSet .
var NL : IntList .
var QI QI' QI'' QI3 QI4 QI5 F L : Qid .
vars QIL QIL' : QidList .
var I : Nat .
var Hk : Hook .
var HkL : HookList .
var MAS : MembAxSet .
var Eq : Equation .
var EqS : EquationSet .
var Rl : Rule .
var RlS : RuleSet .
var OPD : OpDecl .
vars OPDS OPDS' OPDS'' VDS : OpDeclSet .
var CD? : [Condition] .
var Ct : Constant .
var RP : [ResultPair] .
var St : String .
*** In the parsing of bubbles themselves, we consider three different cases:
*** The case of having one single bubble in which no context is
*** considered (used to parse bubbles in term maps in views and in the
*** special attributes of operators); the case of two bubbles to be parsed in
*** the same connected component (used for bubbles in equations and rules),
*** and the case of one bubble to be parsed in a specific sort (used for the
*** bubbles appearing in the identity element attributes in the declarations
*** of operators, and in membership axioms). These three cases are reduced to
*** the case of one single bubble without context, which is handled by the
*** function \texttt{solveBubbles3}.
op solveBubblesEq : Term Term Module Bool OpDeclSet Database -> Term .
op solveBubblesCEq : Term Term Module Bool OpDeclSet Database -> Term .
op solveBubblesRl : Term Term Module Bool OpDeclSet Database -> Term .
op solveBubblesCRl : Term Term Module Bool OpDeclSet Database -> Term .
op solveBubbles2 : Term [Type] Module Bool OpDeclSet Database -> Term .
op solveBubblesCond : Term Module Module Bool OpDeclSet Database -> [Condition] .
op conditionError : QidList -> [Condition] [ctor format (r o)] .
*** The case of two bubbles, generated in the case of equations and rules, is
*** reduced to the case with one single bubble using the polymorphic operator
*** \verb~_==_~ and enclosing each of the bubbles in parentheses. Below, we
*** shall see how after calling this function the terms corresponding to each
*** of the bubbles is extracted.
ceq solveBubblesEq('bubble[T], 'bubble[T'], M, B, VDS, DB)
= if RP :: ResultPair
then if B
then solveUps(constsToVars(getTerm(RP), VDS), DB)
else constsToVars(getTerm(RP), VDS)
fi
else qidError('\r 'Warning:
'\o printSyntaxError(RP, '`( QIL '`) '= '`( QIL' '`)) '\n
'\r 'Error: '\o 'no 'parse 'for 'eq QIL '\s '~ '\s QIL' '\n)
fi
if M' := addOps((VDS
op '_=_ : 'Universal 'Universal -> '@@@ [poly(1 2)] .),
addSorts('@@@, M))
/\ QIL := downQidList(T)
/\ QIL' := downQidList(T')
/\ RP := metaParse(M', '`( QIL '`) '= '`( QIL' '`), '@@@) .
ceq solveBubblesCEq('bubble[T], 'bubble[T'], M, B, VDS, DB)
= if RP :: ResultPair
then if B
then solveUps(constsToVars(getTerm(RP), VDS), DB)
else constsToVars(getTerm(RP), VDS)
fi
else qidError('\r 'Warning:
'\o printSyntaxError(RP, '`( QIL '`) '= '`( QIL' '`)) '\n
'\r 'Error: '\o 'no 'parse 'for 'ceq QIL '\s '~ '\s QIL' '\n)
fi
if M' := addOps((VDS
op '_=_ : 'Universal 'Universal -> '@@@ [poly(1 2)] .),
addSorts('@@@, M))
/\ QIL := downQidList(T)
/\ QIL' := downQidList(T')
/\ RP := metaParse(M', '`( QIL '`) '= '`( QIL' '`), '@@@) .
ceq solveBubblesRl('bubble[T], 'bubble[T'], M, B, VDS, DB)
= if RP :: ResultPair
then if B
then solveUps(constsToVars(getTerm(RP), VDS), DB)
else constsToVars(getTerm(RP), VDS)
fi
else qidError('\r 'Warning:
'\o printSyntaxError(RP, '`( QIL '`) '=> '`( QIL' '`)) '\n
'\r 'Error: '\o 'no 'parse 'for 'rl QIL '\s '=> '\s QIL' '\n)
fi
if M' := addOps((VDS
op '_=>_ : 'Universal 'Universal -> '@@@ [poly(1 2)] .),
addSorts('@@@, M))
/\ QIL := downQidList(T)
/\ QIL' := downQidList(T')
/\ RP := metaParse(M', '`( QIL '`) '=> '`( QIL' '`), '@@@) .
ceq solveBubblesCRl('bubble[T], 'bubble[T'], M, B, VDS, DB)
= if RP :: ResultPair
then if B
then solveUps(constsToVars(getTerm(RP), VDS), DB)
else constsToVars(getTerm(RP), VDS)
fi
else qidError('\r 'Warning:
'\o printSyntaxError(RP, '`( QIL '`) '=> '`( QIL' '`)) '\n
'\r 'Error: '\o 'no 'parse 'for 'crl QIL '\s '=> '\s QIL' '\n)
fi
if M' := addOps((VDS
op '_=>_ : 'Universal 'Universal -> '@@@ [poly(1 2)] .),
addSorts('@@@, M))
/\ QIL := downQidList(T)
/\ QIL' := downQidList(T')
/\ RP := metaParse(M', '`( QIL '`) '=> '`( QIL' '`), '@@@) .
ceq solveBubbles2('bubble[T], T?:Type?, M, true, VDS, DB)
= if RP :: ResultPair
then solveUps(constsToVars(getTerm(RP), VDS), DB)
else qidError('\r 'Warning:
'\o printSyntaxError(RP, QIL) '\n
'\r 'Error: 'No 'parse 'for QIL '\n)
fi
if QIL := downQidList(T)
/\ RP := metaParse(M, QIL, T?:Type?) .
ceq solveBubbles2('bubble[T], T?:Type?, M, false, VDS, DB)
= if RP :: ResultPair
then constsToVars(getTerm(RP), VDS)
else qidError('\r 'Warning: '\o printSyntaxError(RP, QIL) '\n
'\r 'Error: 'No 'parse 'for QIL '\n)
fi
if QIL := downQidList(T)
/\ RP := metaParse(M, QIL, T?:Type?) .
op addInfoConds : Module -> [Module] .
op addInfoConds : Module SortSet -> Module .
eq addInfoConds(M) = addInfoConds(M, getAllSorts(M)) .
eq addInfoConds(M, '@Token@ ; SS) = addInfoConds(M, SS) .
eq addInfoConds(M, '@Bubble@ ; SS) = addInfoConds(M, SS) .
eq addInfoConds(M, S ; SS)
= addInfoConds(
addOps(op qid(string(S)) : nil -> '@Sort@ [ctor] .
op '_:_ : S '@Sort@ -> '@Condition@ [ctor prec(71)] ., M),
SS)
[owise] .
eq addInfoConds(M, none)
= addOps(op '_/\_ : '@Condition@ '@Condition@ -> '@Condition@
[ctor assoc prec(73)] .
op '_=_ : 'Universal 'Universal -> '@Condition@
[ctor poly(1 2) prec(71)] .
op '_:=_ : 'Universal 'Universal -> '@Condition@
[ctor poly(1 2) prec(71)] .
op '_=>_ : 'Universal 'Universal -> '@Condition@
[ctor poly(1 2) prec(71)] .,
addSorts('@Condition@ ; '@Sort@,
if 'Bool in getSorts(M)
then addSubsorts(subsort 'Bool < '@Condition@ ., M)
else M
fi)) .
ceq solveBubblesCond('bubble[T], M, M', B, VDS, DB)
= if 'Bool in getSorts(M)
and-then metaParse(M, QIL, 'Bool) :: ResultPair
then if B
then solveUps(constsToVars(getTerm(metaParse(M, QIL, 'Bool)), VDS), DB)
= 'true.Bool
else constsToVars(getTerm(metaParse(M, QIL, 'Bool)), VDS)
= 'true.Bool
fi
else if metaParse(M', QIL, '@Condition@) :: ResultPair
then if B
then solveUpsCondition(
parseCond(getTerm(metaParse(M', QIL, '@Condition@)), VDS), DB)
else parseCond(getTerm(metaParse(M', QIL, '@Condition@)), VDS)
fi
else conditionError('\r 'Warning: '\o
printSyntaxError(metaParse(M', QIL, '@Condition@), QIL) '\n)
fi
fi
if QIL := downQidList(T) .
op parseCond : Term OpDeclSet -> Condition .
eq parseCond('_/\_[T, T'], VDS) = parseCond(T, VDS) /\ parseCond(T', VDS) .
eq parseCond('_=_[T, T'], VDS)
= constsToVars(T, VDS) = constsToVars(T', VDS) .
eq parseCond('_:_[T, T'], VDS) = constsToVars(T, VDS) : getName(T') .
eq parseCond('_:=_[T, T'], VDS)
= constsToVars(T, VDS) := constsToVars(T', VDS) .
eq parseCond('_=>_[T, T'], VDS)
= constsToVars(T, VDS) => constsToVars(T', VDS) .
eq parseCond(T, VDS) = constsToVars(T, VDS) = 'true.Bool [owise] .
*** Since bubbles can only appear in the identity or special attributes in the
*** declaration of operators, in equations, membership axioms, and rules, the
*** evaluation of bubbles on a preunit is reduced to calls to the
*** \texttt{solveBubbles} functions on each of these sTS of declarations.
op solveBubblesMod : Module OpDeclSet Module Bool OpDeclSet Database -> Module .
op solveBubbles : EquationSet Module [Module] Bool OpDeclSet Database -> EquationSet .
op solveBubbles : RuleSet Module [Module] Bool OpDeclSet Database -> RuleSet .
op solveBubbles : MembAxSet Module [Module] Bool OpDeclSet Database -> MembAxSet .
op solveBubbles : Condition Module Bool OpDeclSet Database -> Condition .
op solveBubblesOps : OpDeclSet OpDeclSet Module Module -> OpDeclSet .
op solveBubblesOps : OpDeclSet OpDeclSet Module -> OpDeclSet .
op solveBubblesOpsAux : OpDeclSet Module -> OpDeclSet .
op solveBubblesAts : AttrSet TypeList Type Module -> AttrSet .
op solveBubblesHooks : HookList Type Module -> HookList .
ceq solveBubblesMod(PU, OPDS, M, B, VDS, DB)
= setOps(
(if getMbs(PU) == none and getEqs(PU) == none and getRls(PU) == none
then PU
else setEqs(
setMbs(
setRls(PU,
solveBubbles(getRls(PU), M', addInfoConds(M'), B, VDS, DB)),
solveBubbles(getMbs(PU), M', addInfoConds(M'), B, VDS, DB)),
solveBubbles(getEqs(PU), M', addInfoConds(M'), B, VDS, DB))
fi),
solveBubblesOps(getOps(PU), OPDS, M'))
if M' := addOps(VDS, M) .
*** To avoid the parsing ambiguities in the identity elements we add the sort
*** of the operator to be used as context in which doing the parsing. We
*** assume that the term given as identity element of an operator is in the
*** kind of the sort of such operator.
eq solveBubblesOps(OPDS, OPDS', M)
= solveBubblesOps(OPDS, OPDS',
setSubsorts(
setSorts(emptyFModule('DUMMY), getSorts(M)), getSubsorts(M)), M) .
ceq solveBubblesOps(op F : TyL -> Ty [ditto AtS] . op F : TyL' -> Ty' [AtS'] . OPDS, OPDS', M, M')
= solveBubblesOps(
op F : TyL -> Ty [AtS removeCtorMetadata(AtS'')] . op F : TyL' -> Ty' [AtS''] . OPDS,
OPDS', M, M')
if not ditto in AtS'
/\ sameKind(M, TyL Ty, TyL' Ty')
---- /\ AtS'' := solveBubblesAts(AtS', TyL', Ty', M') .
/\ AtS'' := AtS' .
ceq solveBubblesOps(op F : TyL -> Ty [ditto AtS] . OPDS, op F : TyL' -> Ty' [AtS'] . OPDS', M, M')
= solveBubblesOps(op F : TyL -> Ty [AtS removeCtorMetadata(AtS'')] . OPDS, op F : TyL' -> Ty' [AtS''] . OPDS', M, M')
if not ditto in AtS'
/\ sameKind(M, TyL Ty, TyL' Ty')
---- /\ AtS'' := solveBubblesAts(AtS', TyL, Ty, M')
/\ AtS'' := AtS' .
---- [owise] .
eq solveBubblesOps(OPDS, OPDS', M, M')
= solveBubblesOpsAux(OPDS, M')
[owise] .
op removeCtorMetadata : AttrSet -> AttrSet .
eq removeCtorMetadata(ctor AtS) = removeCtorMetadata(AtS) .
eq removeCtorMetadata(metadata(St) AtS) = removeCtorMetadata(AtS) .
eq removeCtorMetadata(AtS) = AtS [owise] .
eq solveBubblesOpsAux(op F : TyL -> Ty [AtS] . OPDS, M)
= op F : TyL -> Ty [solveBubblesAts(AtS, TyL, Ty, M)] .
solveBubblesOpsAux(OPDS, M) .
eq solveBubblesOpsAux(none, M) = none .
eq solveBubblesAts(id('bubble[T]) AtS, TyL, Ty, M)
= (id(solveBubbles2('bubble[T], Ty, M, false, none, emptyDatabase))
solveBubblesAts(AtS, TyL, Ty, M)) .
eq solveBubblesAts(left-id('bubble[T]) AtS, Ty TyL, Ty', M)
= (left-id(solveBubbles2('bubble[T], Ty, M, false, none, emptyDatabase))
solveBubblesAts(AtS, Ty TyL, Ty', M)) .
eq solveBubblesAts(right-id('bubble[T]) AtS, TyL Ty, Ty', M)
= (right-id(solveBubbles2('bubble[T], Ty, M, false, none, emptyDatabase))
solveBubblesAts(AtS, TyL Ty, Ty', M)) .
eq solveBubblesAts(special(HkL) AtS, TyL, Ty, M)
= (special(solveBubblesHooks(HkL, Ty, M))
solveBubblesAts(AtS, TyL, Ty, M)) .
eq solveBubblesAts(AtS, TyL, Ty, M) = AtS [owise] .
eq solveBubblesHooks(term-hook(QI, 'bubble[T]) HkL, Ty, M)
= term-hook(QI,
solveBubbles2('bubble[T], anyType, M, false, none, emptyDatabase))
solveBubblesHooks(HkL, Ty, M) .
eq solveBubblesHooks(Hk HkL, Ty, M)
= Hk solveBubblesHooks(HkL, Ty, M)
[owise] .
eq solveBubblesHooks(nil, Ty, M) = nil .
*** Since both sides of any equation or rule have to be in the same connected
*** component of sorts, we parse the two bubbles together using the
*** polymorphic operator \verb~_==_~\footnote{Note that if including
*** \texttt{BOOL} the operator \texttt{\_\,==\_\,} is added for each kind.}.
*** That is, given for example an equation as \verb~eq T = T' .~, we parse
*** \verb~T == T'~, forcing them to be parsed in the same connected component,
*** if possible. We add functions \texttt{lhs} and \texttt{rhs} to extract,
*** respectively, the lefthand and righthand side terms from the result. Note
*** that these are partial functions.
pr 2TUPLE{Term,AttrSet}
* (op p1_ to term, op p2_ to attrSet,
op `(_`,_`) : Term AttrSet -> Tuple{Term,AttrSet} to `{_`,_`}) .
op pullStmtAttrOut : Term OpDeclSet -> [Tuple{Term,AttrSet}] .
op pullStmtAttrOutAux : Term TermList AttrSet OpDeclSet -> [Tuple{Term,AttrSet}] .
op pullLabelOut : Term -> [Tuple{Term,AttrSet}] .
eq pullStmtAttrOut('bubble[QI], VDS) = {'bubble[QI], none} .
eq pullStmtAttrOut('bubble['__[QI, QI']], VDS) = {'bubble['__[QI, QI']], none} .
eq pullStmtAttrOut('bubble['__[QI, QI', QI'']], VDS)
= {'bubble['__[QI, QI', QI'']], none} .
eq pullStmtAttrOut('bubble['__[QI, QI', TL, QI'']], VDS)
= if QI'' =/= ''`].Qid
then {'bubble['__[QI, QI', TL, QI'']], none}
else pullStmtAttrOutAux('bubble['__[QI, QI', TL, QI'']], (QI, QI', TL), none, VDS)
fi .
eq pullStmtAttrOutAux(T, (TL, ''`[.Qid), AtS, VDS)
= if AtS =/= none
then {'bubble['__[TL]], AtS}
else {T, none}
fi .
eq pullStmtAttrOutAux(T, (TL, QI, ''nonexec.Qid), AtS, VDS)
= pullStmtAttrOutAux(T, (TL, QI), AtS nonexec, VDS) .
eq pullStmtAttrOutAux(T, (TL, QI, ''variant.Qid), AtS, VDS)
= pullStmtAttrOutAux(T, (TL, QI), AtS variant, VDS) .
eq pullStmtAttrOutAux(T, (TL, QI, ''owise.Qid), AtS, VDS)
= pullStmtAttrOutAux(T, (TL, QI), AtS owise, VDS) .
eq pullStmtAttrOutAux(T, (TL, QI, ''otherwise.Qid), AtS, VDS)
= pullStmtAttrOutAux(T, (TL, QI), AtS owise, VDS) .
eq pullStmtAttrOutAux(T, (TL, QI, ''label.Qid, QI'), AtS, VDS)
= if downQid(QI') :: Qid
then pullStmtAttrOutAux(T, (TL, QI), AtS label(downQid(QI')), VDS)
else {T, none}
fi .
eq pullStmtAttrOutAux(T, (TL, QI, ''metadata.Qid, QI'), AtS, VDS)
= if downString(downQid(QI')) :: String
then pullStmtAttrOutAux(T, (TL, QI), AtS metadata(downString(downQid(QI'))), VDS)
else {T, none}
fi .
ceq pullStmtAttrOutAux(T, (TL, QI, ''`[.Qid, TL', ''print.Qid, TL''), AtS, VDS)
= pullStmtAttrOutAux(T, (TL, QI, ''`[.Qid, TL'), AtS print(printArg(TL'', VDS)), VDS)
if printArg(TL'', VDS) : QidList .
eq pullStmtAttrOutAux(T, TL, AtS, VDS) = {T, none} [owise] .
op printArg : TermList OpDeclSet ~> QidList .
ceq printArg((T, TL), op QI : nil -> Tp [AtS] . VDS)
= qid(string(downQid(T)) + ":" + string(Tp)) printArg(TL, VDS)
if QI = downQid(T) .
ceq printArg((T, TL), VDS)
= downQid(T) printArg(TL, VDS)
if downString(downQid(T)) : String .
eq printArg(empty, VDS) = nil .
eq pullLabelOut('bubble[QI]) = {'bubble[QI], none} .
eq pullLabelOut('bubble['__[QI, QI']]) = {'bubble['__[QI, QI']], none} .
eq pullLabelOut('bubble['__[QI, QI', QI'']])
= {'bubble['__[QI, QI', QI'']], none} .
eq pullLabelOut('bubble['__[QI, QI', QI'', QI3]])
= {'bubble['__[QI, QI', QI'', QI3]], none} .
eq pullLabelOut('bubble['__[QI, QI', QI'', QI3, TL]])
= if QI == ''`[.Qid and-then (QI'' == ''`].Qid and-then QI3 == '':.Qid)
then {'bubble['__[TL]], label(downQid(QI'))}
else {'bubble['__[QI, QI', QI'', QI3, TL]], none}
fi .
ops lhs rhs : Term -> Term .
eq lhs('_=_[T, T']) = T .
eq lhs('_=>_[T, T']) = T .
eq rhs('_=_[T, T']) = T' .
eq rhs('_=>_[T, T']) = T' .
eq lhs(qidError(QIL)) = qidError(QIL) .
eq rhs(qidError(QIL)) = qidError(QIL) .
eq solveBubbles(EqS, M, unitError(QIL), B, VDS, DB) = equationError(QIL) .
eq solveBubbles(RlS, M, unitError(QIL), B, VDS, DB) = ruleError(QIL) .
eq solveBubbles(MAS, M, unitError(QIL), B, VDS, DB) = membAxError(QIL) .
eq solveBubbles(((eq T = T' [AtS] .) EqS), M, M', B, VDS, DB)
= ((eq lhs(solveBubblesEq(term(pullLabelOut(T)), term(pullStmtAttrOut(T', VDS)),
M, B, VDS, DB))
= rhs(solveBubblesEq(term(pullLabelOut(T)), term(pullStmtAttrOut(T', VDS)),
M, B, VDS, DB))
[attrSet(pullLabelOut(T)) attrSet(pullStmtAttrOut(T', VDS)) AtS] .)
solveBubbles(EqS, M, M', B, VDS, DB)) .
eq solveBubbles(((ceq T = T' if T'' = 'true.Bool [AtS] .) EqS),
M, M', B, VDS, DB)
= ((ceq lhs(solveBubblesCEq(term(pullLabelOut(T)), T', M, B, VDS, DB))
= rhs(solveBubblesCEq(term(pullLabelOut(T)), T', M, B, VDS, DB))
if solveBubblesCond(term(pullStmtAttrOut(T'', VDS)), M, M', B, VDS, DB)
[attrSet(pullLabelOut(T)) attrSet(pullStmtAttrOut(T'', VDS)) AtS] .)
solveBubbles(EqS, M, M', B, VDS, DB)) .
eq solveBubbles((none).EquationSet, M, M', B, VDS, DB) = none .
eq solveBubbles(((rl T => T' [AtS] .) RlS), M, M', B, VDS, DB)
= ((rl lhs(solveBubblesRl(term(pullLabelOut(T)),
term(pullStmtAttrOut(T', VDS)), M, B, VDS, DB))
=> rhs(solveBubblesRl(term(pullLabelOut(T)),
term(pullStmtAttrOut(T', VDS)), M, B, VDS, DB))
[attrSet(pullLabelOut(T)) attrSet(pullStmtAttrOut(T', VDS)) AtS] .)
solveBubbles(RlS, M, M', B, VDS, DB)) .
eq solveBubbles(
((crl T => T' if T'' = 'true.Bool [AtS] .) RlS), M, M', B, VDS, DB)
= ((crl lhs(solveBubblesCRl(term(pullLabelOut(T)), T', M, B, VDS, DB))
=> rhs(solveBubblesCRl(term(pullLabelOut(T)), T', M, B, VDS, DB))
if solveBubblesCond(term(pullStmtAttrOut(T'', VDS)), M, M', B, VDS, DB)
[attrSet(pullLabelOut(T)) attrSet(pullStmtAttrOut(T'', VDS)) AtS] .)
solveBubbles(RlS, M, M', B, VDS, DB)) .
eq solveBubbles((none).RuleSet, M, M', B, VDS, DB) = none .
*** In the call to solve the bubbles in membership axioms we add the sort to
*** which it is constrained to be used as context.
eq solveBubbles(((mb T : S [AtS] .) MAS), M, M', B, VDS, DB)
= ((mb solveBubbles2(term(pullLabelOut(T)), S, M, B, VDS, DB) : S
[attrSet(pullLabelOut(T)) AtS] .)
solveBubbles(MAS, M, M', B, VDS, DB)) .
eq solveBubbles(((cmb T : S if T' = 'true.Bool [AtS] .) MAS),
M, M', B, VDS, DB)
= ((cmb solveBubbles2(term(pullLabelOut(T)), S, M, B, VDS, DB) : S
if solveBubblesCond(T', M, M', B, VDS, DB)
[attrSet(pullLabelOut(T)) AtS] .)
solveBubbles(MAS, M, M', B, VDS, DB)) .
eq solveBubbles((none).MembAxSet, M, M', B, VDS, DB) = none .
*** The parsing process may generate error terms. Since in the
*** current version of the system Core Maude is generating the appropriate
*** error messages, we just have to worry about the elimination of these
*** terms. The effect is the same one as introducing a module at the object
*** level of Core Maude: If there is any term in an identity attribute in an
*** operator declaration, equation, rule, or membership axiom with a parsing
*** error a message is generated and the axiom is eliminated.
eq (op F : TyL -> Ty [id(qidError(QIL)) AtS] .) = opDeclError(QIL) .
eq (op F : TyL -> Ty [left-id(qidError(QIL)) AtS] .) = opDeclError(QIL) .
eq (op F : TyL -> Ty [right-id(qidError(QIL)) AtS] .) = opDeclError(QIL) .
eq (conditionError(QIL) /\ T = T' /\ CD?) = conditionError(QIL) .
eq (conditionError(QIL) /\ T : S /\ CD?) = conditionError(QIL) .
eq (conditionError(QIL) /\ T := T' /\ CD?) = conditionError(QIL) .
eq (conditionError(QIL) /\ T => T' /\ CD?) = conditionError(QIL) .
eq (eq qidError(QIL) = T? [AtS] .) = equationError(QIL) .
eq (eq T? = qidError(QIL) [AtS] .) = equationError(QIL) .
eq (ceq qidError(QIL) = T? if CD? [AtS] .) = equationError(QIL) .
eq (ceq T? = qidError(QIL) if CD? [AtS] .) = equationError(QIL) .
eq (ceq T? = T?' if conditionError(QIL) [AtS] .) = equationError(QIL) .
eq (mb qidError(QIL) : S [AtS] .) = membAxError(QIL) .
eq (cmb qidError(QIL) : S if CD? [AtS] .) = membAxError(QIL) .
eq (cmb T? : S if conditionError(QIL) [AtS] .) = membAxError(QIL) .
eq (rl qidError(QIL) => T? [AtS] .) = ruleError(QIL) .
eq (rl T? => qidError(QIL) [AtS] .) = ruleError(QIL) .
eq (crl qidError(QIL) => T? if CD? [AtS] .) = ruleError(QIL) .
eq (crl T? => qidError(QIL) if CD? [AtS] .) = ruleError(QIL) .
eq (crl T? => T?' if conditionError(QIL) [AtS] .) = ruleError(QIL) .
eq F[qidError(QIL), TL?] = qidError(QIL) .
eq F[TL?, qidError(QIL)] = qidError(QIL) .
eq F[TL?, qidError(QIL), TL?'] = qidError(QIL) .
endfm
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
*** The function \texttt{solveBubbles} defined in the following
*** \texttt{VIEW-BUBBLE-PARSING} module parses the bubbles in a set of preview
*** maps. It takes two modules, the signature of the view's source theory,
*** with the variables declared in the view, to parse the source term in the
*** term maps, and the target theory, with the mappings of the variable
*** declarations in the view, to parse the target terms.
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
fmod VIEW-BUBBLE-PARSING is
pr BUBBLE-PARSING .
pr PRE-VIEW .
var PVMAPS : Set{PreViewMap} .
var VMAP : ViewMap .
vars T T' : Term .
vars M M' : Module .
var U : Module .
var QIL : QidList .
vars VDS VDS' : OpDeclSet .
op solveBubbles : Set{PreViewMap} OpDeclSet OpDeclSet Module Module -> RenamingSet .
eq solveBubbles(PVMAPS, VDS, VDS', U, unitError(QIL)) = none .
eq solveBubbles(PVMAPS, VDS, VDS', unitError(QIL), U) = none .
eq solveBubbles(VMAP, VDS, VDS', M, M') = VMAP [owise] .
eq solveBubbles((VMAP, PVMAPS), VDS, VDS', M, M')
= (VMAP, solveBubbles(PVMAPS, VDS, VDS', M, M'))
[owise] .
eq solveBubbles(preTermMap(T, T'), VDS, VDS', M, M')
= termMap(
solveBubbles(T, M, false, VDS, emptyDatabase),
solveBubbles(T', M', false, VDS', emptyDatabase)) .
eq solveBubbles((preTermMap(T, T'), PVMAPS), VDS, VDS', M, M')
= (termMap(
solveBubbles(T, M, false, VDS, emptyDatabase),
solveBubbles(T', M', false, VDS', emptyDatabase)),
solveBubbles(PVMAPS, VDS, VDS', M, M')) .
eq solveBubbles(none, VDS, VDS', M, M') = none .
endfm
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
***
*** Module Expression Evaluation
***
*** So far we have not introduced more module expressions than those given by
*** simple quoted identifiers. We will introduce some later, but the scheme
*** followed for evaluating them is very simple and can be presented in a
*** generic way. Given a module expression and a database state, the
*** evaluation of a module expression results in the generation of a new
*** module, which is introduced in the database, with the module expression
*** as its name. The resulting database is then returned. If there is already
*** a module in the database with that name, the function returns the original
*** database without any change. The evaluation of a module expression may
*** produce the evaluation of other module expressions contained in the
*** modules involved in the process. This is the case, for example, for the
*** renaming of modules, in which not only the top module is renamed but,
*** perhaps, some of its submodules as well; it is also the case for the
*** instantiation of parameterized modules, where the module being
*** instantiated may contain submodules which are parameterized by some of
*** the parameter theories of the parameterized module in which are imported.
*** We shall discuss in more detail the renaming and instantiation of module
*** expressions in Sections~\ref{renaming} and~\ref{instantiation},
*** respectively.
*** We saw in Section~\ref{module-expressions} how it is possible to import a
*** module expression in which a parameterized module is instantiated by some
*** of the formal parameters of the parameterized module into which it is
*** imported. To be able to evaluate this kind of module expression, the list
*** of parameters of the module in which the module expression appears has to
*** be given.
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
fmod MOD-EXPR-EVAL is
pr DATABASE .
*** decl. moved to module DATABASE
*** op evalModExp : ModuleExpression Database -> Database .
op evalModExp : ModuleExpression ParameterDeclList Database -> Tuple{Database, ModuleExpression} .
op evalViewExp : ViewExp ParameterDeclList Database -> Database .
op evalViewExp : ParameterList ParameterDeclList Database -> Database .
var S : Sort .
var QI : Qid .
var ME : ModuleExpression .
var PDL : ParameterDeclList .
var DB : Database .
vars VE VE' VE'' : ViewExp .
vars PL PL' : ParameterList .
eq evalModExp(ME, DB) = evalModExp(ME, nil, DB) .
eq evalModExp(ME, PDL, DB) = < DB ; ME > [owise] .
eq evalModExp(QI, PDL, DB)
= if unitInDb(QI, DB)
then if compiledModule(QI, DB)
then < DB ; QI >
else < procModule(QI, DB) ; QI >
fi
else if upModule(QI, false) :: Module
then < procModule(QI, insTermModule(QI, upModule(QI, false), DB)) ; QI >
else < warning(DB, '\r 'Error: '\o 'Module QI 'not 'in 'database. '\n) ; QI >
fi
fi .
eq evalViewExp(QI, PDL, DB)
= if labelInParameterDeclList(QI, PDL)
then DB
else if viewInDb(QI, DB)
then if compiledView(QI, DB)
then DB
else procView(QI, DB)
fi
else warning(DB, ('\r 'Error: '\o 'View QI 'not 'in 'database. '\n))
fi
fi .
eq evalViewExp(S{PL}, PDL, DB)
= if viewInDb(S{PL}, DB)
then DB
else viewInst(S, PL, PDL, evalViewExp(S, PDL, evalViewExp(PL, PDL, DB)))
fi .
ceq evalViewExp(VE ;; VE', PDL, DB)
= evalViewExp(VE, PDL, evalViewExp(VE', PDL, DB))
if VE =/= mtViewExp /\ VE' =/= mtViewExp .
eq evalViewExp((S, PL), PDL, DB)
= evalViewExp(S, PDL, evalViewExp(PL, PDL, DB))
[owise] .
eq evalViewExp((S{PL}, PL'), PDL, DB)
= evalViewExp(S{PL}, PDL, evalViewExp(PL', PDL, DB))
[owise] .
eq evalViewExp(nil, PDL, DB) = DB .
op viewInst : ViewExp ViewExp ParameterDeclList Database -> Database .
*******************************************************************************
*** The equations specifying its behavior are later, in INST-EXPR-EVALUATION **
*******************************************************************************
endfm
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
***
*** The Transformation of Object-Oriented Modules to System Modules
***
*** The transformation of object-oriented modules into system modules has
*** already been discussed in Section~\ref{omod2mod}, and also in
*** \cite{Meseguer93b,ClavelDuranEkerLincolnMarti-OlietMeseguerQuesada99}.
*** We focus here on the part of the process accomplished by each of the main
*** functions involved in the transformation. The transformation discussed
*** in~\cite{DuranMeseguer98} assumed that object-oriented modules were
*** flattened before being transformed into system modules. However, doing it
*** in this way, the transformations already made for the modules in the
*** structure were not reused. In the current system, the transformation is
*** done only for the module being introduced, the top of the structure, and
*** dusing the `internal' representations of the submodules stored in the
*** ddatabase for the rest of the structure.
*** This approach requires gathering all class and subclass relation
*** declarations in the structure before starting with the transformation
*** process itself. The function \texttt{prepClasses} collects all these
*** declarations in the structure, and completes all the declarations of
*** classes with the attributes inherited from their superclasses.
*** \begin{comment}
*** This function makes use of a `dummy' module, in which the classes are
*** introduced as sorts and the subclass relations as subsort relations to be
*** able to compute all the operations on the subclass relation using the
*** built-in functions on sorts.
*** \end{comment}
*** Once all the class declarations in the structure have been collected and
*** completed, the transformation is accomplished in two stages. First, the
*** function \texttt{omod2modAux} carries out the
*** following tasks:
*** \begin{itemize}
*** \item For each class declaration of the form
*** $\texttt{class }C\texttt{ | }a_1\texttt{:} S_1\texttt{,}
*** \ldots\texttt{,} a_n\texttt{:} S_n$, the following items are
*** introduced: a subsort $C$ of sort \texttt{Cid}, a constant
*** $C$ of sort $C$, and declarations of operations $a_i
*** \texttt{\ :\_} \texttt{ :\,\,} S_i \texttt{ -> Attribute}$
*** for each attribute $a_i$ (the function
*** \texttt{ops4Attr} creates these declarations).
*** \item For each subclass relation of the form
*** $\texttt{subclass\ }C\texttt{\ <\ }C'$, a subsort
*** declaration $\texttt{subsort\ }C\texttt{\ <\ }C'$ is
*** introduced.
*** \item For each message declaration of the form \verb~msg F : TyL
*** -> S~, an operator declaration \verb~op F : TyL -> S~ is added.
*** \end{itemize}
*** When this process has been completed, the function \texttt{prepAxs} is
*** called. This function applies to the membership axioms, equations, and
*** rewriting rules in the module the transformations indicated in
*** Section~\ref{omod2mod}, so that they become applicable to all the objects
*** of the given class and of their subclasses. The set of attributes of the
*** objects appearing in the membership axioms, equations, and rewriting rules
*** are completed, so that the default convention of not having to
*** exhaustively mention the set of attributes of a class is supported.
*** Note that in Meseguer's paper~\cite{Meseguer93b} a parallel hierarchy of
*** sorts was defined to deal with objects in different classes, and membership
*** axioms constraining the objects to their corresponding sorts were added.
*** The transformation could be easily completed with sorts, subsort relations,
*** and membership constraints as indicated there. In fact, these declarations
*** were added in an initial version and were then removed because they were
*** computationally expensive. However, there are examples in which it would
*** be interesting to have them; when needed, these declarations can be
*** explicitly added by the user in the current version.
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
fmod EXT-TERMSET is
protecting TERMSET .
op |_| : TermSet -> Nat .
eq | X:Term | T:TermSet | = 1 + | T:TermSet | .
eq | emptyTermSet | = 0 .
endfm
view TermSet from TRIV to EXT-TERMSET is
sort Elt to TermSet .
endv
fmod O-O-TO-SYSTEM-MOD-TRANSF is
pr DATABASE .
pr CONVERSION .
pr EXT-TERMSET .
var DB : Database .
var I : Nat .
var ME : Header .
vars S S' S'' C C' : Sort .
vars SS SS' SS'' : SortSet .
var Ty : Type .
var TyL : TypeList .
vars T T' T'' T3 : Term .
vars TL TL' : TermList .
var PL : ParameterList .
vars IL IL' IL'' : ImportList .
vars CDS CDS' : ClassDeclSet .
vars ADS ADS' : AttrDeclSet .
var SSDS : SubsortDeclSet .
vars SCDS SCDS' : SubclassDeclSet .
var OPDS : OpDeclSet .
var MDS : MsgDeclSet .
vars MAS MAS' : MembAxSet .
vars EqS EqS' : EquationSet .
vars RlS RlS' : RuleSet .
var QIL : QidList .
var NQIL : NeQidList .
vars O O' : Term .
vars M U : Module .
vars QI A A' L F : Qid .
var V V' : Variable .
var CD : ClassDecl .
vars SCD SCD' : SubclassDecl .
vars Ct Ct' Ct'' : Constant .
var Cond : Condition .
var AtS : AttrSet .
var H : Header .
var PD : ParameterDecl .
var PDL : ParameterDeclList .
var MN : ModuleName .
var CH : ClassHierarchy .
var C'' : Sort .
vars TS TS' : TermSet .
op newVar : Sort Nat -> Variable .
eq newVar(S, I) = qid("V#" + string(I, 10) + ":" + string(S)) .
*** The function \texttt{prepClasses} completes all classes in the module with
*** all the attributes they inherit from their superclasses.
op prepClasses : ClassDeclSet SubclassDeclSet ImportList ParameterDeclList
Database -> ClassDeclSet .
op prepClasses2 : ClassDeclSet SubclassDeclSet ImportList
ImportList Database -> ClassDeclSet .
op prepClasses3 : ClassDeclSet SubclassDeclSet -> ClassDeclSet .
eq prepClasses(CDS, SCDS, IL, (PD, PDL), DB)
= prepClasses(CDS, SCDS, (IL protecting pd(PD) .), PDL, DB) .
eq prepClasses(CDS, SCDS, IL, nil, DB)
= prepClasses2(CDS, SCDS, IL, nil, DB) .
eq prepClasses2(CDS, SCDS, ((including MN .) IL), IL', DB)
= if (including MN . ) in IL'
then prepClasses2(CDS, SCDS, IL, IL', DB)
else prepClasses2(
(getClasses(getTopModule(MN, DB)) CDS),
(getSubclasses(getTopModule(MN, DB)) SCDS),
(getImports(getTopModule(MN, DB)) IL),
((including MN .) IL'), DB)
fi .
eq prepClasses2(CDS, SCDS, ((extending MN .) IL), IL', DB)
= if (extending MN . ) in IL'
then prepClasses2(CDS, SCDS, IL, IL', DB)
else prepClasses2(
(getClasses(getTopModule(MN, DB)) CDS),
(getSubclasses(getTopModule(MN, DB)) SCDS),
(getImports(getTopModule(MN, DB)) IL),
((extending MN .) IL'), DB)
fi .
eq prepClasses2(CDS, SCDS, ((protecting MN .) IL), IL', DB)
= if (protecting MN . ) in IL'
then prepClasses2(CDS, SCDS, IL, IL', DB)
else prepClasses2(
(getClasses(getTopModule(MN, DB)) CDS),
(getSubclasses(getTopModule(MN, DB)) SCDS),
(getImports(getTopModule(MN, DB)) IL),
((protecting MN .) IL'), DB)
fi .
eq prepClasses2(CDS, SCDS, nil, IL, DB) = prepClasses3(CDS, SCDS) .
eq prepClasses3(CDS, SCDS)
= addAttrs(buildHierarchy(CDS, SCDS, none, empty), SCDS) .
sort ClassHierarchy ClassStruct .
subsort ClassStruct < ClassHierarchy .
op [_,_] : ClassDecl SortSet -> ClassStruct .
op empty : -> ClassHierarchy .
op __ : ClassHierarchy ClassHierarchy -> ClassHierarchy
[assoc comm id: empty] .
op buildHierarchy :
ClassDeclSet SubclassDeclSet SortSet ClassHierarchy -> ClassHierarchy .
op addAttrs : ClassHierarchy SubclassDeclSet -> ClassDeclSet .
op addAttrsToItsSons :
ClassDecl ClassHierarchy SubclassDeclSet -> ClassHierarchy .
eq buildHierarchy(((class C | ADS .) CDS), SCDS, SS, CH)
= if C in SS
then buildHierarchy(CDS, SCDS, SS, CH)
else buildHierarchy(CDS, SCDS, C ; SS, [(class C | ADS .), none] CH)
fi .
eq buildHierarchy(none, (subclass C < C' .) SCDS, SS,
[(class C | ADS .), SS'] [(class C' | ADS' .), SS''] CH)
= buildHierarchy(none, SCDS, SS,
[(class C | ADS .), C' ; SS'] [(class C' | ADS' .), SS''] CH) .
eq buildHierarchy(none, none, SS, CH) = CH .
eq addAttrs([(class C | ADS .), none] CH, SCDS)
= (class C | ADS .)
addAttrs(addAttrsToItsSons((class C | ADS .), CH, SCDS), SCDS) .
eq addAttrs(empty, SCDS) = none .
eq addAttrsToItsSons((class C | ADS .), [(class C' | ADS' .), C ; SS] CH,
(subclass C' < C .) SCDS)
= addAttrsToItsSons((class C | ADS .), [(class C' | ADS, ADS' .), SS] CH,
SCDS) .
ceq addAttrsToItsSons((class C | ADS .), CH, (subclass C' < C'' .) SCDS)
= addAttrsToItsSons((class C | ADS .), CH, SCDS)
if C =/= C'' .
eq addAttrsToItsSons((class C | ADS .), CH, none) = CH .
---- op inAttrDeclSet : Qid AttrDeclSet -> Bool .
----
---- eq inAttrDeclSet(A, ((attr A' : S), ADS))
---- = (A == A') or-else inAttrDeclSet(A, ADS) .
---- eq inAttrDeclSet(A, none) = false .
*** Given a set of attribute declarations, the \texttt{ops4Attr}
*** function returns a set of operator declarations as indicated above. That
*** is, for each attribute $a\texttt{:} S$, an operator of the form
*** $a \texttt{\ :\_} \texttt{ :\,\,} S \texttt{ -> Attribute}$ is declared.
op ops4Attr : AttrDeclSet -> OpDeclSet .
eq ops4Attr(((attr A : S), ADS))
= ((op qid(string(A) + "`:_") : S -> 'Attribute [gather('&)] .)
ops4Attr(ADS)) .
eq ops4Attr(none) = none .
*** The function \texttt{prepLHS} takes the term in the lefthand side of a
*** rule, equation, or membership axiom, and replaces each object
***
*** $\texttt{<\ }O\texttt{\ :\ }C\texttt{\ |\ }ADS\texttt{\ >}$
***
*** in it---with $O$ of sort \texttt{Oid}, $C$ the name of a class, and $ADS$
*** a set of attributes with their corresponding values---by an object
***
*** $\texttt{<\ }O\texttt{\ :\ }V\texttt{\ |\ }ADS\ ADS'\ Atts\texttt{\ >}$
***
*** where the identifier of the class is replaced by a variable $V$ of sort
*** $C$, which is not used in the axiom, and where the set of attributes is
*** completed with attributes $ADS'$ as indicated in Section~\ref{omod2mod}, so
*** that each attribute declared in class $C$ or in any of its superclasses is
*** added with a new variable as value. $Atts$ is a new variable of sort
*** \texttt{AttributeSet}, which is used to range over the additional
*** attributes that may appear in objects of a subclass.
*** The function \texttt{prepLHS} takes as arguments a term (in the initial
*** call, the term in the lefthand side of a rule, equation, or membership
*** axiom), the set of variable declarations of those variables declared in the
*** module that are not used in the axiom---new variables are created only if
*** there are no variables in the module with the appropriate sort---the set of
*** attributes in the* occurrences of the objects---and an index---to make sure
*** that the variables being added have not occurrences of the objects---and an
*** index---to make sure that the variables being added have not been added
*** previously. In the initial call this index is set to zero. \texttt{prepLHS}
*** gives as result a tuple composed of the resulting term, the set of objects
*** in the term (so that the modification of the objects in the righthand side
*** of the rule is simplified), the set of variable declarations corresponding
*** to the new added variables, the set of variable declarations of the
*** variables in the module that have not been used, and the index for the
*** creation of new variables.
*** change (03/20/2002): a new variable is created everytime one is needed
*** The set of objects in the lefthand side will be given as a set of terms.
pr 4TUPLE{TermList, TermSet, Nat, QidList}
* (op p1_ to term, op p2_ to objects, op p3_ to index, op p4_ to messages,
op ((_,_,_,_)) : TermList TermSet Nat QidList -> Tuple{TermList,TermSet,Nat,QidList} to <_;_;_;_>) .
op prepLHS : TermList ClassDeclSet Nat -> Tuple{TermList, TermSet, Nat, QidList} .
op crtObject : Term Sort AttrDeclSet Tuple{TermList, TermSet, Nat, QidList} -> Tuple{TermList, TermSet, Nat, QidList} .
op crtObject2 : Term Variable TermList TermList AttrDeclSet TermSet Nat QidList -> Tuple{TermList, TermSet, Nat, QidList} .
op crtObject3 : Term Qid TermList AttrDeclSet TermSet Nat QidList -> Tuple{TermList, TermSet, Nat, QidList} .
eq prepLHS(qidError(QIL), CDS, I) = < qidError(QIL) ; emptyTermSet ; I ; nil > .
eq prepLHS(F, CDS, I) = < F ; emptyTermSet ; I ; nil > .
eq prepLHS(Ct, CDS, I) = < Ct ; emptyTermSet ; I ; nil > .
*** \texttt{prepLHS} on a list of terms $\texttt{(}T\texttt{,\ }TL\texttt{)}$,
*** with $T$ a term and $TL$ a list of terms, has to make a call to itself with
*** $T$ and with $TL$. The call with $TL$ has to be made with the result of
*** the call with $T$ so that the variables and the index are right.
ceq prepLHS((T, TL), CDS, I)
= < (term(prepLHS(T, CDS, I)),
term(prepLHS(TL, CDS, index(prepLHS(T, CDS, I))))) ;
_|_(objects(prepLHS(T, CDS, I)),
objects(prepLHS(TL, CDS, index(prepLHS(T, CDS, I))))) ;
index(prepLHS(TL, CDS, index(prepLHS(T, CDS, I)))) ;
(messages(prepLHS(T, CDS, I))
messages(prepLHS(TL, CDS, index(prepLHS(T, CDS, I))))) >
if TL =/= empty .
ceq prepLHS(F[TL], CDS, I)
= < F[term(prepLHS(TL, CDS, I))] ;
objects(prepLHS(TL, CDS, I)) ;
index(prepLHS(TL, CDS, I)) ;
messages(prepLHS(TL, CDS, I)) >
if (F =/= '<_:_|_>) /\ (F =/= '<_:_|`>) .
ceq prepLHS('<_:_|_>[O, Ct, T], ((class C | ADS .) CDS), I)
= crtObject(O, C, ADS, prepLHS(T, ((class C | ADS .) CDS), I))
if getName(Ct) == C .
ceq prepLHS('<_:_|`>[O, Ct], ((class C | ADS .) CDS), I)
= crtObject(O, C, ADS,
prepLHS('none.AttributeSet, ((class C | ADS .) CDS), I))
if getName(Ct) == C .
eq prepLHS('<_:_|_>[O, V, T], CDS, I)
= < '<_:_|_>[O, V, T] ; emptyTermSet ; I ; nil > .
*** is this eq necessary?
eq prepLHS('<_:_|`>[O, T], CDS, I)
= prepLHS('<_:_|_>[O, T, 'none.AttributeSet], CDS, I) .
eq prepLHS('<_:_|_>[O, T, T'], none, I)
= < qidError('Error: 'undefined 'class T '\n) ; emptyTermSet ; I ; nil > .
eq crtObject(O, C, ADS, < T ; TS ; I ; QIL >)
= crtObject2(O, newVar(C, I), T, 'none.AttributeSet, ADS, TS, (I + 1), QIL) .
*** The function \texttt{crtObject2} is called with the metarepresentation of
*** the list of attributes appearing in the current object (third argument)
*** and the set of attribute declarations of the class to which such object
*** belongs + all the attributes declared in its superclasses (fifth
*** argument). The function proceeds recursively removing the attribute
*** declarations from the set of declarations of attributes for those
*** attributes that appear in the object. Each time an attribute is found, it
*** is passed with its actual value to the fourth argument of
*** \texttt{crtObject2}, which initially has value \verb~'none.AttributeSet~,
*** composing a list of terms with them.
*** We assume that:
*** \begin{itemize}
*** \item The metarepresentation of a list of attributes is always given with
*** form \verb~'_`,_[F[T], T]~, \verb~F[T]~, or
*** \verb~'none.AttributeSet~, where \texttt{TL} is the
*** metarepresentation of a list of attributes with the same form (this
*** is ensured by the \verb~(e E)~ gathering pattern in the corresponding
*** declaration in the signature in which the parsing is done), and
*** \item that all the attributes appearing in an object have been declared in
*** the corresponding class declaration or in one of its superclasses.
*** \end{itemize}
eq crtObject2(O, V, '_`,_[F[T], TL], TL', ADS, TS, I, QIL)
= crtObject2(O, V, (F[T], TL), TL', ADS, TS, I, QIL) .
ceq crtObject2(O, V, (F[T], TL), TL', ((attr A : S), ADS), TS, I, QIL)
= crtObject2(O, V, TL, (F[T], TL'), ADS, TS, I, QIL)
if qid(string(A) + "`:_") == F .
eq crtObject2(O, V, (F[T], TL), TL', ADS, TS, I, QIL)
= crtObject2(O, V, TL, TL', ADS, TS, I,
(QIL '\r 'Warning: '\o 'Attribute F 'not 'valid '\n))
[owise] .
ceq crtObject2(O, V, F[T], TL, ((attr A : S), ADS), TS, I, QIL)
= crtObject3(O, V, (F[T], TL), ADS, TS, I, QIL)
if qid(string(A) + "`:_") == F .
eq crtObject2(O, V, F[T], TL, ADS, TS, I, QIL)
= crtObject3(O, V, TL, ADS, TS, I,
(QIL '\r 'Warning: '\o 'Attribute F 'not 'valid '\n))
[owise] .
eq crtObject2(O, V, V', TL, ADS, TS, I, QIL)
= crtObject3(O, V, TL, ADS, TS, I,
QIL '\r 'Warning: '\o
'Variables 'are 'not 'allowed 'in 'the 'set 'of 'attributes
'of 'an 'object '`( V' '`) '\n) .
eq crtObject2(O, V, 'none.AttributeSet, TL, ADS, TS, I, QIL)
= crtObject3(O, V, TL, ADS, TS, I, QIL) .
eq crtObject2(O, V, empty, TL, ADS, TS, I, QIL)
= crtObject3(O, V, TL, ADS, TS, I, QIL) .
*** When the function \texttt{crtObject2} has gone through all the
*** attributes in the current object, the function \texttt{crtObject3} is
*** in charge of returning the metarepresentation of the current object
*** completed with the attributes that did not appear in it. These attributes
*** are added with new variables not used in the axiom as value.
*** \texttt{crtObject3} returns a pair composed by this resulting object,
*** and the set of terms representing all the objects in the lefthand
*** side (the current object is added to this set).
eq crtObject3(O, V, TL, ((attr A : S), ADS), TS, I, QIL)
= crtObject3(O, V, (qid(string(A) + "`:_")[newVar(S, I)], TL),
ADS, TS, (I + 1), QIL) .
eq crtObject3(O, V, TL, none, TS, I, QIL)
= < '<_:_|_>[O, V, '_`,_[TL, newVar('AttributeSet, I)]] ;
_|_('<_:_|_>[O, V, '_`,_[TL, newVar('AttributeSet, I)]], TS) ;
(I + 1) ;
QIL > .
*** Once the lefthand side of a rule or equation has been `prepared', the
*** function \texttt{prepRHS} is called with the set of objects returned by
*** \texttt{prepLHS} and the term in the righthand side of such rule or
*** equation. The function \texttt{prepRHS} proceeds recursively throughout the
*** term looking for objects. Each time an object is found, its set of
*** attributes is completed with those in the modified object of the lefthand
*** side which do not appear in it.
op prepRHS : TermSet TermList -> TermList .
op prepRHS : TermSet Condition -> Condition .
op adjustObject : TermSet Term -> Term .
op adjustObjectRHS : TermSet Term -> [Term] .
op adjustAttrsObjectRHS : Term Term -> [Term] .
op adjustAttrsObjectRHSAux : TermSet Term -> [Term] .
op termAttrListToTermSet : TermList -> TermSet .
op _attrInTermSet_ : Qid TermSet -> Bool .
eq prepRHS(TS, T = T' /\ Cond)
= prepRHS(TS, T) = prepRHS(TS, T') /\ prepRHS(TS, Cond) .
eq prepRHS(TS, T : S /\ Cond) = prepRHS(TS, T) : S /\ prepRHS(TS, Cond) .
eq prepRHS(TS, T := T' /\ Cond)
= prepRHS(TS, T) := prepRHS(TS, T') /\ prepRHS(TS, Cond) .
eq prepRHS(TS, T => T' /\ Cond)
= prepRHS(TS, T) => prepRHS(TS, T') /\ prepRHS(TS, Cond) .
eq prepRHS(TS, (nil).Condition) = nil .
eq prepRHS(TS, qidError(QIL)) = qidError(QIL) .
eq prepRHS(TS, F) = F .
eq prepRHS(TS, Ct) = Ct .
ceq prepRHS(TS, F[TL])
= F[prepRHS(TS, TL)]
if (F =/= '<_:_|_>) and (F =/= '<_:_|`>) .
eq prepRHS(TS, '<_:_|_>[O, Ct, T])
= adjustObjectRHS(TS, '<_:_|_>[O, Ct, prepRHS(TS, T)]) .
eq prepRHS(TS, '<_:_|_>[O, V, T]) = '<_:_|_>[O, V, prepRHS(TS, T)] .
eq prepRHS(TS, '<_:_|`>[O, Ct])
= adjustObjectRHS(TS, '<_:_|_>[O, Ct, prepRHS(TS, 'none.AttributeSet)]) .
eq prepRHS(TS, '<_:_|`>[O, V])
= '<_:_|_>[O, V, prepRHS(TS, 'none.AttributeSet)] .
ceq prepRHS(TS, (T, TL))
= (prepRHS(TS, T), prepRHS(TS, TL))
if TL =/= empty .
eq adjustObjectRHS(_|_('<_:_|_>[O, V, T], TS), '<_:_|_>[O', Ct, T'])
= if O == O'
then if getType(V) == getType(Ct)
then '<_:_|_>[O, V, adjustAttrsObjectRHS(T, T')]
else '<_:_|_>[O', Ct, T']
fi
else adjustObjectRHS(TS, '<_:_|_>[O', Ct, T'])
fi .
eq adjustObjectRHS(emptyTermSet, '<_:_|_>[O, Ct, T]) = '<_:_|_>[O, Ct, T] .
*** eq adjustObjectRHS(_|_('<_:_|_>[Ct, C, T], TS), '<_:_|_>[O, Ct', T'])
*** = adjustObjectRHS(TS, '<_:_|_>[O, Ct', T']) .
*** eq adjustObjectRHS(
*** _|_('<_:_|_>[Ct, C, T], TS), '<_:_|_>[Ct', Ct'', T'])
*** = if Ct == Ct'
*** then '<_:_|_>[Ct, Ct'', adjustAttrsObjectRHS(T, T')]
*** else adjustObjectRHS(TS, '<_:_|_>[Ct', Ct'', T'])
*** fi .
*** eq adjustObjectRHS(emptyTermSet, '<_:_|_>[Ct, Ct', T])
*** = '<_:_|_>[Ct, Ct', T] .
*** The function \texttt{adjustAttrsObjectRHS} completes the set of
*** attributes of an object in the righthand side with those in the object in
*** the lefthand side or in the class not used in the lefthand side, which
*** have been completed by the function \texttt{crtObject}.
eq adjustAttrsObjectRHS('_`,_[TL], T)
= adjustAttrsObjectRHSAux(termAttrListToTermSet(TL), T) .
eq adjustAttrsObjectRHSAux(_|_(A[T], TS), '_`,_[A[T'], T''])
= '_`,_[A[T'], adjustAttrsObjectRHSAux(TS, T'')] .
ceq adjustAttrsObjectRHSAux(TS, '_`,_[A[T], T'])
= qidError(A 'is 'not 'a 'valid 'attribute)
if not A attrInTermSet TS .
eq adjustAttrsObjectRHSAux(_|_(A[T], TS), A[T'])
= '_`,_[A[T'], adjustAttrsObjectRHSAux(TS, 'none.AttributeSet)] .
ceq adjustAttrsObjectRHSAux(TS, A[T])
= qidError(A 'is 'not 'a 'valid 'attribute)
if not A attrInTermSet TS .
eq adjustAttrsObjectRHSAux(_|_(A[T], TS), 'none.AttributeSet)
= '_`,_[A[T], adjustAttrsObjectRHSAux(TS, 'none.AttributeSet)] .
eq adjustAttrsObjectRHSAux(V, 'none.AttributeSet) = V .
eq A attrInTermSet _|_(V, TS) = A attrInTermSet TS .
eq A attrInTermSet _|_(A'[T], TS)
= (A == A') or-else (A attrInTermSet TS) .
eq A attrInTermSet emptyTermSet = false .
ceq termAttrListToTermSet((T, TL))
= if T == 'none.AttributeSet
then termAttrListToTermSet(TL)
else _|_(T, termAttrListToTermSet(TL))
fi
if TL =/= empty .
eq termAttrListToTermSet(T)
= if T == 'none.AttributeSet
then emptyTermSet
else T
fi .
*** In the case of equations and rules, the function \texttt{prepAxs} calls the
*** function \texttt{prepLHS} with the term in the lefthand side of the axiom,
*** and then use the generated set of objects to call the \texttt{prepRHS}
*** function. For conditional equations, rules, and membership axioms, this set
*** of terms representing the objects in the lefthand side is also used in the
*** calls to \texttt{prepRHS} with each of the terms in the conditions. The
*** term in the lefthand side of the equation, rule, or membership axiom is
*** replaced by the term returned by \texttt{prepLHS}. The index is used in
*** the recursive calls to \texttt{prepAxs}.
*** \texttt{prepLHS} returns as second argument the set of objects (as a set of
*** terms) appearing in it. These objects are returned after extending their
*** set of attributes by those of the class to which they belong not already
*** specified.
op prepAxs : Module MembAxSet EquationSet RuleSet ClassDeclSet Nat QidList
-> Module .
eq prepAxs(U, ((mb T : S [AtS] .) MAS), EqS, RlS, CDS, I, QIL)
= prepAxs(
addMbs(mb term(prepLHS(T, CDS, I)) : S [AtS] ., U),
MAS, EqS, RlS, CDS,
index(prepLHS(T, CDS, I)),
(QIL messages(prepLHS(T, CDS, I)))) .
eq prepAxs(U, ((cmb T : S if Cond [AtS] .) MAS), EqS, RlS, CDS, I, QIL)
= prepAxs(
addMbs(cmb term(prepLHS(T, CDS, I)) : S
if prepRHS(objects(prepLHS(T, CDS, I)), Cond) [AtS] ., U),
MAS, EqS, RlS, CDS,
index(prepLHS(T, CDS, I)),
(QIL messages(prepLHS(T, CDS, I)))) .
eq prepAxs(U, MAS, ((eq T = T' [AtS] .) EqS), RlS, CDS, I, QIL)
= prepAxs(
addEqs(eq term(prepLHS(T, CDS, I))
= prepRHS(objects(prepLHS(T, CDS, I)), T') [AtS] ., U),
MAS, EqS, RlS, CDS,
index(prepLHS(T, CDS, I)),
(QIL messages(prepLHS(T, CDS, I)))) .
eq prepAxs(U, MAS, ((ceq T = T' if Cond [AtS] .) EqS), RlS, CDS, I, QIL)
= prepAxs(
addEqs(ceq term(prepLHS(T, CDS, I))
= prepRHS(objects(prepLHS(T, CDS, I)), T')
if prepRHS(objects(prepLHS(T, CDS, I)), Cond) [AtS] ., U),
MAS, EqS, RlS, CDS,
index(prepLHS(T, CDS, I)),
(QIL messages(prepLHS(T, CDS, I)))) .
eq prepAxs(U, MAS, EqS, ((rl T => T' [AtS] .) RlS), CDS, I, QIL)
= prepAxs(
addRls(rl term(prepLHS(T, CDS, I))
=> prepRHS(objects(prepLHS(T, CDS, I)), T') [AtS] ., U),
MAS, EqS, RlS, CDS,
index(prepLHS(T, CDS, I)),
(QIL messages(prepLHS(T, CDS, I)))) .
eq prepAxs(U, MAS, EqS, ((crl T => T' if Cond [AtS] .) RlS), CDS, I, QIL)
= prepAxs(
addRls(crl term(prepLHS(T, CDS, I))
=> prepRHS(objects(prepLHS(T, CDS, I)), T')
if prepRHS(objects(prepLHS(T, CDS, I)), Cond) [AtS] ., U),
MAS, EqS, RlS, CDS,
index(prepLHS(T, CDS, I)),
(QIL messages(prepLHS(T, CDS, I)))) .
eq prepAxs(U, none, none, none, CDS, I, nil) = U .
eq prepAxs(U, none, none, none, CDS, I, NQIL) = unitError(NQIL) .
eq prepAxs(unitError(QIL), MAS, EqS, RlS:[RuleSet], CDS, I, QIL':QidList) = unitError(QIL':QidList QIL) .
*** After completing the set of classes in the module with the attributes from
*** their superclasses, the function \texttt{omod2mod} calls the function
*** \texttt{omod2modAux} with the same module and the set of class
*** declarations. The definition of the \texttt{omod2mod} function is given by
*** the five equations below.
op omod2mod : OModule Database -> SModule .
op omod2modAux : OModule ClassDeclSet -> SModule .
op omod2mod : OTheory Database -> SModule .
op omod2modAux : OTheory ClassDeclSet -> SModule .
eq omod2mod(
omod H is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endom,
DB)
= omod2modAux(
omod H is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endom,
prepClasses(CDS, SCDS, IL, getParDecls(H), DB)) .
eq omod2mod(
oth H is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endoth,
DB)
= omod2modAux(
oth H is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endoth,
prepClasses(CDS, SCDS, IL, getParDecls(H), DB)) .
eq omod2modAux(
omod H is
IL sorts SS . SSDS ((class C | ADS .) CDS) SCDS OPDS MDS MAS EqS RlS
endom,
CDS')
= omod2modAux(
omod H is
IL sorts (SS ; C) .
(subsort C < 'Cid . SSDS)
CDS SCDS
((op C : nil -> C [none] .)
ops4Attr(ADS) OPDS)
MDS MAS EqS RlS
endom,
CDS') .
eq omod2modAux(
omod H is
IL sorts SS . SSDS CDS ((subclass C < C' .) SCDS)
OPDS MDS MAS EqS RlS
endom,
CDS')
= omod2modAux(
omod H is
IL sorts SS . ((subsort C < C' .) SSDS)
CDS SCDS OPDS MDS MAS EqS RlS
endom,
CDS') .
eq omod2modAux(
omod H is
IL sorts SS . SSDS CDS SCDS OPDS
((msg F : TyL -> Ty .) MDS) MAS EqS RlS
endom,
CDS')
= omod2modAux(
omod H is
IL sorts SS . SSDS CDS SCDS
((op F : TyL -> Ty [msg] .) OPDS) MDS MAS EqS RlS
endom,
CDS') .
eq omod2modAux(
omod H is IL sorts SS . SSDS none none OPDS none MAS EqS RlS endom,
CDS)
= prepAxs(mod H is IL sorts SS . SSDS OPDS none none none endm,
MAS, EqS, RlS, CDS, 0, nil) .
eq omod2modAux(
oth H is
IL sorts SS . SSDS ((class C | ADS .) CDS)
SCDS OPDS MDS MAS EqS RlS
endoth,
CDS')
= omod2modAux(
oth H is
IL sorts (SS ; C) .
(subsort C < 'Cid . SSDS)
CDS SCDS
((op C : nil -> C [none] .)
ops4Attr(ADS) OPDS)
MDS MAS EqS RlS
endoth,
CDS') .
eq omod2modAux(
oth H is
IL sorts SS . SSDS CDS ((subclass C < C' .) SCDS)
OPDS MDS MAS EqS RlS
endoth,
CDS')
= omod2modAux(
oth H is
IL sorts SS . ((subsort C < C' .) SSDS)
CDS SCDS OPDS MDS MAS EqS RlS
endoth,
CDS') .
eq omod2modAux(
oth H is
IL sorts SS . SSDS CDS SCDS OPDS
((msg F : TyL -> Ty .) MDS) MAS EqS RlS
endoth,
CDS')
= omod2modAux(
oth H is
IL sorts SS . SSDS CDS SCDS
((op F : TyL -> Ty [msg] .) OPDS) MDS MAS EqS RlS
endoth,
CDS') .
eq omod2modAux(
oth H is IL sorts SS . SSDS none none OPDS none MAS EqS RlS endoth,
CDS)
= prepAxs(
th H is IL sorts SS . SSDS OPDS none none none endth,
MAS, EqS, RlS, CDS, 0, nil) .
endfm
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
***
*** Evaluation of Modules and Theories
***
*** As explained in Section~\ref{evaluation-overview}, in our approach
*** transforming a module from its possibly complex structured version to its
*** unstructured form is a two-step process. First, all module expressions
*** are evaluated, generating an intermediate form in which there are only
*** simple inclusion relationships among the modules. This first step can be
*** seen as the reduction of a structured specification to its structured
*** \emph{normal form}. Then, in a second step, this structured normal form is
*** flattened into an unstructured specification. Note, however, that the
*** importation of built-in modules is left explicit in the flattened form.
*** The function \texttt{normalize} is in charge of normalizing the
*** structure.
*** The process of evaluation of a preunit has to take into account the
*** possibility of bubbles being contained in it. Depending on whether it is
*** dealing with a preunit or with a unit, the evaluation process is
*** accomplished by two different functions, namely, \texttt{evalPreModule} and
*** \texttt{evalModule}. One function or the other will be called in each case.
*** Evaluating a module already in the database, which is done by
*** \texttt{evalModule}, does not require bubble handling. Besides this
*** difference, both functions proceed in a similar way. Before presenting the
*** functions \texttt{evalPreModule} and \texttt{evalModule} we introduce some
*** auxiliary declarations.
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
fmod EVALUATION is
pr O-O-TO-SYSTEM-MOD-TRANSF .
pr MOD-EXPR-EVAL .
pr UNIT-BUBBLE-PARSING .
sort List<Module> .
subsort Module < List<Module> .
op nil : -> List<Module> .
op __ : List<Module> List<Module> -> List<Module> [assoc id: nil] .
eq unitError(QIL) UL unitError(QIL') = unitError(QIL QIL') UL .
vars M PU U U' U'' : Module .
vars UL UL' : List<Module> .
vars DB DB' : Database .
vars ME ME' : ModuleExpression .
var P : ViewExp .
var PD : ParameterDecl .
vars PL PL' PL'' : ParameterList .
vars IL IL' IL'' : ImportList .
var I : Import .
var CDS : ClassDeclSet .
var SSDS : SubsortDeclSet .
var SCDS : SubclassDeclSet .
var OPD : OpDecl .
vars OPDS VDS : OpDeclSet .
var MDS : MsgDeclSet .
var MAS : MembAxSet .
var EqS : EquationSet .
var RlS : RuleSet .
var B : Bool .
vars QI QI' V L L' L'' A A' A'' F F' F'' X Y W Z : Qid .
vars QIL QIL' SL : QidList .
vars S S' S'' C C' C'' : Sort .
vars SS SS' : SortSet .
vars Ty Ty' : Type .
vars TyL TyL' : TypeList .
vars AtS AtS' : AttrSet .
var Rl : Rule .
var CD : ClassDecl .
var ADS : AttrDeclSet .
var MD : MsgDecl .
vars T T' T'' T3 : Term .
var TL : TermList .
var VMAP : ViewMap .
var VMAPS : RenamingSet .
var MAP : Renaming .
var MAPS : RenamingSet .
vars VE VE' VE'' : ViewExp .
var HkL : HookList .
vars PDL PDL' : ParameterDeclList .
var St : String .
*** The \texttt{subunitImports} function returns the list of all the
*** subunits of a given unit. It is called with the list of importations of
*** the given unit as first argument, and proceeds recursively through its
*** structure collecting all the subunits in it.
*** The function \texttt{subunitImports} proceeds storing the importations
*** considered up to that point, so it does not have to go through the same
*** part of the structure more than once. When the function is initially
*** called the second argument is set to \texttt{nil}.
op subunitImports : ParameterDeclList ImportList Database -> ImportList .
op subunitImports : ImportList ImportList Database -> ImportList .
eq subunitImports((PD, PDL), IL, DB)
= subunitImports(PDL, IL (protecting pd(PD) .), DB) .
eq subunitImports((nil).ParameterDeclList, IL, DB)
= subunitImports(IL, nil, DB) .
eq subunitImports(I IL, IL' I IL'', DB)
= subunitImports(IL, IL' I IL'', DB) .
eq subunitImports(I IL, IL', DB)
= subunitImports(getImports(getTopModule(moduleName(I), DB)) IL, I IL', DB)
[owise] .
eq subunitImports((nil).ImportList, IL, DB) = IL .
*** The function \texttt{getModules} returns the list of those units
*** in the list of importations given as argument which are not built-in.
op getModules : ImportList Database -> List<Module> .
op getModules : ImportList List<Module> Database -> List<Module> .
eq getModules(IL, DB) = getModules(IL, nil, DB) .
eq getModules(((including ME .) IL), UL, DB)
= getModules(IL, (UL getInternalModule(ME, DB)), DB) .
eq getModules(((including pd(PD) .) IL), UL, DB)
= getModules(IL, (UL getInternalModule(pd(PD), DB)), DB) .
eq getModules(((extending ME .) IL), UL, DB)
= getModules(IL, (UL getInternalModule(ME, DB)), DB) .
eq getModules(((extending pd(PD) .) IL), UL, DB)
= getModules(IL, (UL getInternalModule(pd(PD), DB)), DB) .
eq getModules(((protecting ME .) IL), UL, DB)
= getModules(IL, (UL getInternalModule(ME, DB)), DB) .
eq getModules(((protecting pd(PD) .) IL), UL, DB)
= getModules(IL, (UL getInternalModule(pd(PD), DB)), DB) .
eq getModules(IL, UL unitError(QIL) UL', DB) = unitError(QIL) .
eq getModules(nil, UL, DB) = UL .
*** The normalization of a structure consists in evaluating each of the module
*** expressions appearing in it. Note that, if the \texttt{evalModExp} function
*** generates new modules, they will be evaluated using the \texttt{evalModule}
*** function, producing recursive calls on the part of the structure not
*** previously normalized. Parameters are handled separatedly. They are
*** folded out when analyzing the interface of a module.
pr 3TUPLE{ImportList,ParameterDeclList,Database}
* (op ((_,_,_)) to <_;_;_>,
op p1_ to importList,
op p2_ to parameterDeclList,
op p3_ to database) .
---- sort Tuple{ImportList,ParameterDeclList,Database} .
---- op <_;_;_> : ImportList ParameterDeclList Database
---- -> Tuple{ImportList,ParameterDeclList,Database} .
---- op importList : Tuple{ImportList,ParameterDeclList,Database} -> ImportList .
---- op parameterDeclList :
---- Tuple{ImportList,ParameterDeclList,Database} -> ParameterDeclList .
---- op database : Tuple{ImportList,ParameterDeclList,Database} -> Database .
---- eq importList(< IL ; PDL ; DB >) = IL .
---- eq parameterDeclList(< IL ; PDL ; DB >) = PDL .
---- eq database(< IL ; PDL ; DB >) = DB .
op normalize : ImportList ParameterDeclList Database
-> Tuple{ImportList,ParameterDeclList,Database} .
op normalize : ImportList ImportList ParameterDeclList ParameterDeclList
Database -> Tuple{ImportList,ParameterDeclList,Database} .
op createCopy : ParameterDecl Database -> Database .
---- its definition is in INST-EXPR-EVALUATION
eq normalize(IL, PDL, DB) = normalize(nil, IL, nil, PDL, DB) .
eq normalize(IL, IL', PDL, (X :: ME, PDL'), DB)
= normalize(IL, IL',
(PDL, X :: modExp(evalModExp(ME, nil, DB))), PDL',
createCopy((X :: modExp(evalModExp(ME, nil, DB))),
database(evalModExp(ME, nil, DB)))) .
eq normalize(IL, (including ME .) IL', PDL, PDL', DB)
= normalize(IL (including modExp(evalModExp(ME, PDL, DB)) .), IL',
PDL, PDL', database(evalModExp(ME, PDL, DB))) .
eq normalize(IL, (extending ME .) IL', PDL, PDL', DB)
= normalize(IL (extending modExp(evalModExp(ME, PDL, DB)) .), IL',
PDL, PDL', database(evalModExp(ME, PDL, DB))) .
eq normalize(IL, (protecting ME .) IL', PDL, PDL', DB)
= normalize(IL (protecting modExp(evalModExp(ME, PDL, DB)) .), IL',
PDL, PDL', database(evalModExp(ME, PDL, DB))) .
eq normalize(IL, I IL', PDL, PDL', DB)
= normalize(IL I, IL', PDL, PDL', DB)
[owise] .
eq normalize(IL, nil, PDL, nil, DB) = < IL ; PDL ; DB > .
*** \texttt{checkSortClashes} checks whether the intersection of the two sTS
*** of sorts given as arguments is empty or not. If it is nonempty, then there
*** is a clash of names, and a warning message is passed to the database. The
*** check is very simple, and only reports the name of one of the modules from
*** which the sorts come. Only the name of the module from which the sorts
*** given as second argument come is known at this point. This is the module
*** name given as first argument.
***
*** op checkSortClashes : Header SortSet SortSet Database -> Database .
***
*** eq checkSortClashes(ME, (S ; SS), (S ; SS'), DB)
*** = checkSortClashes(ME, SS, SS',
*** warning(DB,
*** '\g 'Advisory: '\o
*** 'Clash 'of 'sort eSortToSort(S) 'from header2Qid(ME) '\n)) .
*** ceq checkSortClashes(ME, (S ; SS), SS', DB)
*** = checkSortClashes(ME, SS, SS', DB)
*** if not (S in SS') .
*** eq check(ME, none, SS, DB) = DB .
*** In the current system, the only transformation handled by the
*** \texttt{transform} function is the one from object-oriented modules to
*** system modules, which is accomplished by the
*** \texttt{omod2mod} function presented in
*** Section~\ref{omod2modfunction}. However, \texttt{transform} has been
*** defined as a general transformation that could affect other kinds of
*** modules in a future extension.
op transform : Module Database -> Module .
eq transform(unitError(QIL), DB) = unitError(QIL) .
ceq transform(U, DB) = rmVariantAttrs(U) if U :: SModule or U :: STheory .
ceq transform(U, DB) = rmVariantAttrs(omod2mod(U, DB))
if not U :: SModule /\ not U :: STheory /\ U :: OModule or U :: OTheory .
*** The function \texttt{signature} generates a functional module of sort
*** \texttt{FModule}, without equations, by ``forgetting'' the appropriate
*** declarations and converting extended sorts and module names into quoted
*** identifiers.
op removeIds : OpDeclSet Module -> OpDeclSet .
eq removeIds(op F : TyL -> Ty [id(T) AtS] . OPDS, M)
= removeIds(op F : TyL -> Ty [AtS] . OPDS, M) .
eq removeIds(op F : TyL -> Ty [right-id(T) AtS] . OPDS, M)
= removeIds(op F : TyL -> Ty [AtS] . OPDS, M) .
eq removeIds(op F : TyL -> Ty [left-id(T) AtS] . OPDS, M)
= removeIds(op F : TyL -> Ty [AtS] . OPDS, M) .
eq removeIds(op F : TyL -> Ty [special(term-hook(QI, T) HkL) AtS] . OPDS, M)
= removeIds(op F : TyL -> Ty [special(HkL) AtS] . OPDS, M) .
eq removeIds(OPDS, M) = OPDS [owise] .
op removeDittos : OpDeclSet Module -> OpDeclSet .
ceq removeDittos(
op F : TyL -> Ty [ditto AtS] . op F : TyL' -> Ty' [AtS'] . OPDS, M)
= removeDittos(
op F : TyL -> Ty [AtS removeCtorMetadata(AtS')] . op F : TyL' -> Ty' [AtS'] . OPDS, M)
if not ditto in AtS' /\ sameKind(M, TyL Ty, TyL' Ty') .
eq removeDittos(OPDS, M) = OPDS [owise] .
op signature : Module -> Module .
eq signature(unitError(QIL)) = unitError(QIL) .
eq signature(U)
= fmod header2Qid(getName(U)) is
convertModuleExpressions(getImports(U))
sorts getSorts(U) .
getSubsorts(U)
removeIds(
removeDittos(getOps(U),
setSubsorts(
setSorts(emptyFModule('DUMMY), getSorts(U)),
getSubsorts(U))),
setSubsorts(
setSorts(emptyFModule('DUMMY), getSorts(U)),
getSubsorts(U)))
none
none
endfm
[owise] .
*** The function \texttt{flatModule} generates a module of sort \texttt{Module}
*** by ``forgetting'' declarations and converting extended sorts and module
*** identifiers into quoted identifiers.
op flatModule : Module -> Module .
eq flatModule(unitError(QIL)) = unitError(QIL) .
eq flatModule(U)
= if U :: FModule or U :: FTheory
then (fmod header2Qid(getName(U)) is
getImports(U)
sorts getSorts(U) .
getSubsorts(U)
getOps(U)
getMbs(U)
getEqs(U)
endfm)
else (mod header2Qid(getName(U)) is
getImports(U)
sorts getSorts(U) .
getSubsorts(U)
getOps(U)
getMbs(U)
getEqs(U)
getRls(U)
endm)
fi
[owise] .
op convertModuleExpressions : ImportList -> ImportList .
eq convertModuleExpressions(((protecting ME * (MAPS) .) IL))
= (protecting ME * (renamings(MAPS)) .) convertModuleExpressions(IL) .
eq convertModuleExpressions(((extending ME * (MAPS) .) IL))
= (extending ME * (renamings(MAPS)) .) convertModuleExpressions(IL) .
eq convertModuleExpressions(((including ME * (MAPS) .) IL))
= (including ME * (renamings(MAPS)) .) convertModuleExpressions(IL) .
eq convertModuleExpressions(I IL) = I convertModuleExpressions(IL) [owise] .
eq convertModuleExpressions(nil) = nil .
op renamings : RenamingSet -> RenamingSet .
eq renamings(op F to F' [AtS]) = op F to F' [AtS] .
eq renamings((op F to F' [AtS], MAPS))
= (op F to F' [AtS], renamings(MAPS))
[owise] .
eq renamings(op F : TyL -> Ty to F' [AtS])
= op F : TyL -> Ty to F' [AtS] .
eq renamings((op F : TyL -> Ty to F' [AtS], MAPS))
= (op F : TyL -> Ty to F' [AtS],
renamings(MAPS))
[owise] .
eq renamings(sort S to S') = sort S to S' .
eq renamings(((sort S to S'), MAPS))
= ((sort S to S'), renamings(MAPS))
[owise] .
eq renamings(label L to L') = label L to L' .
eq renamings(((label L to L'), MAPS))
= ((label L to L'), renamings(MAPS))
[owise] .
eq renamings((MAP, MAPS)) = renamings(MAPS) [owise] .
eq renamings(none) = none .
*** The evaluation process for units without bubbles is as follows. After
*** normalizing the structure, the function \texttt{evalModule} calls
*** \texttt{evalModule1} with an empty copy of the module to which the list of
*** declarations of importations of built-in modules is added, and with the
*** list of its nonbuilt-in subunits.
*** \texttt{evalModule1} accumulates all the declarations in all the
*** nonbuilt-insubmodules in the copy of the module passed as second argument.
*** The top module is then introduced in the database, and, after calling the
*** \texttt{transform} function and renaming all the variables in it, the
*** internal version of such a module is entered in the database as well.
*** Finally, \texttt{evalModule2} generates the signature and the flat version
*** of the module and enters them in the database.
*** op evalModule : Module Database -> Database .
*** moved to MOD-EXPR-EVAL to solve dependency
op evalModule1 : Module Module List<Module> OpDeclSet Database -> Database .
op evalModule2 : Module Module Database -> Database .
ceq evalModule(U, VDS, DB)
= evalModule1(setPars(setImports(U, IL), PDL), empty(U),
getModules(IL', DB'), VDS, DB')
if < IL ; PDL ; DB' > := normalize(getImports(U), getPars(U), DB)
/\ IL' := subunitImports(PDL, IL, DB') .
eq evalModule1(U, U', (U'' UL), VDS, DB)
= evalModule1(U, addDecls(U', setImports(U'', nil)), UL, VDS, DB) .
eq evalModule1(U, U', nil, VDS, DB)
= evalModule2(
setImports(transform(U, DB), nil),
U',
insertVars(getName(U), VDS,
insertInternalModule(getName(U), transform(U, DB),
insertTopModule(getName(U), U, DB)))) .
eq evalModule1(U, U', unitError(QIL), VDS, DB) = warning(DB, QIL) .
eq evalModule2(U, U', DB)
= insertFlatModule(getName(U), flatModule(addDecls(U, U')), DB) .
eq evalModule2(unitError(QIL), U, DB) = warning(DB, QIL) .
*** The function \texttt{evalPreModule} has to take care of the bubbles in the
*** unit. As we explained in Section~\ref{evaluation-overview}, both the
*** signature and the flattened version of the module are created
*** simultaneously, completing the parsing of the bubbles once the signature
*** has been built, and then completing the flattened module.
*** The \texttt{evalPreModule} function takes as arguments two copies of the
*** module and a database. We shall see in Section~\ref{unit-processing} how
*** these two modules are generated; the one passed as first argument has
*** still bubbles in it, while the other one, which will be used to build the
*** signature, does not contain any bubbles. This module without bubbles is
*** the result of removing the bubbles from the declarations in it, or of
*** removing the declarations themselves when they contain bubbles, as in the
*** case of equations, for example.
*** The \texttt{evalPreModule} function is quite similar to the function
*** \texttt{evalModule}. First, the structure is normalized by calling the
*** \texttt{normalize} function, and then all the subunits in the
*** structure are collected (accomplished by \texttt{subunitImports} and
*** \texttt{getModules}) and the list of importations is updated
*** with the sublist of importations of built-in
*** modules (\texttt{selectBuiltInImports}). Second, the structure of all the
*** subunits below the top is flattened to a single unit. This unit is used to
*** create a first version of the signature (without identity elements of
*** operators) in which all the bubbles in the top preunit are
*** parsed (\texttt{solveBubbles}). The final version of the signature and
*** the flat unit are generated once the bubbles have been parsed. The
*** `internal' version of the module is also generated by renaming the
*** variables in it (\texttt{renameVars}). All these versions of the module
*** are finally entered in the database.
*** Note that if the \texttt{META-LEVEL} module is imported in the module
*** being evaluated, a declaration importing the predefined module
*** \texttt{UP} Section~\ref{non-built-in-predefined}) is added. With the
*** declarations in this module it will be possible to parse bubbles
*** containing calls to the \texttt{up} functions (see
*** Section~\ref{structured-specifications}) in them.
op evalPreModule : Module Module OpDeclSet Database -> Database .
op evalPreModule1 :
Module Module List<Module> Module OpDeclSet Database -> Database .
op evalPreModule2 : Module Module Module OpDeclSet Database -> Database .
op evalPreModule3 : Module Module Module Database -> Database .
*** evalPreModule just calls evalPreModule1 with a set of the units in the
*** structure of the given module. Depending on whether the module is
*** importing META-LEVEL or not UP will be added. BOOL will be added if
*** the include BOOL flag is set and the module doesn't include it already.
ceq evalPreModule(PU, U, VDS, DB)
*** PU : top unit with bubbles (preunit)
*** U : top unit without bubbles (decls with bubbles were removed)
*** VDS : ops corresponding to the vbles in the top unit
= evalPreModule1(
setPars(setImports(PU, IL'), PDL'),
setName(empty(U), getName(U)),
getModules(IL'', DB'),
setImports(U, nil),
VDS,
DB')
if IL := getImports(PU)
/\ PDL := getPars(PU)
/\ < IL' ; PDL' ; DB' > := normalize(defImports(PU, DB) IL, PDL, DB)
/\ IL'' := subunitImports(PDL, IL', DB') .
eq evalPreModule(PU, U, VDS, DB) = DB [owise] .
*** evalPreModule1 joins all the units in the structure into a single unit,
*** the one given as second argument; recall that the fourth one is the
*** top module without bubbles but with the complete list of subunits
*** being imported explicitly
eq evalPreModule1(PU, U, (U' UL), U'', VDS, DB)
= evalPreModule1(PU, addDecls(U, U'), UL, U'', VDS, DB) .
eq evalPreModule1(PU, U, nil, U', VDS, DB)
= evalPreModule2(PU, U, signature(transform(addDecls(U', setImports(U, nil)), DB)), VDS, DB)
[owise] .
eq evalPreModule1(PU, unitError(QIL), UL, U', VDS, DB) = warning(DB, QIL) .
eq evalPreModule1(unitError(QIL), U, UL, U', VDS, DB) = warning(DB, QIL) .
eq evalPreModule1(PU, U, unitError(QIL), U', VDS, DB) = warning(DB, QIL) .
eq evalPreModule2(PU, U, M, VDS, DB)
*** PU : top module with bubbles
*** U : everything below
*** M : complete signature
= evalPreModule3(
solveBubblesMod(PU, getOps(U), M,
included('META-MODULE, getImports(PU), DB), VDS, DB),
U, M,
insertVars(getName(PU), VDS,
insertTopModule(getName(PU),
solveBubblesMod(PU, getOps(U), M,
included('META-MODULE, getImports(PU), DB), VDS, DB), DB))) .
eq evalPreModule3(PU, U, M, DB)
*** PU : top module without bubbles
*** U : everything below
*** M : complete signature
= insertFlatModule(getName(PU),
flatModule(setImports(transform(addDecls(PU, U), DB), nil)),
insertInternalModule(getName(PU), transform(PU, DB), DB)) .
eq evalPreModule3(unitError(QIL), U, M, DB) = warning(DB, QIL) .
endfm
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
*** Note that in both \texttt{evalModule} and \texttt{evalPreModule}, the function
*** \texttt{transform} has to be invoked to transform the module into a
*** functional or system module. In the current system, the only
*** transformation available is from object-oriented modules to system modules.
***
*** 6.8 Application of Map STS
***
*** The following two modules deal with the application of a set of renaming
*** maps to a module. Except for the proof obligations and additional checks
*** associated with views---almost none of these checks are performed, and
*** none of these proof obligations is generated in the current version---the
*** way of applying a renaming map and a view map on a module is the same.
*** Internally, they are treated in the same way; the only difference between
*** them consists in the way of calling the function to accomplish this
*** application.
*** Note that there might be some `interference' between sort maps, and
*** operator maps and message maps when they are applied. Let us consider for
*** example a module with an operator declaration
***
*** op f : Foo -> Foo .
***
*** and a renaming map set
***
*** (sort Foo to Bar, op f : Foo -> Foo to g)
***
*** These renamings have to be applied carefully to avoid unintended behaviors.
*** Depending on which of the maps is applied first, the other will be
*** applicable or not. All the maps must be applied to the original module.
*** To avoid the interference between the sort maps and other maps, the map set
*** is divided into two sTS: The first one contains the sort maps, and the
*** second one contains the other maps.
*** We assume that there are no ambiguous mappings, that is, that we do not
*** have, for example, maps \verb~op f to g~ and \verb~op f to h~. In case of
*** such ambiguity, one of the maps will be arbitrarily chosen.
***
*** 6.8.1 Map STS on Terms
***
*** The application of a set of view maps to a term is defined in the following
*** module \texttt{VIEW-MAP-SET-APPL-ON-TERM}. The function
*** \texttt{applyMapsToTerm} is used to apply a given view map set to terms
*** appearing in equations, rules, identity element declarations, and
*** membership axioms, as part of the process of applying a map set to a unit.
*** Some of the auxiliary functions introduced in this module will also be used
*** in the application of maps to operator and message declarations in the
*** \texttt{VIEW-MAP-SET-APPL-ON-UNIT} module.
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
fmod VIEW-MAP-SET-APPL-ON-TERM is
pr UNIT .
pr VIEW-MAP .
pr EXT-SORT .
var VMAP : ViewMap .
vars VMAPS VMAPS' VMAPS'' : Set{ViewMap} .
var M : Module .
vars F F' F'' A A' A'' : Qid .
vars T T' T'' O : Term .
vars TL TL' TL'' TL3 : TermList .
vars S S' S'' C C' C'' : Sort .
var SS : SortSet .
var K : Kind .
vars TyL TyL' : TypeList .
vars Ty Ty' : Type .
vars Subst Subst' Subst'' : Substitution .
var AtS : AttrSet .
var OPDS : OpDeclSet .
vars V V' : Variable .
vars Ct Ct' : Constant .
var QIL : QidList .
var Cd : Condition .
*** The following functions \texttt{applyMapsToSort} and
*** \texttt{applyMapsToClassSort} apply a set of maps, respectively, to a
*** sort a to a class name in its single identifier form, that is, when they
*** appear qualifying constants. Functions \texttt{applyMapsToType} and
*** \texttt{applyMapsToClassName} are similar but being applied to sort or
*** class names in their normal form.
op applyMapsToSort : Set{ViewMap} Sort -> Sort .
eq applyMapsToSort((sort S to S'), S) = S' .
eq applyMapsToSort((sort S to S'), S'') = S'' [owise] .
eq applyMapsToSort(((sort S to S'), VMAPS), S) = S' .
eq applyMapsToSort(((sort S to S'), VMAPS), S'')
= applyMapsToSort(VMAPS, S'')
[owise] .
eq applyMapsToSort(VMAP, S) = S [owise].
eq applyMapsToSort((VMAP, VMAPS), S) = applyMapsToSort(VMAPS, S) [owise].
eq applyMapsToSort(none, S) = S .
op applyMapsToSortSet : Set{ViewMap} SortSet -> SortSet .
eq applyMapsToSortSet(VMAPS, (S ; SS))
= (applyMapsToType(VMAPS, S) ; applyMapsToSortSet(VMAPS, SS)) .
eq applyMapsToSortSet(VMAPS, none) = none .
op applyMapsToType : Set{ViewMap} Type -> Type .
eq applyMapsToType((sort S to S'), S) = S' .
eq applyMapsToType((sort S to S'), S'') = S'' [owise] .
eq applyMapsToType(((sort S to S'), VMAPS), S) = S' .
eq applyMapsToType(((sort S to S'), VMAPS), S'')
= applyMapsToType(VMAPS, S'')
[owise] .
eq applyMapsToType((sort S to S'), K)
= qid("[" + string(applyMapsToType(sort S to S', getSort(K))) + "]") .
eq applyMapsToType(((sort S to S'), VMAPS), K)
= qid("["
+ string(applyMapsToType(((sort S to S'), VMAPS), getSort(K)))
+ "]") .
eq applyMapsToType(none, Ty) = Ty .
op applyMapsToClassName : Set{ViewMap} Sort -> Sort .
eq applyMapsToClassName((class C to C'), C) = C' .
eq applyMapsToClassName((class C to C'), C'') = C'' [owise] .
eq applyMapsToClassName(((class C to C'), VMAPS), C) = C' .
eq applyMapsToClassName(((class C to C'), VMAPS), C'')
= applyMapsToClassName(VMAPS, C'')
[owise] .
eq applyMapsToClassName(VMAP, C) = C [owise] .
eq applyMapsToClassName((VMAP, VMAPS), C)
= applyMapsToClassName(VMAPS, C)
[owise] .
eq applyMapsToClassName(none, C) = C .
*** \texttt{} applies a map set to an operator name.
op applyOpMapsToOpId : Qid Set{ViewMap} -> Qid .
eq applyOpMapsToOpId(F, (op F to F' [AtS])) = F' .
eq applyOpMapsToOpId(F, (op F : TyL -> Ty to F' [AtS])) = F' .
eq applyOpMapsToOpId(F, VMAPS) = F [owise] .
*** Note that all maps introduced in Sections~\ref{renaming-maps}
*** and~\ref{view-maps}, except for label maps, may affect a term. For example,
*** sort maps will be applied to the qualifications of terms, and class and
*** attribute maps have to be applied to the objects appearing in the term.
*** Operator and message maps in which an explicit arity and coarity is given,
*** and operator maps going to derived operators (see Section~\ref{Views})
*** must be applied to the complete family of subsort-overloaded operators.
*** The function \texttt{applyMapsToTerm} takes as arguments two sTS of
*** view maps (the first set for sort maps, and the second for the other maps),
*** the term to which the maps will be applied, and a module to be used in the
*** matching of terms, sort comparisons, etc. Its declaration is as follows.
op applyMapsToTerm2 : Set{ViewMap} Set{ViewMap} Term Module -> Term .
*** If the term on which the maps have to be applied is not an object,
*** different cases have to be considered for each of the possible forms of a
*** term. If it is a variable or \texttt{error*}, the same term is returned
*** without change (term maps are a special case for this). If it is a sort
*** test or a lazy sort test, with forms \verb~T : S~ and \verb~T :: S~,
*** respectively, the maps are applied to the term \texttt{T} and to the sort
*** \texttt{S}. In case of being of forms \verb~F.S~ or \verb~F[TL]~ with
*** \texttt{F} an operator name, \texttt{S} a sort, and \texttt{TL} a list of
*** terms, the function \texttt{getRightOpMaps} will return the subset of
*** maps which are applicable on such term. If \texttt{none} is returned then
*** no map is applicable. If more than one map is returned then there is an
*** ambiguity, and any of them will be arbitrarily taken. The function
*** \texttt{imagTerm} is called with the term and the maps applicable on
*** it and return the image of the term. In case of a term of the form
*** \texttt{F[TL]}, \texttt{imageOfTerm} will make recursive calls with the
*** arguments in \texttt{TL}.
*** The application of a term map to a term requires the `matching' of the
*** source term in the map with the term on which the map is applied, and then
*** the application of the obtained substitution. Note, however, that a
*** complete matching algorithm is not required. Given the form of the pattern
*** we can choose before hand the appropriate map, that is, we know that in
*** fact there is a match when the function is called. Note also that the map
*** has to be applied to the whole family of subsort overloaded operators. We
*** just have to check that the sort of the given variable and the
*** corresponding term are in the same connected component of sorts. In
*** addition to getting the appropriate substitution, the only thing we need
*** to check is that there are no variables with different assignments, that
*** is, that in case of having a nonlinear pattern, the terms being assigned
*** to each variable are equal. We call \texttt{pseudoMatch} to the function
*** doing this task.
op applyMapsToTerm2 : Set{ViewMap} Set{ViewMap} TermList Module -> TermList .
op imageOfTerm : Set{ViewMap} Set{ViewMap} Term Set{ViewMap} Module -> Term .
op applyMapsToSubst :
Set{ViewMap} Set{ViewMap} Substitution Module -> Substitution .
op pseudoMatch : TermList TermList Module Substitution -> Substitution .
op pseudoMatch2 : TermList TermList Module Substitution -> Substitution .
op pseudoMatchResult : Substitution -> Substitution .
op pseudoMatchResult :
Substitution Assignment Substitution Substitution -> Substitution .
op getRightOpMaps :
Qid TypeList Type Set{ViewMap} Module -> Set{ViewMap} .
op applyMapsToObjectAttrSet :
Set{ViewMap} Set{ViewMap} Sort Term Module -> Term .
op applyMapsToAttrNameInTerm : Set{ViewMap} Sort Qid Module -> Qid .
eq applyMapsToTerm2(VMAPS, VMAPS', Ct, M)
= imageOfTerm(VMAPS, VMAPS', Ct,
getRightOpMaps(getName(Ct), nil, getType(Ct), VMAPS', M), M) .
eq applyMapsToTerm2(VMAPS, VMAPS', V, M)
= qid(string(getName(V)) + ":"
+ string(applyMapsToType(VMAPS, getType(V)))) .
eq applyMapsToTerm2(VMAPS, VMAPS', qidError(QIL), M) = qidError(QIL) .
eq applyMapsToTerm2(VMAPS, VMAPS', F[TL], M)
= imageOfTerm(VMAPS, VMAPS', F[TL],
getRightOpMaps(F, eLeastSort(M, TL), leastSort(M, F[TL]),
VMAPS', M), M)
[owise] .
---- if (F =/= '<_:_|_>) and (F =/= '<_:_|`>) .
eq applyMapsToTerm2(VMAPS, VMAPS', '<_:_|_>[O, Ct, T], M)
= '<_:_|_>[applyMapsToTerm2(VMAPS, VMAPS', O, M),
qid(string(applyMapsToClassName(VMAPS', getName(Ct)))
+ "." + string(applyMapsToClassName(VMAPS', getType(Ct)))),
applyMapsToObjectAttrSet(VMAPS, VMAPS', getName(Ct), T, M)].
ceq applyMapsToTerm2(VMAPS, VMAPS', '<_:_|_>[O, C, T], M)
= '<_:_|_>[applyMapsToTerm2(VMAPS, VMAPS', O, M),
applyMapsToClassName(VMAPS', C),
applyMapsToObjectAttrSet(VMAPS, VMAPS', C, T, M)]
if not C :: Constant .
eq applyMapsToTerm2(VMAPS, VMAPS', '<_:_|`>[O, Ct], M)
= '<_:_|_>[applyMapsToTerm2(VMAPS, VMAPS', O, M),
qid(string(applyMapsToClassName(VMAPS', getName(Ct)))
+ "." + string(applyMapsToClassName(VMAPS', getType(Ct)))),
ceq applyMapsToTerm2(VMAPS, VMAPS', '<_:_|`>[O, C], M)
= '<_:_|_>[applyMapsToTerm2(VMAPS, VMAPS', O, M),
applyMapsToClassName(VMAPS', C), 'none.AttributeSet]
if not C :: Constant .
ceq applyMapsToTerm2(VMAPS, VMAPS', F[TL], M)
= qid("_::`" + string(applyMapsToType(VMAPS, qid(substr(string(F), 4, length(string(F))))))) [
applyMapsToTerm2(VMAPS, VMAPS', TL, M)]
if substr(string(F), 0, 4) == "_::`"
/\ substr(string(F), sd(length(string(F)), 2), 2) = "`}" .
ceq applyMapsToTerm2(VMAPS, VMAPS', (T, TL), M)
= (applyMapsToTerm2(VMAPS, VMAPS', T, M),
applyMapsToTerm2(VMAPS, VMAPS', TL, M))
if TL =/= empty .
*** Application of a map set to the name of an attribute in an object
eq applyMapsToAttrNameInTerm((attr A . S to A'), C, A'', M)
= if sameKind(M, S, C) and-then (qid(string(A) + "`:_") == A'')
then qid(string(A') + "`:_")
else A''
fi .
eq applyMapsToAttrNameInTerm(((attr A . S to A'), VMAPS), C, A'', M)
= if sameKind(M, S, C) and-then (qid(string(A) + "`:_") == A'')
then qid(string(A') + "`:_")
else applyMapsToAttrNameInTerm(VMAPS, C, A'', M)
fi .
eq applyMapsToAttrNameInTerm(VMAP, C, A, M) = A [owise] .
eq applyMapsToAttrNameInTerm((VMAP, VMAPS), C, A, M)
= applyMapsToAttrNameInTerm(VMAPS, C, A, M)
[owise] .
eq applyMapsToAttrNameInTerm(none, S, A, M) = A .
*** Selection of all the operator or message maps that are applicable on an
*** operator with a given arity and coarity.
eq getRightOpMaps(F, TyL, Ty, (msg F' to F''), M)
= getRightOpMaps(F, TyL, Ty, (op F' to F'' [none]), M) .
eq getRightOpMaps(F, TyL, Ty, ((msg F' to F''), VMAPS), M)
= getRightOpMaps(F, TyL, Ty, ((op F' to F'' [none]), VMAPS), M) .
eq getRightOpMaps(F, TyL, Ty, (msg F' : TyL' -> Ty' to F''), M)
= getRightOpMaps(F, TyL, Ty, op F' : TyL' -> Ty' to F'' [none], M) .
eq getRightOpMaps(F, TyL, Ty, ((msg F' : TyL' -> Ty' to F''), VMAPS), M)
= getRightOpMaps(F, TyL, Ty,
(op F' : TyL' -> Ty' to F'' [none], VMAPS), M) .
eq getRightOpMaps(F, TyL, Ty, (op F to F' [AtS]), M) = (op F to F' [AtS]) .
eq getRightOpMaps(F, TyL, Ty, (op F to F' [AtS], VMAPS), M)
= (op F to F' [AtS], getRightOpMaps(F, TyL, Ty, VMAPS, M)) .
eq getRightOpMaps(F, TyL, Ty, op F : TyL' -> Ty' to F' [AtS], M)
= if sameKind(M, TyL Ty, TyL' Ty')
then (op F : TyL' -> Ty' to F' [AtS])
else none
fi .
eq getRightOpMaps(F, TyL, Ty, (op F : TyL' -> Ty' to F' [AtS], VMAPS), M)
= if sameKind(M, TyL Ty, TyL' Ty')
then (op F : TyL' -> Ty' to F' [AtS],
getRightOpMaps(F, TyL, Ty, VMAPS, M))
else getRightOpMaps(F, TyL, Ty, VMAPS, M)
fi .
eq getRightOpMaps(F, TyL, Ty, termMap(F[TL], T), M)
= if sameKind(M, TyL, varListSort(TL))
then (termMap(F[TL], T))
else none
fi .
eq getRightOpMaps(F, TyL, Ty, (termMap(F[TL], T), VMAPS), M)
= if sameKind(M, TyL, varListSort(TL))
then (termMap(F[TL], T), getRightOpMaps(F, TyL, Ty, VMAPS, M))
else getRightOpMaps(F, TyL, Ty, VMAPS, M)
fi .
eq getRightOpMaps(F, TyL, Ty, (termMap(Ct, T)), M)
= if TyL == nil
and-then (F == getName(Ct)
and-then sameKind(M, Ty, getType(Ct)))
then (termMap(Ct, T))
else none
fi .
eq getRightOpMaps(F, TyL, Ty, (termMap(Ct, T), VMAPS), M)
= if TyL == nil
and-then (F == getName(Ct)
and-then sameKind(M, Ty, getType(Ct)))
then (termMap(Ct, T), getRightOpMaps(F, TyL, Ty, VMAPS, M))
else getRightOpMaps(F, TyL, Ty, VMAPS, M)
fi .
eq getRightOpMaps(F, TyL:[Type], Ty:[Type], VMAPS, M) = none [owise].
op varListSort : TermList -> TypeList .
eq varListSort((V, TL)) = (getType(V) varListSort(TL)) .
eq varListSort(empty) = nil .
*** Application of a map set to the set of attributes in an object
eq applyMapsToObjectAttrSet(VMAPS, VMAPS', C, '_`,_[A[T], TL], M)
= '_`,_[applyMapsToAttrNameInTerm(VMAPS', C, A, M)
[applyMapsToTerm2(VMAPS, VMAPS', T, M)],
applyMapsToObjectAttrSet(VMAPS, VMAPS', C, TL, M)] .
eq applyMapsToObjectAttrSet(VMAPS, VMAPS', C, A[T], M)
= applyMapsToAttrNameInTerm(VMAPS', C, A, M)
[applyMapsToTerm2(VMAPS, VMAPS', T, M)] .
eq applyMapsToObjectAttrSet(VMAPS, VMAPS', C,
'_`,_['none.AttributeSet, TL], M)
= '_`,_['none.AttributeSet,
applyMapsToObjectAttrSet(VMAPS, VMAPS', C, TL, M)] .
eq applyMapsToObjectAttrSet(VMAPS, VMAPS', C, 'none.AttributeSet, M)
= 'none.AttributeSet .
*** Image of a term
eq imageOfTerm(VMAPS, VMAPS', Ct, none, M)
= qid(string(getName(Ct)) + "."
+ string(applyMapsToType(VMAPS, getType(Ct)))) .
eq imageOfTerm(VMAPS, VMAPS', F[TL], none, M)
= F [ applyMapsToTerm2(VMAPS, VMAPS', TL, M) ] .
eq imageOfTerm(VMAPS, VMAPS', F[TL], (op F to F' [AtS]), M)
= F' [ applyMapsToTerm2(VMAPS, VMAPS', TL, M) ] .
eq imageOfTerm(VMAPS, VMAPS', F[TL], ((op F to F' [AtS]), VMAPS''), M)
= F' [ applyMapsToTerm2(VMAPS, VMAPS', TL, M) ] .
eq imageOfTerm(VMAPS, VMAPS', F[TL], (op F : TyL -> Ty to F'[AtS]), M)
= F' [ applyMapsToTerm2(VMAPS, VMAPS', TL, M) ] .
eq imageOfTerm(VMAPS, VMAPS', F[TL], (op F : TyL -> Ty to F'[AtS], VMAPS''),M)
= F' [ applyMapsToTerm2(VMAPS, VMAPS', TL, M) ] .
eq imageOfTerm(VMAPS, VMAPS', T, termMap(T', T''), M)
= applySubst(T'',
applyMapsToSubst(VMAPS, VMAPS', pseudoMatch(T', T, M, none), M)) .
eq imageOfTerm(VMAPS, VMAPS', T, (termMap(T', T''), VMAPS''), M)
= applySubst(T'',
applyMapsToSubst(VMAPS, VMAPS', pseudoMatch(T', T, M, none), M)) .
ceq imageOfTerm(VMAPS, VMAPS', Ct, (op F to F' [AtS]), M)
= qid(string(F') + "." + string(applyMapsToType(VMAPS, getType(Ct))))
if getName(Ct) = F .
ceq imageOfTerm(VMAPS, VMAPS', Ct, ((op F to F' [AtS]), VMAPS''), M)
= qid(string(F') + "." + string(applyMapsToType(VMAPS, getType(Ct))))
if getName(Ct) = F .
ceq imageOfTerm(VMAPS, VMAPS', Ct, (op F : TyL -> Ty to F' [AtS]), M)
= qid(string(F') + "." + string(applyMapsToType(VMAPS, getType(Ct))))
if getName(Ct) = F .
ceq imageOfTerm(VMAPS, VMAPS', Ct, (op F : TyL -> Ty to F' [AtS], VMAPS''),M)
= qid(string(F') + "." + string(applyMapsToType(VMAPS, getType(Ct))))
if getName(Ct) = F .
*** Application of a Substitution on a term
op applySubst : TermList Substitution -> TermList .
eq applySubst(T, none) = T .
eq applySubst(V, ((V' <- T) ; Subst))
= if getName(V) == getName(V')
then T
else applySubst(V, Subst)
fi .
eq applySubst(F[TL], Subst) = F[applySubst(TL, Subst)] .
eq applySubst(Ct, Subst) = Ct .
ceq applySubst((T, TL), Subst)
= (applySubst(T, Subst), applySubst(TL,Subst))
if TL =/= empty .
*** Application of a Substitution to a condition
op applySubst : Condition Substitution -> Condition .
eq applySubst(T = T' /\ Cd, Subst)
= (applySubst(T, Subst) = applySubst(T', Subst)) /\ applySubst(Cd, Subst) .
eq applySubst(T => T' /\ Cd, Subst)
= (applySubst(T, Subst) => applySubst(T', Subst)) /\ applySubst(Cd, Subst) .
eq applySubst(T : S /\ Cd, Subst)
= (applySubst(T, Subst) : S) /\ applySubst(Cd, Subst) .
eq applySubst((nil).EqCondition, Subst) = nil .
*** PseudoMatch
eq pseudoMatch(T, T', M, Subst)
= pseudoMatchResult(pseudoMatch2(T, T', M, Subst)) .
eq pseudoMatch2(Ct, Ct', M, Subst) = none .
eq pseudoMatch2(F[TL], F'[TL'], M, Subst)
= if F == F'
then pseudoMatch2(TL, TL', M, Subst)
else none
fi .
eq pseudoMatch2((V, TL), (T, TL'), M, Subst)
= if sameKind(M, getType(V), leastSort(M, T))
then pseudoMatch2(TL, TL', M, (V <- T ; Subst))
else none
fi .
eq pseudoMatch2(V, T, M, Subst)
= if sameKind(M, getType(V), leastSort(M, T))
then (V <- T ; Subst)
else none
fi .
eq pseudoMatch2((V, TL), (T, TL'), M, Subst)
= if sameKind(M, getType(V), leastSort(M, T))
then pseudoMatch2(TL, TL', M, (V <- T ; Subst))
else none
fi .
eq pseudoMatch2((Ct, TL), (Ct', TL'), M, Subst)
= if getName(Ct) == getName(Ct')
then pseudoMatch2(TL, TL', M, Subst)
else none
fi .
eq pseudoMatch2((F[TL], TL'), (F'[TL''], TL3), M, Subst)
= if F == F'
then pseudoMatch2(TL', TL3, M, pseudoMatch2(TL, TL'', M, none) ; Subst)
else none
fi .
eq pseudoMatch2(empty, empty, M, Subst) = Subst .
*** pseudoMatchResult detects conflicts and eliminates duplicates
eq pseudoMatchResult((V <- T) ; Subst)
= pseudoMatchResult(none, (V <- T), none, Subst) .
eq pseudoMatchResult(none) = none .
eq pseudoMatchResult(Subst, (V <- T), Subst', (V' <- T') ; Subst'')
= if V == V'
then if T == T'
then pseudoMatchResult(Subst, (V <- T), Subst', Subst'')
else none
fi
else pseudoMatchResult(Subst, (V <- T), Subst' ; (V' <- T'), Subst'')
fi .
eq pseudoMatchResult(Subst, (V <- T), (V' <- T') ; Subst', none)
= pseudoMatchResult(Subst ; (V <- T), (V' <- T'), none, Subst') .
eq pseudoMatchResult(Subst, (V <- T), none, none) = (Subst ; (V <- T)) .
*** Application of a set of maps to a substitution
eq applyMapsToSubst(VMAPS, VMAPS', ((V <- T) ; Subst), M)
= ((applyMapsToTerm2(VMAPS, VMAPS', V, M)
<- applyMapsToTerm2(VMAPS, VMAPS', T, M)) ;
applyMapsToSubst(VMAPS, VMAPS', Subst, M)) .
eq applyMapsToSubst(VMAPS, VMAPS', none, M) = none .
endfm
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
*** We do not include here the equations defining the semantics of the function
*** \texttt{applyMapsToTerm}. Instead, we present an example illustrating
*** the meaning of the function. Renaming maps and view maps were already
*** discussed in Sections~\ref{Views} and~\ref{module-expressions}.
*** Let us consider the following configuration in the module
*** \texttt{STACK2[Accnt]} presented in Section~\ref{module-expressions}. In
*** this configuration we have objects in the class \texttt{Accnt} which
*** represent the accounts of different clients of a bank, which is
*** represented as an object \texttt{'bank} of class \texttt{Stack[Accnt]}.
*** The object \texttt{'bank} in the example configuration below keeps a stack
*** with the accounts of the bank represented as a linked list of nodes, each
*** of which corresponds to the account of one of the clients.
*** ('bank push 'john)
*** ('peter elt 2000)
*** < 'bank : Stack[Accnt] | first : o ('bank, 1) >
*** < 'paul : Accnt | bal : 5000 >
*** < 'peter : Accnt | bal : 2000 >
*** < 'mary : Accnt | bal : 7200 >
*** < 'john : Accnt | bal : 100 >
*** < o('bank, 0) : Node[Accnt] | node : 'peter, next : null >
*** < o('bank, 1) : Node[Accnt] | node : 'mary, next : o('bank, 0) > .
***
*** Let us apply the following renaming to the previous term.
***
*** (op o to id,
*** class Stack[Accnt] to Bank,
*** msg _push_ : Oid Oid -> Msg to open`account`in_to_,
*** msg _pop to close`account`of_,
*** msg _elt_ to _owns_dollars,
*** attr node . Node[Accnt] to client,
*** attr bal . Accnt to balance)
***
*** The resulting term is as follows.
***
*** (open account in 'bank to 'john)
*** ('peter owns 2000 dollars)
*** < 'bank : Bank | first : id('bank, 1) >
*** < 'paul : Accnt | balance : 5000 >
*** < 'peter : Accnt | balance : 2000 >
*** < 'mary : Accnt | balance : 7200 >
*** < 'john : Accnt | balance : 100 >
*** < id('bank, 0) : Node[Accnt] | client : 'peter, next : null >
*** < id('bank, 1) : Node[Accnt] | client : 'mary, next : id('bank, 0) >
*** The function \texttt{applyMapsToTerm} treats the object constructor
*** \verb~<_:_|_>~ in a special way. It cannot be renamed, and, when an
*** occurrence of such a constructor is found, class and attribute maps require
*** a particular handling. Inside terms these maps are only triggered when
*** this constructor is found, and they are applied in a very restricted way,
*** according to the general pattern for objects. We assume that the operator
*** \verb~<_:_|_>~ is only used for objects and that objects constructed using
*** it are well-formed.
***
*** 6.8.2 Map STS on Modules
***
*** The application of view maps to modules and theories of the different types
*** is defined in the following module \texttt{VIEW-MAP-SET-APPL-ON-UNIT}. The
*** function \texttt{applyMapsToModule} is defined recursively by applying it
*** to the different components of a unit. When the terms in the different
*** declarations are reached, the function \texttt{applyMapsToTerm} is
*** called. This call is made with the set of maps split conveniently, as
*** explained above.
-------------------------------------------------------------------------------
*******************************************************************************
-------------------------------------------------------------------------------
fmod VIEW-MAP-SET-APPL-ON-UNIT is
pr VIEW-MAP-SET-APPL-ON-TERM .
pr INT-LIST .
pr VIEW-EXPR .
op applyMapsToModule : Set{ViewMap} Module Module -> Module .
op applyMapsToModuleAux : Set{ViewMap} Set{ViewMap} Module Module -> Module .
op splitMaps : Set{ViewMap} -> Tuple{Set{ViewMap},Set{ViewMap}} .
op splitMapsAux : Set{ViewMap} Set{ViewMap} Set{ViewMap}
-> Tuple{Set{ViewMap},Set{ViewMap}} .
op applyMapsToTypeList : Set{ViewMap} TypeList -> TypeList .
op applyMapsToSubsorts : Set{ViewMap} SubsortDeclSet -> SubsortDeclSet .
op applyMapsToOps : Set{ViewMap} Set{ViewMap} OpDeclSet Module
-> OpDeclSet .
op applyMapsToOp :
Set{ViewMap} Set{ViewMap} Set{ViewMap} OpDecl Module -> OpDecl .
op applyMapsToAttrs : Set{ViewMap} Set{ViewMap} AttrSet Module -> AttrSet .
op applyMapToAttrs : ViewMap AttrSet -> AttrSet .
op applyMapToAttrsAux : AttrSet AttrSet AttrSet -> AttrSet .
op applyMapsToHooks :
Set{ViewMap} Set{ViewMap} HookList Module -> HookList .
op applyMapsToHooksAux : Set{ViewMap} Set{ViewMap} Hook Module -> Hook .
op applyMapsToMbs : Set{ViewMap} Set{ViewMap} MembAxSet Module
-> MembAxSet .
op applyMapsToEqs :
Set{ViewMap} Set{ViewMap} EquationSet Module -> EquationSet .
op applyMapsToRls : Set{ViewMap} Set{ViewMap} RuleSet Module -> RuleSet .
op applyMapsToCond : Set{ViewMap} Set{ViewMap} Condition Module -> Condition .
op applyMapsToLabel : Set{ViewMap} Qid -> Qid .
op applyMapsToClassDeclSet :
Set{ViewMap} Set{ViewMap} ClassDeclSet -> ClassDeclSet .
op applyMapsToSubclassDeclSet :
Set{ViewMap} SubclassDeclSet -> SubclassDeclSet .
op applyMapsToMsgDeclSet :
Set{ViewMap} Set{ViewMap} MsgDeclSet Module -> MsgDeclSet .
op applyMapsToMsgDecl : Set{ViewMap} Set{ViewMap} MsgDecl Module -> MsgDecl .
op applyMapsToAttrName : Set{ViewMap} Sort Qid -> Qid .
op applyMapsToAttrDeclSet :
Set{ViewMap} Set{ViewMap} Sort AttrDeclSet -> AttrDeclSet .
vars M U : Module .
vars QI QI' QI'' L L' L'' F F' F'' A A' A'' : Qid .
vars V V' : Variable .
vars QIL QIL' : QidList .
var VE : ViewExp .
var H : Header .
var ME : ModuleExpression .
var PDL : ParameterDeclList .
var IL : ImportList .
vars S S' S'' C C' C'' : Sort .
var Ty : Type .
vars TyL TyL' : TypeList .
var SS : SortSet .
var SSDS : SubsortDeclSet .
var OPDS : OpDeclSet .
var MAS : MembAxSet .
var EqS : EquationSet .
var RlS : RuleSet .
var CDS : ClassDeclSet .
var SCDS : SubclassDeclSet .
var MDS : MsgDeclSet .
var ADS : AttrDeclSet .
vars T T' T'' T3 O : Term .
vars TL TL' : TermList .
var At : Attr .
vars AtS AtS' AtS'' : AttrSet .
vars I I' : Nat .
vars NL NL' : IntList .
var Hk : Hook .
var HkL : HookList .
var VMAP : ViewMap .
vars VMAPS VMAPS' VMAPS'' : Set{ViewMap} .
var Subst : Substitution .
var Cond : Condition .
var St : String .
var MN : ModuleName .
sort Tuple{Set{ViewMap},Set{ViewMap}} .
op <_;_> : Set{ViewMap} Set{ViewMap} -> Tuple{Set{ViewMap},Set{ViewMap}} .
ops sortMaps otherMaps : Tuple{Set{ViewMap},Set{ViewMap}} -> Set{ViewMap} .
eq sortMaps(< VMAPS ; VMAPS' >) = VMAPS .
eq otherMaps(< VMAPS ; VMAPS' >) = VMAPS' .
eq splitMaps(VMAPS) = splitMapsAux(VMAPS, none, none) .
eq splitMapsAux((sort S to S'), VMAPS', VMAPS'')
= splitMapsAux(none, ((sort S to S'), VMAPS'), VMAPS'') .
eq splitMapsAux(((sort S to S'), VMAPS), VMAPS', VMAPS'')
= splitMapsAux(VMAPS, ((sort S to S'), VMAPS'), VMAPS'') .
eq splitMapsAux(VMAP, VMAPS', VMAPS'')
= splitMapsAux(none, VMAPS', (VMAP, VMAPS'')) [owise] .
eq splitMapsAux((VMAP, VMAPS), VMAPS', VMAPS'')
= splitMapsAux(VMAPS, VMAPS', (VMAP, VMAPS'')) [owise] .
eq splitMapsAux(none, VMAPS, VMAPS') = < VMAPS ; VMAPS' > .
*** To avoid the interference between the sort maps with other maps, the map
*** set is divided in two sets.
ceq applyMapsToModule(VMAPS, U, M)
= applyMapsToModuleAux(VMAPS', VMAPS'', U, M)
if < VMAPS' ; VMAPS'' > := splitMaps(VMAPS) .
eq applyMapsToModule(VMAPS, U, unitError(QIL)) = unitError(QIL) .
eq applyMapsToModuleAux(VMAPS, VMAPS',
mod H is IL sorts SS . SSDS OPDS MAS EqS RlS endm,
M)
= mod H is
IL
sorts applyMapsToSortSet(VMAPS, SS) .
applyMapsToSubsorts(VMAPS, SSDS)
applyMapsToOps(VMAPS, VMAPS', OPDS, M)
applyMapsToMbs(VMAPS, VMAPS', MAS, M)
applyMapsToEqs(VMAPS, VMAPS', EqS, M)
applyMapsToRls(VMAPS, VMAPS', RlS, M)
endm .
eq applyMapsToModuleAux(VMAPS, VMAPS',
th MN is IL sorts SS . SSDS OPDS MAS EqS RlS endth,
M)
= th MN is
IL sorts applyMapsToSortSet(VMAPS, SS) .
applyMapsToSubsorts(VMAPS, SSDS)
applyMapsToOps(VMAPS, VMAPS', OPDS, M)
applyMapsToMbs(VMAPS, VMAPS', MAS, M)
applyMapsToEqs(VMAPS, VMAPS', EqS, M)
applyMapsToRls(VMAPS, VMAPS', RlS, M)
endth .
eq applyMapsToModuleAux(VMAPS, VMAPS',
fmod H is IL sorts SS . SSDS OPDS MAS EqS endfm,
M)
= fmod H is
IL
sorts applyMapsToSortSet(VMAPS, SS) .
applyMapsToSubsorts(VMAPS, SSDS)
applyMapsToOps(VMAPS, VMAPS', OPDS, M)
applyMapsToMbs(VMAPS, VMAPS', MAS, M)
applyMapsToEqs(VMAPS, VMAPS', EqS, M)
endfm .
eq applyMapsToModuleAux(VMAPS, VMAPS', fth MN is IL sorts SS . SSDS OPDS MAS EqS endfth, M)
= fth MN is
IL
sorts applyMapsToSortSet(VMAPS, SS) .
applyMapsToSubsorts(VMAPS, SSDS)
applyMapsToOps(VMAPS, VMAPS', OPDS, M)
applyMapsToMbs(VMAPS, VMAPS', MAS, M)
applyMapsToEqs(VMAPS, VMAPS', EqS, M)
endfth .
eq applyMapsToModuleAux(VMAPS, VMAPS',
omod H is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endom,
M)
= omod H is
IL
sorts applyMapsToSortSet(VMAPS, SS) .
applyMapsToSubsorts(VMAPS, SSDS)
applyMapsToClassDeclSet(VMAPS, VMAPS', CDS)
applyMapsToSubclassDeclSet(VMAPS', SCDS)
applyMapsToOps(VMAPS, VMAPS', OPDS, M)
applyMapsToMsgDeclSet(VMAPS, VMAPS', MDS, M)
applyMapsToMbs(VMAPS, VMAPS', MAS, M)
applyMapsToEqs(VMAPS, VMAPS', EqS, M)
applyMapsToRls(VMAPS, VMAPS', RlS, M)
endom .
eq applyMapsToModuleAux(VMAPS, VMAPS',
oth MN is
IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS
endoth,
M)
= oth MN is
IL
sorts applyMapsToSortSet(VMAPS, SS) .
applyMapsToSubsorts(VMAPS, SSDS)
applyMapsToClassDeclSet(VMAPS, VMAPS', CDS)
applyMapsToSubclassDeclSet(VMAPS', SCDS)
applyMapsToOps(VMAPS, VMAPS', OPDS, M)
applyMapsToMsgDeclSet(VMAPS, VMAPS', MDS, M)
applyMapsToMbs(VMAPS, VMAPS', MAS, M)
applyMapsToEqs(VMAPS, VMAPS', EqS, M)
applyMapsToRls(VMAPS, VMAPS', RlS, M)
endoth .
eq applyMapsToOps(VMAPS, VMAPS', (op F : TyL -> Ty [AtS] . OPDS), M)
= (applyMapsToOp(VMAPS, getRightOpMaps(F, TyL, Ty, VMAPS', M),
VMAPS', (op F : TyL -> Ty [AtS] .), M)
applyMapsToOps(VMAPS, VMAPS', OPDS, M)) .
eq applyMapsToOps(VMAPS, VMAPS', none, M) = none .
eq applyMapsToOp(VMAPS, VMAP, VMAPS', (op F : TyL -> Ty [AtS] .), M)
= (op applyOpMapsToOpId(F, VMAP) : applyMapsToTypeList(VMAPS, TyL)
-> applyMapsToType(VMAPS, Ty)
[applyMapsToAttrs(VMAPS, VMAPS', applyMapToAttrs(VMAP, AtS), M)] .) .
eq applyMapsToOp(VMAPS, (VMAP, VMAPS'), VMAPS'',
(op F : TyL -> Ty [AtS] .), M)
*** In case of ambiguous mappings we take one of them arbitrarily
= (op applyOpMapsToOpId(F, VMAP) : applyMapsToTypeList(VMAPS, TyL)
-> applyMapsToType(VMAPS, Ty)
[applyMapsToAttrs(VMAPS, VMAPS'', applyMapToAttrs(VMAP, AtS), M)] .) .
eq applyMapsToOp(VMAPS, none, VMAPS', (op F : TyL -> Ty [AtS] .), M)
*** No map for this declaration
= (op F : applyMapsToTypeList(VMAPS, TyL) -> applyMapsToType(VMAPS, Ty)
[applyMapsToAttrs(VMAPS, VMAPS', AtS, M)] .) .
eq applyMapsToMsgDeclSet(VMAPS, VMAPS', ((msg F : TyL -> Ty .) MDS), M)
= (applyMapsToMsgDecl(VMAPS, getRightOpMaps(F, TyL, Ty, VMAPS', M),
(msg F : TyL -> Ty .), M)
applyMapsToMsgDeclSet(VMAPS, VMAPS', MDS, M)) .
eq applyMapsToMsgDeclSet(VMAPS, VMAPS', none, M) = none .
eq applyMapsToMsgDecl(VMAPS, VMAP, (msg F : TyL -> Ty .), M)
= (msg applyOpMapsToOpId(F, VMAP) : applyMapsToTypeList(VMAPS, TyL)
-> applyMapsToType(VMAPS, Ty) .) .
eq applyMapsToMsgDecl(VMAPS, (VMAP, VMAPS'), (msg F : TyL -> Ty .), M)
*** In case of ambiguous mappings we take one of them arbitrarily
= (msg applyOpMapsToOpId(F, VMAP) : applyMapsToTypeList(VMAPS, TyL)
-> applyMapsToType(VMAPS, Ty) .) .
eq applyMapsToMsgDecl(VMAPS, none, (msg F : TyL -> Ty .), M)
*** No map for this declaration
= (msg F : applyMapsToTypeList(VMAPS, TyL)
-> applyMapsToType(VMAPS, Ty) .) .
*** The function \texttt{applyMapToAttrs} just takes care of changing the
*** attributes of the operators as indicated in the renamings. The renamings
*** properly said is accomplished by the function
*** \texttt{applyMapsToAttrs}.
eq applyMapToAttrs((msg F to F'), AtS) = AtS .
eq applyMapToAttrs((msg F : TyL -> Ty to F'), AtS) = AtS .
eq applyMapToAttrs(termMap(T, T'), AtS) = AtS .
eq applyMapToAttrs((op F to F' [AtS]), AtS')
= applyMapToAttrsAux(AtS, AtS', none) .
eq applyMapToAttrs((op F : TyL -> Ty to F' [AtS]), AtS')
= applyMapToAttrsAux(AtS, AtS', none) .
*** add the new syntactic attributes
eq applyMapToAttrsAux((gather(QIL) AtS), AtS', AtS'')
= applyMapToAttrsAux(AtS, AtS', (gather(QIL) AtS'')) .
eq applyMapToAttrsAux((format(QIL) AtS), AtS', AtS'')
= applyMapToAttrsAux(AtS, AtS', (format(QIL) AtS'')) .
eq applyMapToAttrsAux((prec(I) AtS), AtS', AtS'')
= applyMapToAttrsAux(AtS, AtS', (prec(I) AtS'')) .
eq applyMapToAttrsAux((At AtS), AtS', AtS'')
= applyMapToAttrsAux(AtS, AtS', AtS'')
[owise] .
*** remove the old syntactic attributes
eq applyMapToAttrsAux(AtS, (format(QIL) AtS'), AtS'')
= applyMapToAttrsAux(AtS, AtS', AtS'') .
eq applyMapToAttrsAux(AtS, (gather(QIL) AtS'), AtS'')
= applyMapToAttrsAux(AtS, AtS', AtS'') .
eq applyMapToAttrsAux(AtS, (prec(I) AtS'), AtS'')
= applyMapToAttrsAux(AtS, AtS', AtS'') .
eq applyMapToAttrsAux(none, (At AtS), AtS')
= applyMapToAttrsAux(none, AtS, (At AtS')) .
eq applyMapToAttrsAux(none, none, AtS) = AtS .
eq applyMapsToTypeList(VMAPS, (Ty TyL))
= (applyMapsToType(VMAPS, Ty) applyMapsToTypeList(VMAPS, TyL)) .
eq applyMapsToTypeList(VMAPS, nil) = nil .
eq applyMapsToSubsorts(VMAPS, ((subsort S < S' .) SSDS))
= ((subsort applyMapsToType(VMAPS, S)
< applyMapsToType(VMAPS, S') .)
applyMapsToSubsorts(VMAPS, SSDS)) .
eq applyMapsToSubsorts(VMAPS, none) = none .
eq applyMapsToAttrs(VMAPS, VMAPS', (id(T) AtS), M)
= (id(applyMapsToTerm2(VMAPS, VMAPS', T, M))
applyMapsToAttrs(VMAPS, VMAPS', AtS, M)) .
eq applyMapsToAttrs(VMAPS, VMAPS', (left-id(T) AtS), M)
= (left-id(applyMapsToTerm2(VMAPS, VMAPS', T, M))
applyMapsToAttrs(VMAPS, VMAPS', AtS, M)) .
eq applyMapsToAttrs(VMAPS, VMAPS', (right-id(T) AtS), M)
= (right-id(applyMapsToTerm2(VMAPS, VMAPS', T, M))
applyMapsToAttrs(VMAPS, VMAPS', AtS, M)) .
eq applyMapsToAttrs(VMAPS, VMAPS', (special(HkL) AtS), M)
= (special(applyMapsToHooks(VMAPS, VMAPS', HkL, M))
applyMapsToAttrs(VMAPS, VMAPS', AtS, M)) .
eq applyMapsToAttrs(VMAPS, VMAPS', (label(L) AtS), M)
= (label(applyMapsToLabel(VMAPS, L))
applyMapsToAttrs(VMAPS, VMAPS', AtS, M)) .
eq applyMapsToAttrs(VMAPS, VMAPS', AtS, M) = AtS [owise] .
eq applyMapsToHooks(VMAPS, VMAPS', id-hook(QI, QIL) HkL, M)
= id-hook(QI, QIL)
applyMapsToHooks(VMAPS, VMAPS', HkL, M).
eq applyMapsToHooks(VMAPS, VMAPS', op-hook(QI, QI', QIL, QI'') HkL, M)
= applyMapsToHooksAux(VMAPS,
getRightOpMaps(QI', QIL, QI'', VMAPS', M),
op-hook(QI, QI', QIL, QI''), M)
applyMapsToHooks(VMAPS, VMAPS', HkL, M).
eq applyMapsToHooks(VMAPS, VMAPS', term-hook(QI, T) HkL, M)
= term-hook(QI, applyMapsToTerm2(VMAPS, VMAPS', T, M))
applyMapsToHooks(VMAPS, VMAPS', HkL, M).
eq applyMapsToHooks(VMAPS, VMAPS', nil, M) = nil .
eq applyMapsToHooksAux(VMAPS, VMAP, op-hook(QI, F, TyL, Ty), M)
= op-hook(QI, applyOpMapsToOpId(F, VMAP),
applyMapsToTypeList(VMAPS, TyL), applyMapsToType(VMAPS, Ty)) .
eq applyMapsToHooksAux(VMAPS, (VMAP, VMAPS'), op-hook(QI, F, TyL, Ty), M)
*** In case of ambiguous mappings we take any of them arbitrarily
= op-hook(QI, applyOpMapsToOpId(F, VMAP),
applyMapsToTypeList(VMAPS, TyL), applyMapsToType(VMAPS, Ty)) .
eq applyMapsToHooksAux(VMAPS, none, op-hook(QI, F, TyL, Ty), M)
= op-hook(QI, F, applyMapsToTypeList(VMAPS, TyL),
applyMapsToType(VMAPS, Ty)) .
eq applyMapsToMbs(VMAPS, VMAPS', ((mb T : S [AtS] .) MAS), M)
= ((mb applyMapsToTerm2(VMAPS, VMAPS', T, M)
: applyMapsToType(VMAPS, S)
[applyMapsToAttrs(VMAPS, VMAPS', AtS, M)] .)
applyMapsToMbs(VMAPS, VMAPS', MAS, M)) .
eq applyMapsToMbs(VMAPS, VMAPS', ((cmb T : S if Cond [AtS] .) MAS),
M)
= ((cmb applyMapsToTerm2(VMAPS, VMAPS', T, M)
: applyMapsToType(VMAPS, S)
if applyMapsToCond(VMAPS, VMAPS', Cond, M)
[applyMapsToAttrs(VMAPS, VMAPS', AtS, M)] .)
applyMapsToMbs(VMAPS, VMAPS', MAS, M)) .
eq applyMapsToMbs(VMAPS, VMAPS', none, M) = none .
eq applyMapsToEqs(VMAPS, VMAPS', ((ceq T = T' if Cond [AtS] .) EqS), M)
= ((ceq applyMapsToTerm2(VMAPS, VMAPS', T, M)
= applyMapsToTerm2(VMAPS, VMAPS', T', M)
if applyMapsToCond(VMAPS, VMAPS', Cond, M)
[applyMapsToAttrs(VMAPS, VMAPS', AtS, M)] .)
applyMapsToEqs(VMAPS, VMAPS', EqS, M)) .
eq applyMapsToEqs(VMAPS, VMAPS', ((eq T = T' [AtS] .) EqS), M)
= ((eq applyMapsToTerm2(VMAPS, VMAPS', T, M)
= applyMapsToTerm2(VMAPS, VMAPS', T', M)
[applyMapsToAttrs(VMAPS, VMAPS', AtS, M)] .)
applyMapsToEqs(VMAPS, VMAPS', EqS, M)) .
eq applyMapsToEqs(VMAPS, VMAPS', none, M) = none .
eq applyMapsToRls(VMAPS, VMAPS', ((crl T => T' if Cond [AtS] .) RlS), M)
= ((crl applyMapsToTerm2(VMAPS, VMAPS', T, M)
=> applyMapsToTerm2(VMAPS, VMAPS', T', M)
if applyMapsToCond(VMAPS, VMAPS', Cond, M)
[applyMapsToAttrs(VMAPS, VMAPS', AtS, M)] .)
applyMapsToRls(VMAPS, VMAPS', RlS, M)) .
eq applyMapsToRls(VMAPS, VMAPS', ((rl T => T' [AtS] .) RlS), M)
= ((rl applyMapsToTerm2(VMAPS, VMAPS', T, M)
=> applyMapsToTerm2(VMAPS, VMAPS', T', M)
[applyMapsToAttrs(VMAPS, VMAPS', AtS, M)] .)
applyMapsToRls(VMAPS, VMAPS', RlS, M)) .
eq applyMapsToRls(VMAPS, VMAPS', none, M) = none .
eq applyMapsToCond(VMAPS, VMAPS', T = T' /\ Cond, M)
= applyMapsToTerm2(VMAPS, VMAPS', T, M)
= applyMapsToTerm2(VMAPS, VMAPS', T', M)
/\ applyMapsToCond(VMAPS, VMAPS', Cond, M) .
eq applyMapsToCond(VMAPS, VMAPS', T : S /\ Cond, M)
= applyMapsToTerm2(VMAPS, VMAPS', T, M)
: applyMapsToSort(VMAPS, S)
/\ applyMapsToCond(VMAPS, VMAPS', Cond, M) .
eq applyMapsToCond(VMAPS, VMAPS', T := T' /\ Cond, M)
= applyMapsToTerm2(VMAPS, VMAPS', T, M)
:= applyMapsToTerm2(VMAPS, VMAPS', T', M)
/\ applyMapsToCond(VMAPS, VMAPS', Cond, M) .
eq applyMapsToCond(VMAPS, VMAPS', T => T' /\ Cond, M)
= applyMapsToTerm2(VMAPS, VMAPS', T, M)
=> applyMapsToTerm2(VMAPS, VMAPS', T', M)
/\ applyMapsToCond(VMAPS, VMAPS', Cond, M) .
eq applyMapsToCond(VMAPS, VMAPS', nil, M) = nil .
eq applyMapsToLabel((label L to L'), L'')
= if L == L''
then L'
else L''
fi .
eq applyMapsToLabel(((label L to L'), VMAPS), L'')
= if L == L''
then L'
else applyMapsToLabel(VMAPS, L'')
fi .
eq applyMapsToLabel(VMAP, L) = L [owise] .
eq applyMapsToLabel((VMAP, VMAPS), L)
= applyMapsToLabel(VMAPS, L)
[owise] .
eq applyMapsToLabel(none, L) = L .
eq applyMapsToClassDeclSet(VMAPS, VMAPS', ((class C | ADS .) CDS))
= ((class applyMapsToClassName(VMAPS', C) |
applyMapsToAttrDeclSet(VMAPS, VMAPS', C, ADS) .)
applyMapsToClassDeclSet(VMAPS, VMAPS', CDS)) .
eq applyMapsToClassDeclSet(VMAPS, VMAPS', none) = none .
eq applyMapsToAttrDeclSet(VMAPS, VMAPS', C, ((attr A : Ty), ADS))
= ((attr applyMapsToAttrName(VMAPS', C, A) : applyMapsToType(VMAPS, Ty)),
applyMapsToAttrDeclSet(VMAPS, VMAPS', C, ADS)) .
eq applyMapsToAttrDeclSet(VMAPS, VMAPS', C, none) = none .
eq applyMapsToAttrName((attr A . C to A'), C', A'')
= if (C == C') and (A == A'')
then A'
else A''
fi .
eq applyMapsToAttrName(((attr A . C to A'), VMAPS), C', A'')
= if (C == C') and (A == A'')
then A'
else applyMapsToAttrName(VMAPS, C', A'')
fi .
eq applyMapsToAttrName(VMAP, C, A) = A [owise] .
eq applyMapsToAttrName((VMAP, VMAPS), C, A)
= applyMapsToAttrName(VMAPS, C, A)
[owise] .
eq applyMapsToAttrName(none, C, A) = A .
eq applyMapsToSubclassDeclSet(VMAPS, ((subclass C < C' .) SCDS))
= ((subclass applyMapsToClassName(VMAPS, C)
< applyMapsToClassName(VMAPS, C') .)
applyMapsToSubclassDeclSet(VMAPS, SCDS)) .
eq applyMapsToSubclassDeclSet(VMAPS, none) = none .
endfm
*******************************************************************************
***
*** 6.9 Instantiation of Parameterized Modules and the
*** \texttt{META-LEVEL} Module Expression
*** A parameterized module
*** $\texttt{M[L}_1\texttt{\ ::\ T}_1\texttt{,\}\ldots\texttt{, L}_n
*** \texttt{ :: T}_n\texttt{]}$, with \mbox{$\texttt{L}_1\ldots\texttt{L}_n$}
*** labels and \mbox{$\texttt{T}_1\ldots\texttt{T}_n$} theory identifiers, is
*** represented as a module with name \texttt{M} which contains parameter
*** declarations \mbox{$\texttt{par\ L}_i\texttt{\ ::\ T}_i$} for
*** $1\leq i\leq n$, and an importation declaration
*** \mbox{$\texttt{inc\ par\ L}_i\texttt{\ ::\ T}_i\texttt{\ .}$} for each
*** parameter \mbox{$\texttt{L}_i\texttt{\ ::\ T}_i$} in its interface. Note
*** that all modules are handled in a uniform way: nonparameterized modules
*** and theories have their list of parameters set to \texttt{nil}.
*** The instantiation of the formal parameters of a parameterized module with
*** actual modules or theories requires a view from each formal parameter
*** theory to its corresponding actual unit. The process of instantiation
*** results in the replacement of each interface theory by its corresponding
*** actual parameter, using the views to bind actual names to formal names.
*** The naming conventions for sorts have to be taken into account in the
*** instantiation process: every occurrence of a sort coming from a theory in
*** the interface of a module must be qualified by its theory's label, and
*** sorts defined in the body of a parameterized module can be parameterized
*** by the labels in the interface of the module (see
*** Section~\ref{parameterized-modules}).
*** The labeling convention for theories and for the sorts coming from them is
*** very useful to avoid collisions of sort names coming from the parameter
*** theories, and also to allow different uses of the same theory several
*** times in the interface of a module. We assume that all sorts coming from
*** the theory part of the parameter theories are used in their qualified form
*** to manipulate the maps defined in the views before being applied to the
*** body of the module being instantiated. If the target of a view is a
*** theory, the sorts from the theory part of the target theory appearing in
*** the targTS of the maps in the view will be qualified as well, following
*** the same convention.
*** When a parameterized module
*** $\texttt{M[L}_1\texttt{\ ::\ T}_1\texttt{,\ }
*** \ldots\texttt{,\ L}_n\texttt{\ ::\ T}_n\texttt{]}$
*** is instantiated with views $\texttt{V}_1\ldots\texttt{V}_n$, each
*** parameterized sort $\texttt{S[L}_1\texttt{,}\ldots\texttt{,L}_n\texttt{]}$
*** in the body of the parameterized module is renamed to
*** $\texttt{S[V}_1\texttt{,}\ldots\texttt{,V}_n\texttt{]}$.
*** The discussion on the qualification of sorts in views before being used in
*** the instantiation process applies in a completely similar way to class
*** names in parameterized object-oriented modules.
*** As we saw in Section~\ref{module-expressions}, it is possible to import a
*** module expression in which a parameterized module is instantiated by some
*** of the formal parameters of the parameterized module in which it is
*** imported. This is done by using the label of some of the parameters in the
*** interface of a module, say \mbox{$\texttt{L}_k\texttt{\ ::\ T}_k$}, in a
*** module expression in which some parameterized module \texttt{N} with formal
*** parameter $\texttt{T}_k$ is instantiated with $\texttt{L}_k$, that is, we
*** have the module expression $\texttt{N[}\ldots\texttt{L}_k\ldots\texttt{]}$.
*** In this case, $\texttt{L}_k$ is considered as the identity view for the
*** theory $\texttt{T}_k$ with $\texttt{L}_k$ as name. Note that to be able to
*** check whether a label in the interface of a module is used in an
*** instantiation of this form, in the evaluation of a module expression the
*** list of parameters of the module in which the module expression appears
*** must be available. This is the reason why the \texttt{evalModExp} function
*** was defined with \texttt{ParameterList} as one of the sorts in its
*** arity (see Section~\ref{evalModExp}). For module expressions appearing
*** outside of any module, that is, in commands, etc., this list will be set
*** to \texttt{nil}.
*** Note that this kind of instantiation may produce a `cascade' effect. The
*** module being instantiated may itself import other module expressions in
*** which labels of some of its parameter theories are used in the
*** instantiation of some of these imported module expressions. This is handled
*** by `preparing' the module expressions appearing in the importation
*** declarations of the module (\texttt{prepImports}). This process
*** consists in changing the labels of the interface of the module being
*** instantiated which are used in the importations of module expressions by
*** the corresponding view names (\texttt{prepHeader}). After completing the
*** generation of the module resulting from the evaluation of the module
*** expression, this module will be evaluated with the \texttt{evalModule}
*** function, producing the evaluation of these new module expressions. In any
*** extension of the language, new equations for the function
*** \texttt{prepHeader} will have to be added for each new kind of module
*** expression being defined.
*** In Sections~\ref{renaming} and~\ref{extension} we shall see how new
*** equations completing the semantics of \texttt{prepHeader} are added for
*** each new module expression being defined. In the case of the renaming
*** module expression, the renaming maps will have to be prepared as well, to
*** adjust the sort names being renamed to the conventions discussed above.
*** As for any other module expression being defined, in addition to the
*** operator declaration for the constructor of the instantiation module
*** expression, equations completing the semantics of operators
*** \texttt{evalModExp}, \texttt{header2QidList}, and
*** \texttt{setUpModExpDeps} have to be given.
fmod INST-EXPR-EVALUATION is
pr EVALUATION .
pr VIEW-MAP-SET-APPL-ON-UNIT .
inc MOD-EXPR .
inc MOD-NAME .
pr DATABASE .
*** We start by giving the new constructor for sort \texttt{ModuleExpression}.
*** Note thatthe modules \texttt{MOD-EXPR} and \texttt{MOD-NAME} have been
*** imported in \texttt{including} mode.
vars QI QI' QI'' X Y W Z C F F' A A' L L' : Qid .
var QIL : QidList .
vars M M' PU U U' U'' DM : Module .
var Th : OTheory .
vars ME ME' ME'' : ModuleExpression .
var H : Header .
vars MN MN' : ModuleName .
vars MNS MNS' MNS'' MNS3 MNS4 MNS5 : Set{ModuleName} .
vars VE VE' VE'' VE3 VE4 : ViewExp .
vars VES VES' : Set{ViewExp} .
vars MIS MIS' : Set{ModuleInfo} .
var VIS : Set{ViewInfo} .
vars DB DB' DB'' : Database .
var PD : ParameterDecl .
vars PDL PDL' PDL'' PDL3 PDL4 PDL5 : ParameterDeclList .
var PDS : Set{ParameterDecl} .
vars PL PL' PL'' PL3 : ParameterList .
vars S S' P P' P'' : Sort .
vars IL IL' IL'' IL3 : ImportList .
vars VMAPS VMAPS' VMAPS'' VMAPS3 : Set{ViewMap} .
var V : Variable .
var Ct : Constant .
var SL : QidList .
var Ty : Type .
var TyL : TypeList .
vars SS SS' SS'' : SortSet .
var K : Kind .
vars T T' O : Term .
var DT : Default{Term} .
var TL : TermList .
var CDS : ClassDeclSet .
var ADS : AttrDeclSet .
var B : Bool .
var AtS : AttrSet .
var VMAP : ViewMap .
var N : Nat .
var PV : PreView .
var VI : View .
var VDS : OpDeclSet .
*** In the input given by the user, the operator \verb~_(_)~ is used both for
*** the instantiation of module expressions, and for expressions
*** parameterizing the module \texttt{META-LEVEL} with a list of module names.
*** The function \texttt{evalModExp} distinguishes these two cases, calling
*** the function \texttt{unitInst} in the former and the function
*** \texttt{prepMetalevel} in the latter.
op unitInst : Header ParameterList ParameterDeclList Database -> Database .
op prepMetalevel : ParameterList Database -> Database .
eq evalModExp(ME{PL}, PDL, DB)
= if unitInDb(ME{PL}, DB)
then < DB ; ME{PL} >
else if ME == 'META-LEVEL
then < prepMetalevel(PL, DB) ; ME{PL} >
else < unitInst(
modExp(evalModExp(ME, PDL, evalViewExp(PL, PDL, DB))),
PL, PDL,
database(evalModExp(ME, PDL, evalViewExp(PL, PDL, DB))))
;
modExp(evalModExp(ME, PDL, evalViewExp(PL, PDL, DB))){PL} >
fi
fi .
*** The function \texttt{prepMetalevel} creates a new module with the
*** module expression being evaluated as name, which imports the predefined
*** \texttt{META-LEVEL} module. For each module name \texttt{I} in the list
*** given as parameter of the expression, the declaration of a constant
*** \texttt{I} of sort \texttt{Module} and an equation identifying such
*** constant with the metarepresentation of the module with such name in the
*** database are added to the module being created.
op prepMetalevelAux : ParameterList Module Database -> Database .
eq prepMetalevel(PL, DB)
= prepMetalevelAux(PL,
addImports((including 'META-LEVEL .),
setName(emptyFModule, 'META-LEVEL{PL})), DB) .
eq prepMetalevelAux((QI), U, DB)
= prepMetalevelAux(nil,
addOps((op qid("META-" + string(QI)) : nil -> 'Module [none] .),
addEqs((eq qid("META-" + string(QI) + ".Module")
= up(getFlatModule(QI, database(evalModExp(QI, DB))))
[none] .),
U)),
DB) .
eq prepMetalevelAux((QI, PL), U, DB)
= prepMetalevelAux(PL,
addOps((op qid("META-" + string(QI)) : nil -> 'Module [none] .),
addEqs((eq qid("META-" + string(QI) + ".Module")
= up(getFlatModule(QI, database(evalModExp(QI, DB))))
[none] .),
U)),
DB) .
eq prepMetalevelAux(nil, U, DB) = evalModule(U, none, DB) .
*** The function \texttt{getClassNames} returns the set of the names of
*** the classes in a set of class declarations.
op getClassNames : ClassDeclSet -> SortSet .
eq getClassNames(((class S | ADS .) CDS))
= (S ; getClassNames(CDS)) .
eq getClassNames(none) = none .
*** The following `getTh' functions return the corresponding elements in the
*** theory part of the structure of the given unit. For example, the function
*** \texttt{getThSorts} returns the set of sorts declared in the ``loose
*** part'' of the structure of the unit in the database having the name
*** indicated as first argument.
op getThSorts : ModuleExpression Database -> SortSet .
op getThClasses : ModuleExpression Database -> SortSet .
op getThSortsAux : ImportList Database -> SortSet .
op getThClassesAux : ImportList Database -> SortSet .
eq getThSorts(ME, DB)
= if theory(getTopModule(ME, DB))
then (getThSortsAux(getImports(getTopModule(ME, DB)), DB) ;
getSorts(getTopModule(ME, DB)))
else none
fi .
eq getThSortsAux(((including MN .) IL), DB)
= (getThSorts(MN, DB) ; getThSortsAux(IL, DB)) .
eq getThSortsAux(((extending MN .) IL), DB)
= (getThSorts(MN, DB) ; getThSortsAux(IL, DB)) .
eq getThSortsAux(((protecting MN .) IL), DB)
= (getThSorts(MN, DB) ; getThSortsAux(IL, DB)) .
eq getThSortsAux(nil, DB) = none .
eq getThClasses(ME, DB)
= if getTopModule(ME, DB) :: OTheory
and-then not getTopModule(ME, DB) :: STheory
then (getThClassesAux(getImports(getTopModule(ME, DB)), DB) ;
getClassNames(getClasses(getTopModule(ME, DB))))
else none
fi .
eq getThClassesAux(((including MN .) IL), DB)
= (getThClasses(MN, DB) ; getThClassesAux(IL, DB)) .
eq getThClassesAux(((extending MN .) IL), DB)
= (getThClasses(MN, DB) ; getThClassesAux(IL, DB)) .
eq getThClassesAux(((protecting MN .) IL), DB)
= (getThClasses(MN, DB) ; getThClassesAux(IL, DB)) .
eq getThClassesAux(nil, DB) = none .
*** The `get' functions return the corresponding elements in the structure of
*** the given unit. For example, \texttt{getSortSet} returns all the sorts
*** declared in the structure of the unit in the database having the name
*** given as first argument.
op getSortSet : ModuleName Database -> SortSet .
op getClassSet : ModuleName Database -> SortSet .
op getSortSetAux : ImportList Database -> SortSet .
op getClassSetAux : ImportList Database -> SortSet .
eq getSortSet(MN, DB)
= (getSortSetAux(getImports(getTopModule(MN, DB)), DB) ;
getSorts(getTopModule(MN, DB))) .
eq getSortSetAux(((including MN .) IL), DB)
= (getSortSet(MN, DB) ; getSortSetAux(IL, DB)) .
eq getSortSetAux(((extending MN .) IL), DB)
= (getSortSet(MN, DB) ; getSortSetAux(IL, DB)) .
eq getSortSetAux(((protecting MN .) IL), DB)
= (getSortSet(MN, DB) ; getSortSetAux(IL, DB)) .
eq getSortSetAux(nil, DB) = none .
eq getClassSet(MN, DB)
= (getClassSetAux(getImports(getTopModule(MN, DB)), DB) ;
getClassNames(getClasses(getTopModule(MN, DB)))) .
eq getClassSetAux(((including MN .) IL), DB)
= (getClassSet(MN, DB) ; getClassSetAux(IL, DB)) .
eq getClassSetAux(((extending MN .) IL), DB)
= (getClassSet(MN, DB) ; getClassSetAux(IL, DB)) .
eq getClassSetAux(((protecting MN .) IL), DB)
= (getClassSet(MN, DB) ; getClassSetAux(IL, DB)) .
eq getClassSetAux(nil, DB) = none .
*** As pointed out in Section~\ref{parameterized-modules}, in a parameterized
*** module all occurrences of sorts or classes coming from the parameter
*** theories have to be qualified. \texttt{createCopy} is the function used
*** for creating these renamed copies of the parameters. As also explained in
*** Section~\ref{parameterized-modules}, if a parameter theory is structured,
*** the renaming is carried out not only at the top level, but for the entire
*** ``theory part'' in the structure.
*** The function \texttt{createCopy} calls an auxiliary function,
*** \texttt{prepPar}, which recursively proceeds through all the subtheories
*** of the given theory. For each theory in the structure, the required set of
*** maps is generated and applied to such a theory using the
*** \texttt{applyMapsToModule} function discussed in
*** Section~\ref{applyMapsToModule}, which is then evaluated and entered into
*** the database. Note that the renamings to which a theory is subjected must
*** also be applied to the theories importing it. The new database and the
*** renaming maps applied to the theory will have to be returned by the
*** function.
*** The function \texttt{prepPar} makes a copy of the theory specified by the
*** name given as first argument and of all its subtheories (only theories, no
*** modules), and qualifies all the sorts appearing in it with the label given
*** in the declaration of the parameter, which is given as second argument.
pr 2TUPLE{ViewExp,ViewExp}
* (op ((_,_)) to <_;_>,
op p1_ to 1st,
op p2_ to 2nd).
sorts ---- Tuple{ViewExp,ViewExp}
Set{Tuple{ViewExp,ViewExp}}
prepParResult .
subsort Tuple{ViewExp,ViewExp} < Set{Tuple{ViewExp,ViewExp}} .
---- op <_;_> : ViewExp ViewExp -> Tuple{ViewExp,ViewExp} .
---- ops 1st 2nd : Tuple{ViewExp,ViewExp} -> ViewExp .
op none : -> Set{Tuple{ViewExp,ViewExp}} .
op __ : Set{Tuple{ViewExp,ViewExp}} Set{Tuple{ViewExp,ViewExp}}
-> Set{Tuple{ViewExp,ViewExp}} [assoc comm id: none] .
vars VEPS VEPS' : Set{Tuple{ViewExp,ViewExp}} .
---- eq 1st(< VE ; VE' >) = VE .
---- eq 2nd(< VE ; VE' >) = VE' .
op prepPar : Qid Qid ModuleExpression Database -> prepParResult .
op prepParImports : ImportList ImportList Qid Qid RenamingSet
Set{Tuple{ViewExp,ViewExp}} ParameterDeclList Database
-> prepParResult .
op <_;_;_;_;_;_;_> : RenamingSet Database ViewExp ViewExp
Set{Tuple{ViewExp,ViewExp}} Bool ImportList
-> prepParResult .
op mapSet : prepParResult -> RenamingSet .
op database : prepParResult -> Database .
op sourceViewExp : prepParResult -> ViewExp .
op targetViewExp : prepParResult -> ViewExp .
op viewExpPairSet : prepParResult -> Set{Tuple{ViewExp,ViewExp}} .
op theoryFlag : prepParResult -> Bool .
op getImports : prepParResult -> ImportList .
eq mapSet(< VMAPS ; DB ; VE ; VE' ; VEPS ; B ; IL >) = VMAPS .
eq database(< VMAPS ; DB ; VE ; VE' ; VEPS ; B ; IL >) = DB .
eq sourceViewExp(< VMAPS ; DB ; VE ; VE' ; VEPS ; B ; IL >) = VE .
eq targetViewExp(< VMAPS ; DB ; VE ; VE' ; VEPS ; B ; IL >) = VE' .
eq viewExpPairSet(< VMAPS ; DB ; VE ; VE' ; VEPS ; B ; IL >) = VEPS .
eq theoryFlag(< VMAPS ; DB ; VE ; VE' ; VEPS ; B ; IL >) = B .
eq getImports(< VMAPS ; DB ; VE ; VE' ; VEPS ; B ; IL >) = IL .
----op createCopy : ParameterDecl Database -> Database .
op prepPar : Qid ModuleExpression Database -> prepParResult .
op prepParImports : ImportList ImportList Qid RenamingSet
Set{Tuple{ViewExp,ViewExp}} ParameterDeclList Database
-> prepParResult .
eq createCopy(X :: ME, DB)
= if unitInDb(pd(X :: ME), DB)
then DB
else database(prepPar(X, ME, database(evalModExp(ME, DB))))
fi .
ceq prepPar(X, ME, DB)
= < (VMAPS'', VMAPS3) ;
(if unitInDb(pd(X :: ME), DB)
then DB
else evalModule(
setImports(
setName(
applyMapsToModule(
(VMAPS'', VMAPS3),
Th,
getFlatModule(ME, DB)),
pd(X :: ME)),
IL),
applyMapsToOps(
VMAPS'',
VMAPS3,
getVars(ME, DB),
getFlatModule(ME, DB)),
DB')
fi) ;
mtViewExp ; mtViewExp ; none ; true ; nil >
if Th := getTopModule(ME, DB)
/\ < VMAPS ; DB' ; VE ; VE' ; VEPS ; B ; IL >
:= prepParImports(getImports(Th), nil, X, none, none, X :: ME, DB)
/\ < VMAPS'' ; VMAPS3 >
:= splitMaps(
(VMAPS,
sortMapsPar(X, getSorts(Th), none),
classMapsPar(X, classSet(getClasses(Th)), none))) .
eq prepPar(X, ME, DB)
= < none ; warning(DB, '\r 'Error3: '\o 'Incorrect 'parameter '\n) ;
mtViewExp ; mtViewExp ; none ; false ; nil >
[owise] .
ceq prepParImports(((including ME .) IL), IL', X, VMAPS, VEPS, PDL, DB)
= if B
then prepParImports(IL, (IL' (including pd(X :: ME') .)),
X, (VMAPS, VMAPS'), VEPS, PDL, DB')
else prepParImports(IL, (IL' (including ME .)), X, VMAPS, VEPS, PDL, DB)
fi
if ME' := prepModExp(ME, VEPS)
/\ < VMAPS' ; DB' ; VE ; VE' ; VEPS' ; B ; IL'' >
:= prepPar(X, ME', database(evalModExp(ME', PDL, DB))) .
ceq prepParImports(((extending ME .) IL), IL', X, VMAPS, VEPS, PDL, DB)
= if B
then *** A theory shouldn't be imported in protecting mode
prepParImports(IL, (IL' (extending pd(X :: ME') .)),
X, (VMAPS, VMAPS'), VEPS, PDL, DB')
else prepParImports(IL, (IL' (extending ME .)), X, VMAPS, VEPS, PDL, DB)
fi
if ME' := prepModExp(ME, VEPS)
/\ < VMAPS' ; DB' ; VE ; VE' ; VEPS' ; B ; IL'' >
:= prepPar(X, ME', database(evalModExp(ME', PDL, DB))) .
ceq prepParImports(((protecting ME .) IL), IL', X, VMAPS, VEPS, PDL, DB)
= if B
then *** A theory shouldn't be imported in protecting mode
prepParImports(IL, (IL' (protecting pd(X :: ME') .)),
X, (VMAPS, VMAPS'), VEPS, PDL, DB')
else prepParImports(IL, (IL' (protecting ME .)), X, VMAPS, VEPS, PDL, DB)
fi
if ME' := prepModExp(ME, VEPS)
/\ < VMAPS' ; DB' ; VE ; VE' ; VEPS' ; B ; IL'' >
:= prepPar(X, ME', database(evalModExp(ME', PDL, DB))) .
ceq prepParImports(((including pd(X :: ME) .) IL), IL',
Y, VMAPS, (< X ; Z > VEPS), PDL, DB)
= prepParImports(IL, (IL' (including pd(Z :: ME') .)),
Y, (VMAPS, VMAPS'), (< X ; Z > VEPS), PDL, DB')
if ME' := prepModExp(ME, VEPS)
/\ < VMAPS' ; DB' ; VE ; VE' ; VEPS' ; B ; IL'' >
:= prepPar(X, ME', database(evalModExp(ME', PDL, DB))) .
ceq prepParImports(((extending pd(X :: ME) .) IL), IL',
Y, VMAPS, (< X ; Z > VEPS), PDL, DB)
= prepParImports(IL, (IL' (extending pd(Z :: ME') .)),
Y, (VMAPS, VMAPS'), (< X ; Z > VEPS), PDL, DB')
if ME' := prepModExp(ME, VEPS)
/\ < VMAPS' ; DB' ; VE ; VE' ; VEPS' ; B ; IL'' >
:= prepPar(X, ME', database(evalModExp(ME', PDL, DB))) .
ceq prepParImports(((protecting pd(X :: ME) .) IL), IL',
Y, VMAPS, (< X ; Z > VEPS), PDL, DB)
= prepParImports(IL, (IL' (protecting pd(Z :: ME') .)),
Y, (VMAPS, VMAPS'), (< X ; Z > VEPS), PDL, DB')
if ME' := prepModExp(ME, VEPS)
/\ < VMAPS' ; DB' ; VE ; VE' ; VEPS' ; B ; IL'' >
:= prepPar(X, ME', database(evalModExp(ME', PDL, DB))) .
eq prepParImports(nil, IL, X, VMAPS, VEPS, PDL, DB)
= < VMAPS ; DB ; mtViewExp ; mtViewExp ; none ; false ; IL > .
ceq prepPar(X, Y, ME, DB)
= < (VMAPS'', VMAPS3) ;
(if unitInDb(pd(Y :: ME), DB)
then DB
else evalModule(
setImports(
setName(
applyMapsToModule(
(VMAPS'', VMAPS3),
getTopModule(pd(X :: ME), DB),
getFlatModule(pd(X :: ME), DB)),
pd(Y :: ME)),
IL),
applyMapsToOps(
VMAPS'',
VMAPS3,
getVars(pd(X :: ME), DB),
getFlatModule(pd(X :: ME), DB)),
DB')
fi) ;
X ; Y ; < X ; Y > ; true ; nil >
if Th := getTopModule(ME, DB)
/\ < VMAPS ; DB' ; VE ; VE' ; VEPS ; B ; IL >
:= prepParImports(getImports(Th),
nil, X, Y, none, < X ; Y >, X :: ME, DB)
/\ < VMAPS'' ; VMAPS3 >
:= splitMaps(
(VMAPS,
genMapsQualSorts(X, Y, getSorts(Th), none),
genMapsQualClasses(X, Y, classSet(getClasses(Th)), none))) .
eq prepParImports(((including ME .) IL), IL', X, Y, VMAPS, VEPS, PDL, DB)
= prepParImports(IL, (IL' including ME .), X, Y, VMAPS, VEPS, PDL, DB) .
eq prepParImports(((extending ME .) IL), IL', X, Y, VMAPS, VEPS, PDL, DB)
= prepParImports(IL, (IL' extending ME .), X, Y, VMAPS, VEPS, PDL, DB) .
eq prepParImports(((protecting ME .) IL), IL', X, Y, VMAPS, VEPS, PDL, DB)
= prepParImports(IL, (IL' protecting ME .), X, Y, VMAPS, VEPS, PDL, DB) .
ceq prepParImports(including pd(X :: ME) . IL, IL',
Y, Z, VMAPS, VEPS, PDL, DB)
= prepParImports(IL, IL' including pd(X :: ME') .,
Y, Z, (VMAPS, VMAPS'), VEPS, PDL, DB')
if ME' := prepModExp(ME, VEPS)
/\ < VMAPS' ; DB' ; VE ; VE' ; VEPS' ; B ; IL'' >
:= prepPar(Y, Z, ME', database(evalModExp(ME', PDL, DB))) .
ceq prepParImports(extending pd(X :: ME) . IL, IL',
Y, Z, VMAPS, VEPS, PDL, DB)
= prepParImports(IL, IL' extending pd(X :: ME') .,
Y, Z, (VMAPS, VMAPS'), VEPS, PDL, DB')
if ME' := prepModExp(ME, VEPS)
/\ < VMAPS' ; DB' ; VE ; VE' ; VEPS' ; B ; IL'' >
:= prepPar(Y, Z, ME', database(evalModExp(ME', PDL, DB))) .
ceq prepParImports(protecting pd(X :: ME) . IL, IL',
Y, Z, VMAPS, VEPS, PDL, DB)
= prepParImports(IL, IL' protecting pd(X :: ME') .,
Y, Z, (VMAPS, VMAPS'), VEPS, PDL, DB')
if ME' := prepModExp(ME, VEPS)
/\ < VMAPS' ; DB' ; VE ; VE' ; VEPS' ; B ; IL'' >
:= prepPar(Y, Z, ME', database(evalModExp(ME', PDL, DB))) .
eq prepParImports(nil, IL, X, Y, VMAPS, VEPS, PDL, DB)
= < VMAPS ; DB ; mtViewExp ; mtViewExp ; none ; false ; IL > .
op sortMapsPar : Qid SortSet Set{Tuple{ViewExp,ViewExp}} -> RenamingSet .
op classMapsPar : Qid SortSet Set{Tuple{ViewExp,ViewExp}} -> RenamingSet .
op qualify : Qid Sort -> Sort .
op qualify : Qid Sort Set{Tuple{ViewExp,ViewExp}} -> Sort .
op qualify : Qid Sort ParameterList ParameterList
Set{Tuple{ViewExp,ViewExp}} -> Sort .
eq qualify(X, S) = qualify(X, getName(S), getPars(S), empty, none) .
eq qualify(X, S, VEPS) = qualify(X, getName(S), getPars(S), empty, VEPS) .
eq qualify(X, S, (P, PL), PL', < P ; P' > VEPS)
= qualify(X, S, PL, PL' P', < P ; P' > VEPS) .
eq qualify(X, S, (P, PL), PL', VEPS)
= qualify(X, S, PL, PL' P, VEPS)
[owise] .
eq qualify(X, S, empty, PL, VEPS)
= qid(string(X) + "$" + string(makeSort(S, PL))) .
eq sortMapsPar(X, (S ; SS), VEPS)
= ((sort S to qualify(X, S, VEPS)), sortMapsPar(X, SS, VEPS)) .
eq sortMapsPar(X, none, VEPS) = none .
eq classMapsPar(X, (S ; SS), VEPS)
= ((class S to qualify(X, S, VEPS)), classMapsPar(X, SS, VEPS)) .
eq classMapsPar(X, none, VEPS) = none .
*** When one of the labels of the interface of a module is being used in a
*** module expression to instantiate some formal parameter of a module, then,
*** in the evaluation of such module expression the qualification of all sorts
*** and class names coming from the theory part of the parameter theory have
*** to be changed according to such a label. In the evaluation of an
*** instantiation module expression this is done by generating the
*** corresponding renaming maps, which are then applied to the module being
*** instantiated. Given labels \texttt{L} and \texttt{L'}, for each sort or
*** class name \texttt{S} in the set given as argument, a map of the form
*** \verb~L$S to L'$S~ is generated.
op genMapsQualSorts :
Qid Qid SortSet Set{Tuple{ViewExp,ViewExp}} -> RenamingSet .
op genMapsQualClasses :
Qid Qid SortSet Set{Tuple{ViewExp,ViewExp}} -> RenamingSet .
eq genMapsQualSorts(X, Y, (S ; SS), VEPS)
= ((sort qualify(X, S, VEPS) to qualify(Y, S, VEPS)),
genMapsQualSorts(X, Y, SS, VEPS)) .
eq genMapsQualSorts(X, Y, none, VEPS) = none .
eq genMapsQualClasses(X, Y, (S ; SS), VEPS)
= ((class qualify(X, S, VEPS) to qualify(Y, S, VEPS)),
genMapsQualClasses(X, Y, SS, VEPS)) .
eq genMapsQualClasses(X, Y, none, VEPS) = none .
*** The function \texttt{prepare} takes the map set of a view and
*** prepares it to be used in an instantiation by transforming sort and class
*** names into their qualified form, if required (sorts and class names in a
*** view have to be qualified only if they were defined in a theory).
*** The \texttt{prepare} function takes five arguments: The set of maps
*** to be prepared, the label with which the sorts to be renamed have to be
*** qualified, the set of sorts in the theory part of the source of the view,
*** and the set of sorts and class names in the theory part of the target of
*** the view.
*** Note that we assume that there is a sort map and a class map for each sort
*** and class in the theory part of the source of the view. Therefore, sorts
*** and class names appearing as sources of sort and class maps are
*** systematically qualified. The sorts or class names used in the targTS of
*** the maps will be qualified only if they were declared in a theory. In maps
*** for operators in which the arity and coarity are specified, or for those
*** going to derived terms, the sorts appearing in the arity or coarity of an
*** operator and those used to qualify terms, or in sort tests in terms, must
*** also be qualified. However, in these cases the qualification cannot be
*** done on all sorts, but only on those defined in the theory parts. This is
*** the reason why the sTS of sorts in the theory parts of the source and
*** target and the set of class names in the target of the view are given when
*** calling \texttt{prepare}.
op prepare : Set{ViewMap} Qid SortSet SortSet SortSet -> RenamingSet .
op prepare : TypeList Qid SortSet -> TypeList .
op prepTerm : TermList Qid SortSet -> TermList .
eq prepare((sort S to S'), X, SS, SS', SS'')
= if S' in SS'
then (sort qualify(X, S) to qualify(X, S'))
else (sort qualify(X, S) to S')
fi .
eq prepare(((sort S to S'), VMAPS), X, SS, SS', SS'')
= ((if S' in SS'
then (sort qualify(X, S) to qualify(X, S'))
else (sort qualify(X, S) to S')
fi),
prepare(VMAPS, X, SS, SS', SS'')) .
eq prepare((op F : TyL -> Ty to F' [AtS]), X, SS, SS', SS'')
= (op F : prepare(TyL, X, SS) -> prepare(Ty, X, SS) to F' [AtS]) .
eq prepare(((op F : TyL -> Ty to F' [AtS]), VMAPS),
X, SS, SS', SS'')
= ((op F : prepare(TyL, X, SS) -> prepare(Ty, X, SS) to F'
[AtS]),
prepare(VMAPS, X, SS, SS', SS'')) .
eq prepare((op F to F' [AtS]), X, SS, SS', SS'') = (op F to F' [AtS]) .
eq prepare(((op F to F' [AtS]), VMAPS), X, SS, SS', SS'')
= ((op F to F' [AtS]), prepare(VMAPS, X, SS, SS', SS'')) .
eq prepare(termMap(T, T'), X, SS, SS', SS'')
= termMap(prepTerm(T, X, SS), prepTerm(T', X, SS')) .
eq prepare((termMap(T, T'), VMAPS), X, SS, SS', SS'')
= (termMap(prepTerm(T, X, SS), prepTerm(T', X, SS')),
prepare(VMAPS, X, SS, SS', SS'')) .
eq prepare((msg F : TyL -> Ty to F'), X, SS, SS', SS'')
= (msg F : prepare(TyL, X, SS) -> prepare(Ty, X, SS) to F') .
eq prepare(((msg F : TyL -> Ty to F'), VMAPS), X, SS, SS', SS'')
= ((msg F : prepare(TyL, X, SS) -> prepare(Ty, X, SS) to F'),
prepare(VMAPS, X, SS, SS', SS'')) .
eq prepare((msg F to F'), X, SS, SS', SS'') = (msg F to F') .
eq prepare(((msg F to F'), VMAPS), X, SS, SS', SS'')
= ((msg F to F'), prepare(VMAPS, X, SS, SS', SS'')) .
eq prepare((class S to S'), X, SS, SS', SS'')
= if S' in SS''
then (class qualify(X, S) to qualify(X, S'))
else (class qualify(X, S) to S')
fi .
eq prepare(((class S to S'), VMAPS), X, SS, SS', SS'')
= ((if S' in SS''
then (class qualify(X, S) to qualify(X, S'))
else (class qualify(X, S) to S')
fi),
prepare(VMAPS, X, SS, SS', SS'')) .
eq prepare((attr A . S to A'), X, SS, SS', SS'')
= (attr A . qualify(X, S) to A') .
eq prepare(((attr A . S to A'), VMAPS), X, SS, SS', SS'')
= ((attr A . qualify(X, S) to A'),
prepare(VMAPS, X, SS, SS', SS'')) .
eq prepare((label L to L'), X, SS, SS', SS'') = (label L to L') .
eq prepare(none, X, SS, SS', SS'') = none .
eq prepare((S TyL), X, (S ; SS))
= (qualify(X, S) prepare(TyL, X, (S ; SS))) .
eq prepare((K TyL), X, SS)
= prepare((getSort(K) TyL), X, SS) .
eq prepare((S TyL), X, SS)
= (S prepare(TyL, X, SS))
[owise] .
eq prepare(nil, X, SS) = nil .
eq prepTerm(F[TL], X, SS) = F[prepTerm(TL, X, SS)] .
eq prepTerm(V, X, SS)
= if getType(V) in SS
then qid(string(getName(V)) + ":" + string(qualify(X, getType(V))))
else qid(string(getName(V)) + ":" + string(getType(V)))
fi .
eq prepTerm(Ct, X, SS)
= if getType(Ct) in SS
then qid(string(getName(Ct)) + "." + string(qualify(X, getType(Ct))))
else qid(string(getName(Ct)) + "." + string(getType(Ct)))
fi .
ceq prepTerm((T, TL), X, SS)
= (prepTerm(T, X, SS), prepTerm(TL, X, SS))
if TL =/= empty .
eq prepTerm(qidError(QIL), X, SS) = qidError(QIL) .
*** For each parameterized sort
*** $\texttt{S[L}_1\texttt{,}\ldots\texttt{,L}_n\texttt{]}$ in the
*** body of a parameterized module with
*** $\texttt{L}_1\ldots\texttt{L}_n$ the labels of the parameters in
*** the interface of the module, a map of the form 9
*** $\texttt{sort\ S[L}_1\texttt{,}\ldots\texttt{,L}_n\texttt{]\
*** to\ S[V}_1\texttt{,}\ldots\texttt{,V}_n\texttt{]}$
*** is generated, where $\texttt{V}_i$ is the name of the view associated to
*** the label $\texttt{L}_i$ in the set of pairs given as argument.
op genMapsSorts : SortSet Set{Tuple{ViewExp,ViewExp}} -> RenamingSet .
op genMapsClasses : SortSet Set{Tuple{ViewExp,ViewExp}} -> RenamingSet .
op prepSort : Sort Set{Tuple{ViewExp,ViewExp}} -> Sort .
op prepSort :
Sort ParameterList ParameterList Set{Tuple{ViewExp,ViewExp}} -> Sort .
eq genMapsSorts((S ; SS), VEPS)
= (if prepSort(S, VEPS) == S
then none
else (sort S to prepSort(S, VEPS))
fi),
genMapsSorts(SS, VEPS) .
eq genMapsSorts(none, VEPS) = none .
eq genMapsClasses((S ; SS), VEPS)
= (if prepSort(S, VEPS) == S
then none
else (class S to prepSort(S, VEPS))
fi),
genMapsClasses(SS, VEPS) .
eq genMapsClasses(none, VEPS) = none .
eq prepSort(S, VEPS) = prepSort(getName(S), empty, getPars(S), VEPS) .
eq prepSort(Ty, VEPS) = Ty [owise] .
eq prepSort(S, PL, P, < P ; VE > VEPS)
= prepSort(S, (PL, VE), empty, < P ; VE > VEPS) .
eq prepSort(S, PL, (P, PL'), < P ; VE > VEPS)
= prepSort(S, (PL, VE), PL', < P ; VE > VEPS) .
eq prepSort(S, PL, P, VEPS)
= prepSort(S, (PL, prepSort(P, VEPS)), empty, VEPS)
[owise] .
eq prepSort(S, PL, (P, PL'), VEPS)
= prepSort(S, (PL, prepSort(P, VEPS)), PL', VEPS)
[owise] .
eq prepSort(S, PL, empty, VEPS)
= if getPars(S) == empty
then makeSort(S, PL)
else makeSort(prepSort(S, VEPS), PL)
fi .
*** The function \texttt{prepImports} takes a list of importation
*** declarations and a set of pairs composed of a label and a view name, and
*** returns the list of importations resulting from changing in each of the
*** module expressions the occurrences of the labels of the interface of the
*** module being instantiated by the names of the views associated to them in
*** the list of pairs.
op prepImports : ImportList Set{Tuple{ViewExp,ViewExp}} -> ImportList .
op prepModExp :
ModuleExpression Set{Tuple{ViewExp,ViewExp}} -> ModuleExpression .
op prepModExp : ModuleExpression ViewExp ViewExp ViewExp
Set{Tuple{ViewExp,ViewExp}} -> ModuleExpression .
op prepParameterDecl :
ParameterDecl Set{Tuple{ViewExp,ViewExp}} -> ParameterDecl .
op prepViewExp : ViewExp Set{Tuple{ViewExp,ViewExp}} -> ViewExp .
op prepViewExp : ParameterList Set{Tuple{ViewExp,ViewExp}} -> ParameterList .
eq prepImports(((including ME .) IL), VEPS)
= (including prepModExp(ME, VEPS) .)
prepImports(IL, VEPS) .
eq prepImports(((including pd(PD) .) IL), VEPS)
= (including pd(prepParameterDecl(PD, VEPS)) .)
prepImports(IL, VEPS) .
eq prepImports(((extending ME .) IL), VEPS)
= (extending prepModExp(ME, VEPS) .)
prepImports(IL, VEPS) .
eq prepImports(((extending pd(PD) .) IL), VEPS)
= (extending pd(prepParameterDecl(PD, VEPS)) .)
prepImports(IL, VEPS) .
eq prepImports(((protecting ME .) IL), VEPS)
= (protecting prepModExp(ME, VEPS) .)
prepImports(IL, VEPS) .
eq prepImports(((protecting pd(PD) .) IL), VEPS)
= (protecting pd(prepParameterDecl(PD, VEPS)) .)
prepImports(IL, VEPS) .
eq prepImports(nil, VEPS) = nil .
eq prepModExp(QI, VEPS) = QI .
eq prepModExp(ME{PL}, VEPS) = prepModExp(ME, empty, empty, PL, VEPS) .
eq prepModExp(ME + ME', VEPS)
= prepModExp(ME, VEPS) + prepModExp(ME', VEPS) .
eq prepModExp(ME, VEPS) = ME [owise] .
eq prepModExp(ME, PL, PL', (P, PL''), < P ; S > VEPS)
= prepModExp(ME, (PL, S), PL', PL'', < P ; S > VEPS) .
eq prepModExp(ME, PL, PL', (P, PL''), < P ; S{PL3} > VEPS)
= prepModExp(ME, (PL, S{PL3}), PL', PL'', < P ; S{PL3} > VEPS) .
ceq prepModExp(ME, PL, PL', (P, PL''), < P ; P' ;; VE > VEPS)
= prepModExp(ME, (PL, P'), (PL', VE), PL'', < P ; P' ;; VE > VEPS)
if VE =/= mtViewExp .
eq prepModExp(ME, PL, PL', (P, PL''), VEPS)
= prepModExp(ME, (PL, P), PL', PL'', VEPS)
[owise] .
eq prepModExp(ME, PL, PL', (QI{PL''}, PL3), VEPS)
= prepModExp(ME, (PL, prepViewExp(QI{PL''}, VEPS)), PL', PL3, VEPS) .
eq prepModExp(ME, PL, empty, empty, VEPS) = ME{PL} .
eq prepModExp(ME, PL, PL', empty, VEPS) = ME{PL}{PL'} [owise] .
eq prepParameterDecl(X :: ME, < Y ; Z > VEPS)
= if X == Y
then (Z :: ME)
else prepParameterDecl(X :: ME, VEPS)
fi .
eq prepParameterDecl(X :: ME, none) = X :: ME .
eq prepViewExp(VE, < VE ; VE' > VEPS) = VE' .
eq prepViewExp(QI, VEPS) = QI [owise] .
eq prepViewExp(X{PL}, VEPS) = X{prepViewExp(PL, VEPS)} [owise] .
ceq prepViewExp((VE, PL), VEPS)
= prepViewExp(VE, VEPS), prepViewExp(PL, VEPS)
if VE =/= nil /\ PL =/= nil [owise] .
*** The function \texttt{unitInst} calls the auxiliary function
*** \texttt{unitInstAux}, which proceeds recursively on each of the parameters
*** in the interface of the module being instantiated. For each view, a set of
*** maps to be applied to the module is generated, which are accumulated in
*** the third argument of the function.
*** In the base case, when there are no more parameters and no more views, the
*** maps for the parameterized sorts are also generated, and all maps are
*** then applied.
*** \texttt{unitInstAux} proceeds accumulating also the list of parameters
*** being modified, the list of importations, and a list of label-view
*** pairs (\texttt{QidTuple{ViewExp,ViewExp}}) associating each label in
*** the interface to the view used in the instantiation of the theory with
*** such label. This list of pairs is used to generate the set of maps of the
*** parameterized sorts and to `prepare' the list of importations as
*** indicated above.
sort TreatParResult .
op <_;_;_;_;_> : Set{ViewMap} ParameterDeclList ImportList
Set{Tuple{ViewExp,ViewExp}} Database -> TreatParResult .
op mapSet : TreatParResult -> Set{ViewMap} .
op getPars : TreatParResult -> ParameterDeclList .
op getImports : TreatParResult -> ImportList .
op viewExpPairSet : TreatParResult -> Set{Tuple{ViewExp,ViewExp}} .
op db : TreatParResult -> Database .
eq mapSet(< VMAPS ; PDL ; IL ; VEPS ; DB >) = VMAPS .
eq getPars(< VMAPS ; PDL ; IL ; VEPS ; DB >) = PDL .
eq getImports(< VMAPS ; PDL ; IL ; VEPS ; DB >) = IL .
eq viewExpPairSet(< VMAPS ; PDL ; IL ; VEPS ; DB >) = VEPS .
eq db(< VMAPS ; PDL ; IL ; VEPS ; DB >) = DB .
op unitInstAux : Module Module OpDeclSet RenamingSet ParameterDeclList
ParameterDeclList ImportList ImportList ParameterList
Set{Tuple{ViewExp,ViewExp}} ParameterDeclList Database
-> Database .
op treatPar : ParameterDecl ViewExp Set{Tuple{ViewExp,ViewExp}}
ParameterDeclList Database -> TreatParResult .
op treatPar2 : ParameterDecl ViewExp Set{Tuple{ViewExp,ViewExp}}
ParameterDeclList Database -> TreatParResult .
op treatParAux : Qid ModuleExpression ParameterDeclList ViewExp Qid ViewExp
ViewExp ParameterDeclList RenamingSet ParameterDeclList
ImportList Set{Tuple{ViewExp,ViewExp}} Database
-> TreatParResult .
op treatParAux2 : Qid ModuleExpression ParameterDeclList ViewExp Qid ViewExp
ViewExp ParameterDeclList RenamingSet ParameterDeclList ImportList
Set{Tuple{ViewExp,ViewExp}} Database -> TreatParResult .
eq unitInst(ME, PL, PDL, DB)
= unitInstAux(setName(getTopModule(ME, DB), ME{PL}),
signature(getFlatModule(ME, DB)), getVars(ME, DB), none,
getPars(getTopModule(ME, DB)), nil,
getImports(getTopModule(ME, DB)), nil, PL, none, PDL, DB) .
ceq unitInstAux(U, M, VDS, VMAPS,
(X :: ME, PDL), PDL', IL, IL'',
(QI, PL), VEPS, PDL'', DB)
= unitInstAux(U, M, VDS, (VMAPS, VMAPS'), PDL, (PDL', PDL3),
IL, (IL'' IL3), PL, (VEPS VEPS'), PDL'', DB')
if < VMAPS' ; PDL3 ; IL3 ; VEPS' ; DB' >
:= treatPar(X :: ME, QI, VEPS, PDL'', DB) .
ceq unitInstAux(U, M, VDS, VMAPS,
(X :: ME, PDL), PDL', IL, IL'',
(QI{PL}, PL'), VEPS, PDL'', DB)
= unitInstAux(U, M, VDS, (VMAPS, VMAPS'), PDL, (PDL', PDL3),
IL, (IL'' IL3), PL', (VEPS VEPS'), PDL'', DB')
if < VMAPS' ; PDL3 ; IL3 ; VEPS' ; DB' >
:= treatPar(X :: ME, QI{PL}, VEPS, PDL'', DB) .
ceq unitInstAux(U, M, VDS, VMAPS, nil, PDL, IL, IL', empty, VEPS, PDL', DB)
= evalModule(
setImports(
setPars(applyMapsToModule((VMAPS', VMAPS''), U, M), PDL),
(prepImports(IL, VEPS) IL')),
applyMapsToOps(VMAPS', VMAPS'', VDS, M),
DB)
if < VMAPS' ; VMAPS'' >
:= splitMaps(
(VMAPS,
genMapsSorts(
(getSorts(U) ; getSortSetAux(getImports(U), DB)), VEPS),
genMapsClasses(
(getClassNames(getClasses(U)) ;
getClassSetAux(getImports(U), DB)), VEPS))) .
eq unitInstAux(unitError(QIL), UK:[Module], SDV:[OpDeclSet], VMAPS, PDL,
PDL', IL, IL', PL, VEPS, PDL'', DB)
= warning(DB, QIL) .
eq unitInstAux(noModule,
unitError(QIL), VDS, VMAPS, PDL, PDL', IL, IL', VE, VEPS, PDL'', DB)
= warning(DB, QIL) .
eq unitInstAux(U, M, VDS, VMAPS, (X :: ME, PDL),
PDL', IL, IL', empty, VEPS, PDL'', DB)
= warning(DB,
'\r 'Error: '\o 'Incorrect 'module header2QidList(getName(U)) '. '\n) .
eq unitInstAux(U, M, VDS, VMAPS, nil, PDL, IL, IL', (QI, VE, PL), VEPS, PDL', DB)
= warning(DB,
'\r 'Error: '\o 'Incorrect 'module header2QidList(getName(U)) '. '\n) .
eq unitInstAux(U, M, VDS, VMAPS, PDL, PDL', IL, IL', PL, VEPS, PDL'', DB)
= DB
[owise] .
eq treatParView(X :: ME, VE, ME', VEPS, PDL, DB)
= if labelInModExp(X, ME')
then treatPar(X :: ME, VE, VEPS, PDL, DB)
else < none ;
getPars(treatPar(X :: ME, VE, VEPS, PDL, DB)) ;
getImports(treatPar(X :: ME, VE, VEPS, PDL, DB)) ;
viewExpPairSet(treatPar(X :: ME, VE, VEPS, PDL, DB)) ;
db(treatPar(X :: ME, VE, VEPS, PDL, DB)) >
fi .
op labelInModExp : Qid ModuleExpression -> Bool .
op labelInViewExp : Qid ViewExp -> Bool .
eq labelInModExp(X, QI) = X == QI .
eq labelInModExp(X, ME{VE}) = labelInViewExp(X, VE) .
eq labelInModExp(X, TUPLE[N]) = false .
eq labelInModExp(X, POWER[N]) = false .
eq labelInViewExp(X, QI) = X == QI .
eq labelInViewExp(X, ((VE, VE')))
= labelInViewExp(X, VE) or-else labelInViewExp(X, VE') .
eq labelInViewExp(X, QI{VE}) = X == QI or-else labelInViewExp(X, VE) .
eq treatPar(X :: ME, VE, VEPS, PDL, DB)
= if VE :: Qid and-then labelInParameterDeclList(VE, PDL)
then < (genMapsQualSorts(X, VE, getThSorts(ME, DB), VEPS),
genMapsQualClasses(X, VE, getThClasses(ME, DB), VEPS)) ;
VE :: ME ;
nil ;
< X ; VE > ;
createCopy((VE :: ME), DB) >
else if viewInDb(VE, DB)
then if theory(getTopModule(target(getView(VE, DB)), DB))
then < prepare(
mapSet(getView(VE, DB)), X,
getThSorts(ME, DB),
getThSorts(target(getView(VE, DB)), DB),
getThClasses(target(getView(VE, DB)), DB)) ;
X :: target(getView(VE, DB)) ;
nil ;
< X ; (VE ;; X) > ;
createCopy((X :: target(getView(VE, DB))), DB) >
else < prepare(
mapSet(getView(VE, DB)), X,
getThSorts(ME, DB), none, none) ;
getPars(getTopModule(target(getView(VE, DB)), DB)) ;
(protecting target(getView(VE, DB)) .) ;
< X ; VE > ;
DB >
fi
else < none ; nil ; nil ; none ;
warning(DB, '\r 'Error: '\o 'View VE 'not 'in 'database. '\n) >
fi
fi .
op viewInstAux : View Set{ViewMap} ParameterDeclList ParameterDeclList
ParameterList Set{Tuple{ViewExp,ViewExp}} ParameterDeclList Database
-> Database .
op treatParView : ParameterDecl ParameterList ModuleExpression
Set{Tuple{ViewExp,ViewExp}} ParameterDeclList Database
-> TreatParResult .
op treatParAux : Qid ModuleExpression ParameterList Qid ViewExp ViewExp
ParameterList RenamingSet ParameterList ImportList
Set{Tuple{ViewExp,ViewExp}} Database -> TreatParResult .
eq viewInst(VE, PL, PDL, DB)
= viewInstAux(setName(getView(VE, DB), VE{PL}),
none, getPars(getView(VE, DB)), nil, PL, none, PDL, DB) .
ceq viewInstAux(VI, VMAPS, (X :: ME, PDL), PDL', (QI, PL), VEPS, PDL'', DB)
= viewInstAux(VI, (VMAPS, VMAPS'), PDL, (PDL', PDL3),
PL, (VEPS VEPS'), PDL'', DB')
if < VMAPS' ; PDL3 ; IL ; VEPS' ; DB' >
:= treatParView(X :: ME, QI, source(VI), VEPS, PDL'', DB) .
ceq viewInstAux(VI, VMAPS, (X :: ME, PDL), PDL',
(QI{PL}, PL'), VEPS, PDL'', DB)
= viewInstAux(VI, (VMAPS, VMAPS'), PDL, (PDL', PDL3),
PL', (VEPS VEPS'), PDL'', DB')
if < VMAPS' ; PDL3 ; IL ; VEPS' ; DB' >
:= treatParView(X :: ME, QI{PL}, source(VI), VEPS, PDL'', DB) .
ceq viewInstAux(VI, VMAPS, nil, PDL, empty, VEPS, PDL', DB)
= insertView(
setPars(
sTSource(
setTarget(
setMaps(VI,
applyMapsToMaps(
(genMapsSorts(getSortSet(source(VI), DB''), VEPS),
genMapsClasses(getClassSet(source(VI), DB''), VEPS)),
(VMAPS,
genMapsSorts(getSortSet(target(VI), DB''), VEPS),
genMapsClasses(getClassSet(target(VI), DB''), VEPS)),
mapSet(VI))),
prepModExp(target(VI), VEPS)),
prepModExp(source(VI), VEPS)),
PDL),
DB'')
if < DB' ; ME' > := evalModExp(prepModExp(source(VI), VEPS), PDL', DB)
/\ < DB'' ; ME'' > := evalModExp(prepModExp(target(VI), VEPS), PDL', DB') .
eq viewInstAux(viewError(QIL), VMAPS, PDL0:[ParameterDeclList], PDL, PL, VEPS, PDL', DB)
= warning(DB, QIL) .
eq viewInstAux(VI, VMAPS, (X :: ME, PDL), PDL', empty, VEPS, PDL'', DB)
= warning(DB, ('\r 'Error: '\o 'Incorrect 'view name(VI) '. '\n)) .
eq viewInstAux(VI, VMAPS, nil, PDL, (QI, PL), VEPS, PDL', DB)
= warning(DB, ('\r 'Error: '\o 'Incorrect 'view name(VI) '. '\n)) .
eq viewInstAux(VI, VMAPS, (X :: ME, PDL), PDL', (QI{PL}, PL'), VEPS, PDL'', DB)
= warning(DB, ('\r 'Error: '\o 'Wrong 'instantiation name(VI) '. '\n)) .
op applyMapsToMaps : Set{ViewMap} Set{ViewMap} Set{ViewMap} -> Set{ViewMap} .
op applyMapsToTerm : Set{ViewMap} TermList -> TermList .
eq applyMapsToMaps(VMAPS, VMAPS', op F to F' [AtS]) = (op F to F' [AtS]) .
eq applyMapsToMaps(VMAPS, VMAPS', (op F to F' [AtS], VMAPS''))
= (op F to F' [AtS], applyMapsToMaps(VMAPS, VMAPS', VMAPS'')) .
eq applyMapsToMaps(VMAPS, VMAPS', op F : TyL -> Ty to F' [AtS])
= (op F : applyMapsToTypeList(VMAPS, TyL)
-> applyMapsToType(VMAPS, Ty) to F' [AtS]) .
eq applyMapsToMaps(VMAPS, VMAPS',
(op F : TyL -> Ty to F' [AtS], VMAPS''))
= (op F : applyMapsToTypeList(VMAPS, TyL)
-> applyMapsToType(VMAPS, Ty) to F' [AtS],
applyMapsToMaps(VMAPS, VMAPS', VMAPS'')) .
eq applyMapsToMaps(VMAPS, VMAPS', (sort S to S'))
= (sort applyMapsToType(VMAPS, S) to applyMapsToType(VMAPS', S')) .
eq applyMapsToMaps(VMAPS, VMAPS', ((sort S to S'), VMAPS''))
= ((sort applyMapsToType(VMAPS, S) to applyMapsToType(VMAPS', S')),
applyMapsToMaps(VMAPS, VMAPS', VMAPS'')) .
eq applyMapsToMaps(VMAPS, VMAPS', (label L to L')) = (label L to L') .
eq applyMapsToMaps(VMAPS, VMAPS', ((label L to L'), VMAPS''))
= ((label L to L'), applyMapsToMaps(VMAPS, VMAPS', VMAPS'')) .
eq applyMapsToMaps(VMAPS, VMAPS', (class S to S'))
= (class applyMapsToType(VMAPS, S) to applyMapsToType(VMAPS',S')) .
eq applyMapsToMaps(VMAPS, VMAPS', ((class S to S'), VMAPS''))
= ((class applyMapsToType(VMAPS, S) to applyMapsToType(VMAPS',S')),
applyMapsToMaps(VMAPS, VMAPS', VMAPS'')) .
eq applyMapsToMaps(VMAPS, VMAPS', (attr A . S to A'))
= (attr A . applyMapsToType(VMAPS, S) to A') .
eq applyMapsToMaps(VMAPS, VMAPS', ((attr A . S to A'), VMAPS''))
= ((attr A . applyMapsToType(VMAPS, S) to A'),
applyMapsToMaps(VMAPS, VMAPS', VMAPS'')) .
eq applyMapsToMaps(VMAPS, VMAPS', (msg F to F')) = (msg F to F') .
eq applyMapsToMaps(VMAPS, VMAPS', ((msg F to F'), VMAPS''))
= ((msg F to F'), applyMapsToMaps(VMAPS, VMAPS', VMAPS'')) .
eq applyMapsToMaps(VMAPS, VMAPS', (msg F : TyL -> S to F'))
= (msg F : applyMapsToTypeList(VMAPS, TyL)
-> applyMapsToType(VMAPS, S) to F') .
eq applyMapsToMaps(VMAPS, VMAPS',
((msg F : TyL -> S to F'), VMAPS''))
= ((msg F : applyMapsToTypeList(VMAPS, TyL)
-> applyMapsToType(VMAPS, S) to F'),
applyMapsToMaps(VMAPS, VMAPS', VMAPS'')) .
eq applyMapsToMaps(VMAPS, VMAPS', termMap(T, T'))
= termMap(applyMapsToTerm(VMAPS, T),
applyMapsToTerm(VMAPS', T')) .
eq applyMapsToMaps(VMAPS, VMAPS', (termMap(T, T'), VMAPS''))
= (termMap(applyMapsToTerm(VMAPS, T),
applyMapsToTerm(VMAPS', T')),
applyMapsToMaps(VMAPS, VMAPS', VMAPS'')) .
eq applyMapsToMaps(VMAPS, VMAPS', none) = none .
eq applyMapsToTerm(VMAPS, Ct)
= qid(string(getName(Ct))
+ "." + string(applyMapsToType(VMAPS, getType(Ct)))) .
eq applyMapsToTerm(VMAPS, V) = V .
eq applyMapsToTerm(VMAPS, qidError(QIL)) = qidError(QIL) .
ceq applyMapsToTerm(VMAPS, F[TL])
= F[applyMapsToTerm(VMAPS, TL)]
if (F =/= '<_:_|_>) and (F =/= '<_:_|`>) .
eq applyMapsToTerm(VMAPS, '<_:_|_>[O, Ct, T])
= '<_:_|_>[applyMapsToTerm(VMAPS, O),
qid(string(applyMapsToClassName(VMAPS, getName(Ct)))
+ "." + string(applyMapsToClassName(VMAPS, getType(Ct)))),
applyMapsToTerm(VMAPS, T)] .
ceq applyMapsToTerm(VMAPS, '<_:_|_>[O, C, T])
= '<_:_|_>[applyMapsToTerm(VMAPS, O),
applyMapsToClassName(VMAPS, C),
applyMapsToTerm(VMAPS, T)]
if not C :: Constant .
eq applyMapsToTerm(VMAPS, '<_:_|`>[O, Ct])
= '<_:_|_>[applyMapsToTerm(VMAPS, O),
qid(string(applyMapsToClassName(VMAPS, getName(Ct)))
+ "." + string(applyMapsToClassName(VMAPS, getType(Ct)))),
ceq applyMapsToTerm(VMAPS, '<_:_|`>[O, C])
= '<_:_|_>[applyMapsToTerm(VMAPS, O),
applyMapsToClassName(VMAPS, C),
if not C :: Constant .
ceq applyMapsToTerm(VMAPS, (T, TL))
= (applyMapsToTerm(VMAPS, T), applyMapsToTerm(VMAPS, TL))
if TL =/= empty .
*** As pointed out in Section~\ref{module-names}, for each new module
*** expression constructor being introduced, we need to add equations for the
*** operator \texttt{header2Qid}. Since the function to transform view
*** expressions into lists of quoted identifiers was already defined in
*** Section~\ref{VIEW-EXPR}, we just need to add the following equation.
eq header2Qid((ME { PL }))
= qidList2Qid(header2Qid(ME) '`{ parameterList2Qid(PL) '`}) .
ceq header2QidList((ME { PL }))
= (if QI == '\s then QIL else QIL QI fi
'`{ parameterList2QidList(PL) '`} '\s)
if QIL QI := header2QidList(ME) .
*** Given a module expression of the form \verb~ME{VE}~ such that
*** \texttt{ME} is in the database, we need to add \verb~ME{VE}~ to the set
*** of names of the modules depending on \texttt{ME} and on \texttt{VE}.
*** Since \texttt{VE} may be a composed view expression, we have to add the
*** name of the module to each of the views in it. In this way, if \texttt{ME}
*** or any of the views in \texttt{VE} is redefined or removed from the
*** database, \verb~ME{VE}~ will be removed as well.
eq setUpModExpDeps(ME{PL},
db(< ME ; DT ; U ; U' ; M ; VDS ; MNS ; VES > MIS, MNS',
VIS, VES', MNS'', MNS3, MNS4, QIL))
= viewExpDeps(ME{PL}, PL,
db(< ME ; DT ; U ; U' ; M ; VDS ; (MNS . ME{PL}) ; VES > MIS,
MNS', VIS, VES', MNS'', MNS3, MNS4, QIL)) .
eq setUpModExpDeps(ME{PL},
db(< ME ; DM ; U ; U' ; M ; VDS ; MNS ; VES > MIS, MNS',
VIS, VES', MNS'', MNS3, MNS4, QIL))
= viewExpDeps(ME{PL}, PL,
db(< ME ; DM ; U ; U' ; M ; VDS ; (MNS . ME{PL}) ; VES > MIS,
MNS', VIS, VES', MNS'', MNS3, MNS4, QIL)) .
eq setUpModExpDeps('META-LEVEL{PL}, DB)
= setUpModExpDeps('META-LEVEL{PL}, PL, DB) .
eq setUpModExpDeps('META-LEVEL{QI},
db(< QI ; DT ; U ; U' ; M ; VDS ; MNS ; VES > MIS, MNS',
VIS, VES', MNS'', MNS3, MNS4, QIL))
= db(< QI ; DT ; U ; U' ; M ; VDS ; MNS . 'META-LEVEL{QI} ; VES >
MIS, MNS', VIS, VES', MNS'', MNS3, MNS4, QIL) .
eq setUpModExpDeps('META-LEVEL{QI},
db(< QI ; DM ; U ; U' ; M ; VDS ; MNS ; VES > MIS, MNS',
VIS, VES', MNS'', MNS3, MNS4, QIL))
= db(< QI ; DM ; U ; U' ; M ; VDS ; MNS . 'META-LEVEL{QI} ; VES >
MIS, MNS', VIS, VES', MNS'', MNS3, MNS4, QIL) .
ceq setUpModExpDeps(ME{PL}, DB)
= warning(DB, ('\r 'Error: '\o 'Module header2QidList(ME) 'not 'in 'database. '\n))
if (ME =/= 'META-LEVEL) /\ (not unitInDb(ME, DB)) .
eq setUpModExpDeps('META-LEVEL{PL}, (QI, PL'),
db(< QI ; DT ; U ; U' ; M ; VDS ; MNS ; VES > MIS, MNS',
VIS, VES', MNS'', MNS3, MNS4, QIL))
= setUpModExpDeps('META-LEVEL{PL}, PL',
db(< QI ; DT ; U ; U' ; M ; VDS ; MNS . 'META-LEVEL{PL} ; VES >
MIS, MNS', VIS, VES', MNS'', MNS3, MNS4, QIL)) .
eq setUpModExpDeps('META-LEVEL{PL}, (QI, PL'),
db(< QI ; DM ; U ; U' ; M ; VDS ; MNS ; VES > MIS, MNS',
VIS, VES', MNS'', MNS3, MNS4, QIL))
= setUpModExpDeps('META-LEVEL{PL}, PL',
db(< QI ; DM ; U ; U' ; M ; VDS ; MNS . 'META-LEVEL{PL} ; VES >
MIS, MNS', VIS, VES', MNS'', MNS3, MNS4, QIL)) .
eq setUpModExpDeps('META-LEVEL{PL}, nil, DB) = DB .
op viewExpDeps : Header ViewExp Database -> Database .
---- eq viewExpDeps(ME, VE,
---- db(MIS, MNS,
---- < VE ; DT ; VI ; MNS' ; VES > VIS, VES',
---- MNS'', MNS3, MNS4, QIL))
---- = db(MIS, MNS, < VE ; DT ; VI ; MNS' . ME ; VES > VIS, VES',
---- MNS'', MNS3, MNS4, QIL) .
eq viewExpDeps(ME, (VE, PL),
db(MIS, MNS,
< VE ; DT ; VI ; MNS' ; VES > VIS, VES',
MNS'', MNS3, MNS4, QIL))
= viewExpDeps(ME, PL,
db(MIS, MNS,
< VE ; DT ; VI ; MNS' . ME ; VES > VIS, VES',
MNS'', MNS3, MNS4, QIL)) .
---- eq viewExpDeps(ME, VE, DB) = DB [owise] .
eq viewExpDeps(ME, (VE, PL), DB) = viewExpDeps(ME, PL, DB) [owise] .
eq viewExpDeps(ME, empty, DB) = DB .
endfm
*******************************************************************************
***
*** 6.10 Renaming of Modules
***
*** In addition to the declaration of the constructor for renaming module
*** expressions, the following module \texttt{RENAMING-EXPR-EVALUATION}
*** introduces equations to treat this new case in the definition of functions
*** \texttt{evalModExp}, \texttt{header2QidList}, \texttt{prepHeader}, and
*** \texttt{setUpModuleDeps}.
*** A renaming expression is evaluated by applying the renaming maps, not only
*** to the top unit, but also to the part of the structure \emph{affected} by
*** the maps. The renaming process propagates downwards in the unit hierarchy
*** while the units in the structure are affected by the renamings. We say that
*** a unit is affected by a set of maps (checked by the \texttt{modAffd}
*** function) when any of the maps is applicable to any of the declarations in
*** the unit, or in any of its subunits. The application of a set of maps to a
*** single unit is accomplished by the \texttt{applyMapsToModule} function,
*** discussed in Section~\ref{applyMapsToModule}.
fmod RENAMING-EXPR-EVALUATION is
pr DATABASE .
pr VIEW-MAP-SET-APPL-ON-UNIT .
pr EVALUATION .
inc MOD-EXPR .
pr MOD-EXPR-EVAL .
pr INST-EXPR-EVALUATION .
pr FMAP .
vars ME ME' : ModuleExpression .
var MNS MNS' MNS'' MNS3 MNS4 : Set{ModuleName} .
vars MIS MIS' : Set{ModuleInfo} .
var VIS : Set{ViewInfo} .
vars M M' : Module .
vars PU U U' DM : Module .
vars DB DB' : Database .
var QIL : QidList .
vars VES VES' : Set{ViewExp} .
var PL : ParameterList .
var PDL : ParameterDeclList .
vars PDS PDS' : Set{ParameterDecl} .
var I : Import .
vars IL IL' : ImportList .
var VMAP : ViewMap .
vars VMAPS VMAPS' VMAPS'' VMAPS3 : RenamingSet .
var VEPS : Set{Tuple{ViewExp,ViewExp}} .
vars X QI QI' QI'' F F' F'' L L' L'' A A' A'' : Qid .
vars S S' S'' C C' C'' : Sort .
var K : Kind .
vars SS : SortSet .
vars TyL TyL' : TypeList .
vars Ty Ty' : Type .
vars T T' T'' T3 : Term .
var DT : Default{Term} .
var TL : TermList .
var OPD : OpDeclSet .
vars OPDS VDS : OpDeclSet .
vars AtS AtS' : AttrSet .
var Rl : Rule .
var RlS : RuleSet .
var CD : ClassDecl .
var CDS : ClassDeclSet .
var ADS : AttrDeclSet .
var MD : MsgDecl .
var MDS : MsgDeclSet .
var MAP : Renaming .
vars MAPS MAPS' MAPS'' : RenamingSet .
var N : Nat .
var NL : IntList .
var Hk : Hook .
var HkL : HookList .
var B : Bool .
var St : String .
*** The function \texttt{crtCopyRen} creates a copy of the part of the
*** structure of the specified module which is affected by the renaming,
*** applying to each of the generated modules in the new structure the subset
*** of maps affecting each one of them. The equation extending the
*** \texttt{evalModExp} function to the renaming module expression is then
*** reduced to a call to \texttt{crtCopyRen} with the appropriate
*** arguments.
eq labelInModExp(X, ME * (MAPS)) = labelInModExp(X, ME) .
op crtCopyRen : ModuleExpression RenamingSet Database -> Database .
ceq evalModExp(ME * (MAPS), PDL, DB)
= if unitInDb(ME' * (MAPS''), DB')
then < DB' ; ME' * (MAPS'') >
else < crtCopyRen(ME', MAPS', DB') ; ME' * (MAPS'') >
fi
if < DB' ; ME' > := evalModExp(ME, PDL, DB)
/\ MAPS' := fixMaps(MAPS, ME', DB')
/\ MAPS'' := canMaps(MAPS', getFlatModule(ME', DB')) .
eq crtCopyRen(ME, none, DB) = DB .
ceq crtCopyRen(ME, VMAPS, DB)
= if unitInDb(_*`(_`)(ME, VMAPS'), DB)
then DB
else applyMapsRec(
VMAPS,
getImports(getTopModule(ME, DB)),
nil,
setName(
applyMapsToModuleAux(VMAPS'', VMAPS3,
getTopModule(ME, DB), getFlatModule(ME, DB)),
_*`(_`)(ME, VMAPS')),
applyMapsToOps(VMAPS'', VMAPS3,
getVars(ME, DB), getFlatModule(ME, DB)),
DB)
fi
if VMAPS' := canMaps(VMAPS, getFlatModule(ME, DB))
/\ < VMAPS'' ; VMAPS3 > := splitMaps(VMAPS') .
op canMaps : RenamingSet Module -> RenamingSet .
eq canMaps(op F : TyL -> Ty to F' [AtS], M)
= op F : canKinds(TyL, M) -> canKinds(Ty, M) to F' [AtS] .
eq canMaps((op F : TyL -> Ty to F' [AtS], MAPS), M)
= (op F : canKinds(TyL, M) -> canKinds(Ty, M) to F' [AtS],
canMaps(MAPS, M)) .
eq canMaps(msg F : TyL -> Ty to F', M)
= msg F : canKinds(TyL, M) -> canKinds(Ty, M) to F' .
eq canMaps((msg F : TyL -> Ty to F', MAPS), M)
= (msg F : canKinds(TyL, M) -> canKinds(Ty, M) to F',
canMaps(MAPS, M)) .
eq canMaps(MAP:Renaming, M) = MAP:Renaming [owise] .
eq canMaps((MAP:Renaming, MAPS), M)
= (MAP:Renaming, canMaps(MAPS, M))
[owise] .
eq canMaps(none, M) = none .
op canKinds : TypeList Module -> [TypeList] .
---- eq canKinds(K:Kind TyL, M)
---- = kind(maximalSorts(M, K:Kind)) canKinds(TyL, M) .
eq canKinds(nil, M) = nil .
eq canKinds(cc(S ; SS) TyL, M)
= kind(maximalSorts(M, getKind(M, S))) canKinds(TyL, M) .
----eq canKinds(TyL, M) = nil [owise] .
*** We proceed downwards while the set of maps affects the module, but we do so
*** restricting the set of maps to the subset affecting the module. Since
*** operator and message maps in which arity and coarity are specified must be
*** applied to the whole subsort-overloaded family of operators or messages, we
*** have to carry along the signature of the module at the top to make all the
*** calls to the engine. Note that we may have maps of operations or messages
*** with the domain given by sorts that are not in the submodules but which
*** have other sorts in the submodules in the same connected components.
op applyMapsRec : Set{ViewMap} ImportList
ImportList Module OpDeclSet Database -> Database .
eq applyMapsRec(VMAPS, ((including ME .) IL), IL', U, VDS, DB)
= applyMapsRec(
VMAPS, IL,
including ME *( canMaps(fixMaps(VMAPS, ME, DB),
getFlatModule(ME, DB)) ) . IL',
U, VDS,
crtCopyRen(ME, fixMaps(VMAPS, ME, DB), DB)) .
eq applyMapsRec(VMAPS, ((extending ME .) IL), IL', U, VDS, DB)
= applyMapsRec(
VMAPS, IL,
extending ME *( canMaps(fixMaps(VMAPS, ME, DB),
getFlatModule(ME, DB)) ) . IL',
U, VDS,
crtCopyRen(ME, fixMaps(VMAPS, ME, DB), DB)) .
eq applyMapsRec(VMAPS, ((protecting ME .) IL), IL', U, VDS, DB)
= applyMapsRec(
VMAPS, IL,
protecting ME *( canMaps(fixMaps(VMAPS, ME, DB),
getFlatModule(ME, DB)) ) . IL',
U, VDS,
crtCopyRen(ME, fixMaps(VMAPS, ME, DB), DB)) .
eq applyMapsRec(VMAPS, (I IL), IL', U, VDS, DB)
= applyMapsRec(VMAPS, IL, (I IL'), U, VDS, DB)
[owise] .
eq applyMapsRec(VMAPS, nil, IL, U, VDS, DB)
= evalModule(setImports(U, IL), VDS, DB) .
eq applyMapsRec(VMAPS, IL, IL', unitError(QIL), VDS, DB)
= warning(DB, QIL) .
op fixMaps : [RenamingSet] ModuleExpression Database -> RenamingSet .
op fixMaps2 : [RenamingSet] Module ClassDeclSet MsgDeclSet -> RenamingSet .
ceq fixMaps(MAPS, ME, DB)
= fixMaps2(MAPS, getFlatModule(ME, DB), CDS, MDS)
if < CDS ; MDS > := getAllClassesAndMsgs(ME, DB) .
eq fixMaps2(op F to F' [AtS], M, CDS, MDS)
= opsAffd(getOps(M), op F to F' [AtS], M) .
eq fixMaps2((op F to F' [AtS], MAPS), M, CDS, MDS)
= (opsAffd(getOps(M), op F to F' [AtS], M),
fixMaps2(MAPS, M, CDS, MDS)) .
eq fixMaps2(op F : TyL -> Ty to F' [AtS], M, CDS, MDS)
= opsAffd(getOps(M), op F : TyL -> Ty to F' [AtS], M) .
eq fixMaps2((op F : TyL -> Ty to F' [AtS], MAPS), M, CDS, MDS)
= (opsAffd(getOps(M), op F : TyL -> Ty to F' [AtS], M),
fixMaps2(MAPS, M, CDS, MDS)) .
eq fixMaps2(msg F to F', M, CDS, MDS)
= msgsAffd(MDS, msg F to F', M) .
eq fixMaps2((msg F to F', MAPS), M, CDS, MDS)
= (msgsAffd(MDS, msg F to F', M), fixMaps2(MAPS, M, CDS, MDS)) .
eq fixMaps2(msg F : TyL -> Ty to F', M, CDS, MDS)
= msgsAffd(MDS, msg F : TyL -> Ty to F', M) .
eq fixMaps2((msg F : TyL -> Ty to F', MAPS), M, CDS, MDS)
= (msgsAffd(MDS, msg F : TyL -> Ty to F', M),
fixMaps2(MAPS, M, CDS, MDS)) .
eq fixMaps2(sort Ty to Ty', M, CDS, MDS)
= if sortsAffd(getSorts(M), sort Ty to Ty')
then (sort Ty to Ty')
else none
fi .
eq fixMaps2(((sort Ty to Ty'), MAPS), M, CDS, MDS)
= (if sortsAffd(getSorts(M), sort Ty to Ty')
then (sort Ty to Ty')
else none
fi,
fixMaps2(MAPS, M, CDS, MDS)) .
eq fixMaps2(class Ty to Ty', M, CDS, MDS)
= if classesAffd(CDS, class Ty to Ty')
then (class Ty to Ty')
else none
fi .
eq fixMaps2(((class Ty to Ty'), MAPS), M, CDS, MDS)
= (if classesAffd(CDS, class Ty to Ty')
then (class Ty to Ty')
else none
fi,
fixMaps2(MAPS, M, CDS, MDS)) .
eq fixMaps2(attr A . Ty to Ty', M, CDS, MDS)
= if classesAffd(CDS, attr A . Ty to Ty')
then (attr A . Ty to Ty')
else none
fi .
eq fixMaps2(((class A . Ty to Ty'), MAPS), M, CDS, MDS)
= (if classesAffd(CDS, attr A . Ty to Ty')
then (attr A . Ty to Ty')
else none
fi,
fixMaps2(MAPS, M, CDS, MDS)) .
eq fixMaps2(MAP:Renaming, M, CDS, MDS) = MAP:Renaming [owise] .
eq fixMaps2((MAP:Renaming, MAPS), M, CDS, MDS)
= (MAP:Renaming, fixMaps2(MAPS, M, CDS, MDS))
[owise] .
eq fixMaps2(none, M, CDS, MDS) = none .
sort Tuple{ClassDeclSet, MsgDeclSet} .
op <_;_> : ClassDeclSet MsgDeclSet -> Tuple{ClassDeclSet, MsgDeclSet} .
op getClasses : Tuple{ClassDeclSet, MsgDeclSet} -> ClassDeclSet .
op getMsgs : Tuple{ClassDeclSet, MsgDeclSet} -> MsgDeclSet .
eq getClasses(< CDS ; MDS >) = CDS .
eq getMsgs(< CDS ; MDS >) = MDS .
op getAllClassesAndMsgs :
ModuleExpression Database -> Tuple{ClassDeclSet, MsgDeclSet} .
op getAllClassesAndMsgs :
ImportList Database -> Tuple{ClassDeclSet, MsgDeclSet} .
eq getAllClassesAndMsgs(ME, DB)
= if getTopModule(ME, DB) :: OModule
and-then not getTopModule(ME, DB) :: SModule
then < getClasses(
getAllClassesAndMsgs(getImports(getTopModule(ME, DB)), DB))
getClasses(getTopModule(ME, DB))
;
getMsgs(
getAllClassesAndMsgs(getImports(getTopModule(ME, DB)), DB))
getMsgs(getTopModule(ME, DB)) >
else < none ; none >
fi .
eq getAllClassesAndMsgs(I IL, DB)
= < getClasses(getAllClassesAndMsgs(moduleName(I), DB))
getClasses(getAllClassesAndMsgs(IL, DB))
;
getMsgs(getAllClassesAndMsgs(moduleName(I), DB))
getMsgs(getAllClassesAndMsgs(IL, DB)) > .
eq getAllClassesAndMsgs((nil).ImportList, DB) = < none ; none > .
---- sorts NeSet<TypeList> Set<TypeList> .
---- subsort TypeList < NeSet<TypeList> < Set<TypeList> .
---- op noneTLS : -> Set<TypeList> [ctor] .
---- op _!_ : Set<TypeList> Set<TypeList> -> Set<TypeList>
---- [ctor assoc comm id: noneTLS] .
---- op _!_ : NeSet<TypeList> NeSet<TypeList> -> NeSet<TypeList>
---- [ctor assoc comm id: noneTLS] .
---- sort Set<Type> .
---- subsorts Type SortSet < Set<Type> .
---- op _o_ : Set<Type> Set<Type> -> Set<Type> [ctor assoc comm id: none] .
----
---- eq Ty o Ty = Ty .
sort TypeSetList .
subsort TypeSet < TypeSetList .
op nilTSL : -> TypeSetList [ctor] .
op _l_ : TypeSetList TypeSetList -> TypeSetList
[ctor assoc id: nilTSL] .
var TS : TypeSet .
var TSL : TypeSetList .
var TLS : TypeListSet .
---- var NTLS : NeTypeListSet .
---- eq TyL ! TyL = TyL .
----eq _!_(qidError(QIL), NTLS) = qidError(QIL) .
op fixKinds : TypeList Module -> TypeListSet .
op fixKinds : TypeList TypeSetList Module -> TypeListSet .
op fixKindsAux : Type Module -> TypeSet .
op fixKindsAux2 : SortSet Module -> TypeSet .
op unfold : TypeSetList -> TypeListSet .
op add : TypeSet TypeListSet -> TypeListSet .
eq fixKinds(TyL, M) = fixKinds(TyL, nilTSL, M) .
eq fixKinds(Ty TyL, TSL, M)
= if fixKindsAux(Ty, M) == nil
then none
else fixKinds(TyL, TSL l fixKindsAux(Ty, M), M)
fi .
eq fixKinds(nil, TSL, M) = unfold(TSL) .
eq fixKindsAux(S, M)
= if S in getSorts(M)
then cc(connectedSorts(M, S))
else none
fi .
eq fixKindsAux(K, M) = fixKindsAux2(getSorts(K), M) .
eq fixKindsAux(cc(SS), M) = fixKindsAux2(SS, M) .
eq fixKindsAux2((S ; SS), M)
= (if S in getSorts(M)
then cc(connectedSorts(M, S))
else none
fi
;
fixKindsAux2(SS, M)) .
eq fixKindsAux2(none, M) = none .
ceq unfold(TS l TSL) = add(TS, unfold(TSL)) if TS =/= none .
eq unfold(nilTSL) = none .
ceq add(Ty, TyL ; TLS) = add(Ty, TyL) ; add(Ty, TLS) if TLS =/= none .
eq add(Ty ; Ty' ; TS, TLS) = add(Ty, TLS) ; add(Ty' ; TS, TLS) .
eq add(none, TLS) = nilTSL .
eq add(Ty, none) = Ty .
eq add(Ty, TyL) = Ty TyL .
op connectedSorts : Module Type -> SortSet .
op connectedSorts : Module SortSet Type -> SortSet .
eq connectedSorts(M, Ty) = connectedSorts(M, getSorts(M), Ty) .
eq connectedSorts(M, S ; SS, Ty)
= if sameKind(M, S, Ty)
then S
else none
fi ; connectedSorts(M, SS, Ty) .
eq connectedSorts(M, none, Ty) = none .
op sortsAffd : SortSet ViewMap -> Bool .
op opsAffd : OpDeclSet ViewMap Module -> RenamingSet .
op opsAffdAux : OpDeclSet Qid TypeListSet Qid AttrSet Module
-> RenamingSet .
eq sortsAffd((S ; SS), (sort S to S')) = true .
eq sortsAffd(SS, (sort S to S')) = false [owise] .
eq opsAffd(op F : TyL -> Ty [AtS] . OPDS, op F to F' [AtS'], M)
= op F to F' [AtS'] .
eq opsAffd(OPDS, op F : TyL -> Ty to F' [AtS], M)
= opsAffdAux(OPDS, F, fixKinds(TyL Ty, M), F', AtS, M) .
eq opsAffd(OPDS, VMAPS:[RenamingSet], M) = none [owise] .
eq opsAffdAux(op F : TyL -> Ty [AtS] . OPDS,
F, (TyL' Ty') ; TLS, F', AtS', M)
= if sameKind(M, (TyL Ty), (TyL' Ty'))
then (op F : TyL' -> Ty' to F' [AtS'],
opsAffdAux(OPDS, F, TLS, F', AtS', M))
else (opsAffdAux(OPDS, F, (TyL' Ty') ; TLS, F', AtS', M),
opsAffdAux(op F : TyL -> Ty [AtS] . OPDS, F, TLS, F', AtS', M))
fi .
eq opsAffdAux(OPDS, F, TLS, F', AtS, M) = none [owise] .
*** The predicate \texttt{modAffd} checks whether the module with the
*** name given as first argument in the database is affected by the set of maps
*** given as second argument. A module is affected by a map set if any of the
*** maps is applicable to the module or to any of its submodules.
op modAffd : Header RenamingSet Module Database -> Bool .
op modAffdAux : Module RenamingSet Module Database -> Bool .
op rlsAffd : RuleSet RenamingSet -> Bool .
op importsAffd : ImportList RenamingSet Module Database -> Bool .
op classesAffd : ClassDeclSet RenamingSet -> Bool .
op msgsAffd : MsgDeclSet RenamingSet Module -> RenamingSet .
op msgsAffdAux : MsgDeclSet Qid TypeListSet Qid Module -> RenamingSet .
eq modAffd(ME, VMAPS, M, DB)
= modAffdAux(getTopModule(ME, DB), VMAPS, M, DB) .
eq modAffdAux(U, VMAPS, M, DB)
= sortsAffd(getSorts(U), VMAPS)
or-else
(opsAffd(getOps(U), VMAPS, M) == none
or-else
((not U :: FModule
and-then
(rlsAffd(getRls(U), VMAPS)
or-else
(not U :: SModule
and-then
(classesAffd(getClasses(U), VMAPS)
or-else
msgsAffd(getMsgs(U), VMAPS, M) == none))))
or-else
importsAffd(getImports(U), VMAPS, M, DB))) .
eq importsAffd(((including ME .) IL), VMAPS, M, DB)
= modAffd(ME, VMAPS, M, DB)
or-else importsAffd(IL, VMAPS, M, DB) .
eq importsAffd(((extending ME .) IL), VMAPS, M, DB)
= modAffd(ME, VMAPS, M, DB)
or-else importsAffd(IL, VMAPS, M, DB) .
eq importsAffd(((protecting ME .) IL), VMAPS, M, DB)
= modAffd(ME, VMAPS, M, DB)
or-else importsAffd(IL, VMAPS, M, DB) .
eq importsAffd(nil, VMAPS, M, DB) = false .
eq rlsAffd(((rl T => T' [label(L) AtS] .) RlS), (label L' to L''))
= (L == L') or-else rlsAffd(RlS, label L' to L'') .
eq rlsAffd(((rl T => T' [label(L) AtS] .) RlS),
((label L' to L''), VMAPS))
= (L == L') or-else
(rlsAffd((rl T => T' [label(L) AtS] .), VMAPS) or-else
rlsAffd(RlS, ((label L' to L''), VMAPS))) .
eq rlsAffd(((crl T => T' if T'' = T3 [label(L) AtS] .) RlS),
(label L' to L''))
= (L == L') or-else rlsAffd(RlS, (label L' to L'')) .
eq rlsAffd(((crl T => T' if T'' = T3 [label(L) AtS] .) RlS),
((label L' to L''), VMAPS))
= (L == L')
or-else
(rlsAffd((crl T => T' if T'' = T3 [label(L) AtS] .), VMAPS)
or-else
rlsAffd(RlS, ((label L' to L''), VMAPS))) .
eq rlsAffd(RlS, VMAPS) = false [owise] .
eq classesAffd(((class C | ADS .) CDS), (class C' to C''))
= (C == C')
or-else
classesAffd(CDS, (class C' to C'')) .
eq classesAffd(((class C | ADS .) CDS), ((class C' to C''), VMAPS))
= (C == C')
or-else
(classesAffd((class C | ADS .), VMAPS)
or-else
classesAffd(CDS, ((class C' to C''), VMAPS))) .
eq classesAffd(((class C | ((attr A : S), ADS) .) CDS),
(attr A' . C' to A''))
= if C == C'
then (A == A')
or-else
classesAffd(((class C | ADS .) CDS), (attr A' . C' to A''))
else classesAffd(CDS, (attr A' . C' to A''))
fi .
eq classesAffd(((class C | ((attr A : S), ADS) .) CDS),
((attr A' . C' to A''), VMAPS))
= if C == C'
then (A == A')
or-else
(classesAffd(((class C | ADS .) CDS),
((attr A' . C' to A''), VMAPS))
or-else
classesAffd(CDS, VMAPS))
else classesAffd((class C | ((attr A : S), ADS) .), VMAPS)
or-else
classesAffd(CDS, ((attr A' . C' to A''), VMAPS))
fi .
eq classesAffd(CDS, VMAPS) = false [owise] .
eq msgsAffd(msg F : TyL -> Ty . MDS, msg F to F', M) = msg F to F' .
eq msgsAffd(MDS, msg F : TyL -> Ty to F', M)
= msgsAffdAux(MDS, F, fixKinds(TyL Ty, M), F', M) .
eq msgsAffd(MDS, VMAPS:[RenamingSet], M) = none [owise] .
eq msgsAffdAux(msg F : TyL -> Ty . MDS, F, (TyL' Ty') ; TLS, F', M)
= if sameKind(M, (TyL Ty), (TyL' Ty'))
then (msg F : TyL' -> Ty' to F',
msgsAffdAux(MDS, F, TLS, F', M))
else (msgsAffdAux(MDS, F, (TyL' Ty') ; TLS, F', M),
msgsAffdAux(msg F : TyL -> Ty . MDS, F, TLS, F', M))
fi .
eq msgsAffdAux(MDS, F, TLS, F', M) = none [owise] .
*** The function \texttt{mapsRestrict} returns the subset of the view
*** maps given as second argument that affect the given module.
op mapsRestrict : Module RenamingSet Module Database -> RenamingSet .
op mapsRestrict : Header RenamingSet Module Database -> RenamingSet .
eq mapsRestrict(ME, VMAPS, M, DB)
= mapsRestrict(getTopModule(ME, DB), VMAPS, M, DB) .
eq mapsRestrict(U, VMAP, M, DB)
= if modAffdAux(U, VMAP, M, DB)
then VMAP
else none
fi .
eq mapsRestrict(U, (VMAP, VMAPS), M, DB)
= if modAffdAux(U, VMAP, M, DB)
then (VMAP, mapsRestrict(U, VMAPS, M, DB))
else mapsRestrict(U, VMAPS, M, DB)
fi .
eq mapsRestrict(U, none, M, DB) = none .
*** The definition of the function \texttt{header2QidList} on the renaming
*** module expression has to take care of transforming into a quoted identifier
*** list the set of view maps given in the module expression.
op maps2QidList : RenamingSet -> QidList .
op attrSet2QidList : AttrSet -> QidList .
op hookList2QidList : HookList -> QidList .
op termList2QidList : TermList -> QidList .
op intList2QidList : IntList -> QidList .
op typeList2QidList : TypeList -> QidList .
eq maps2QidList(((op F to F' [AtS]), MAPS))
= if AtS == none
then ('op F 'to F' '`, '\s maps2QidList(MAPS))
else ('op F 'to F' '\s '`[ attrSet2QidList(AtS) '`] '`, '\s
maps2QidList(MAPS))
fi
[owise] .
eq maps2QidList((op F to F' [AtS]))
= if AtS == none
then ('op F 'to F')
else ('op F 'to F' '\s '`[ attrSet2QidList(AtS) '`])
fi .
eq maps2QidList(((op F : TyL -> Ty to F' [AtS]), MAPS))
= if AtS == none
then ('op F ': typeList2QidList(TyL) '-> Ty 'to F' '`,
'\s maps2QidList(MAPS))
else ('op F ': typeList2QidList(TyL) '-> Ty 'to F'
'`[ attrSet2QidList(AtS) '`] '`, '\s maps2QidList(MAPS))
fi
[owise] .
eq maps2QidList((op F : TyL -> Ty to F' [AtS]))
= if AtS == none
then ('op F ': typeList2QidList(TyL) '-> Ty 'to F')
else ('op F ': typeList2QidList(TyL) '-> Ty 'to F'
'`[ attrSet2QidList(AtS) '`])
fi .
eq maps2QidList(((sort S to S'), MAPS))
= ('sort S 'to S' '`, '\s maps2QidList(MAPS))
[owise] .
eq maps2QidList((sort S to S')) = ('sort S 'to S') .
eq maps2QidList(((label L to L'), MAPS))
= ('label L 'to L' '`, '\s maps2QidList(MAPS))
[owise] .
eq maps2QidList((label L to L')) = ('label L 'to L') .
eq maps2QidList(((msg F to F'), MAPS))
= ('msg F 'to F' '`, '\s maps2QidList(MAPS))
[owise] .
eq maps2QidList((msg F to F')) = ('msg F 'to F') .
eq maps2QidList(((msg F : TyL -> Ty to F'), MAPS))
= ('msg F ': typeList2QidList(TyL) '-> Ty 'to F' '`, '\s
maps2QidList(MAPS))
[owise] .
eq maps2QidList((msg F : TyL -> Ty to F'))
= ('msg F ': typeList2QidList(TyL) '-> Ty 'to F') .
eq maps2QidList(((class S to S'), MAPS))
= ('class S 'to S' '`, '\s maps2QidList(MAPS))
[owise] .
eq maps2QidList((class S to S')) = ('class S 'to S') .
eq maps2QidList(((attr QI . S to QI'), MAPS))
= ('attr S '. QI 'to QI' '`, '\s maps2QidList(MAPS))
[owise] .
eq maps2QidList((attr QI . S to QI')) = ('attr S '. QI 'to QI') .
eq maps2QidList(none) = nil .
eq attrSet2QidList(none) = nil .
eq attrSet2QidList((assoc AtS)) = ('assoc attrSet2QidList(AtS)) .
eq attrSet2QidList((comm AtS)) = ('comm attrSet2QidList(AtS)) .
eq attrSet2QidList((idem AtS)) = ('idem attrSet2QidList(AtS)) .
eq attrSet2QidList((iter AtS)) = ('iter attrSet2QidList(AtS)) .
eq attrSet2QidList((id(T) AtS))
= ('id: termList2QidList(T) attrSet2QidList(AtS)) .
eq attrSet2QidList((right-id(T) AtS))
= ('right-id: termList2QidList(T) attrSet2QidList(AtS)) .
eq attrSet2QidList((left-id(T) AtS))
= ('left-id: termList2QidList(T) attrSet2QidList(AtS)) .
eq attrSet2QidList((poly(NL) AtS))
= ('poly '`( intList2QidList(NL) '`) attrSet2QidList(AtS)) .
eq attrSet2QidList((strat(NL) AtS))
= ('strat '`( intList2QidList(NL) '`) attrSet2QidList(AtS)) .
eq attrSet2QidList((memo AtS)) = ('memo attrSet2QidList(AtS)) .
eq attrSet2QidList((prec(N) AtS))
= ('prec intList2QidList(N) attrSet2QidList(AtS)) .
eq attrSet2QidList((gather(QIL) AtS))
= ('gather QIL attrSet2QidList(AtS)) .
eq attrSet2QidList((format(QIL) AtS))
= ('format QIL attrSet2QidList(AtS)) .
eq attrSet2QidList((ctor AtS)) = ('ctor attrSet2QidList(AtS)) .
eq attrSet2QidList((frozen(NL) AtS))
= ('frozen '`( intList2QidList(NL) '`) attrSet2QidList(AtS)) .
eq attrSet2QidList((config AtS)) = ('config attrSet2QidList(AtS)) .
eq attrSet2QidList((object AtS)) = ('object attrSet2QidList(AtS)) .
eq attrSet2QidList((msg AtS)) = ('msg attrSet2QidList(AtS)) .
eq attrSet2QidList((special(HkL) AtS))
= ('special '`( hookList2QidList(HkL) '`) attrSet2QidList(AtS)) .
eq attrSet2QidList((none).AttrSet) = nil .
eq attrSet2QidList((metadata(St) AtS)) = (('metadata qid("\"" + St + "\"")) attrSet2QidList(AtS)) .
eq attrSet2QidList((nonexec AtS)) = ('nonexec attrSet2QidList(AtS)) .
eq attrSet2QidList((variant AtS)) = ('variant attrSet2QidList(AtS)) .
eq hookList2QidList((id-hook(QI, QIL) HkL))
= ('id-hook QI '`, '`( QIL '`) hookList2QidList(HkL)) .
eq hookList2QidList((op-hook(QI, QI', QIL, QI'') HkL))
= ('op-hook QI '`( QI' ': QIL '-> QI'' '`) hookList2QidList(HkL)) .
eq hookList2QidList((term-hook(QI, T) HkL))
= ('term-hook '`( QI '`, termList2QidList(T) '`) hookList2QidList(HkL)) .
eq termList2QidList(QI) = QI .
eq termList2QidList(F[TL]) = (F '`( termList2QidList(TL) '`)) .
ceq termList2QidList((T, TL))
= (termList2QidList(T) '`, termList2QidList(TL))
if TL =/= empty .
eq intList2QidList((N NL)) = (qid(string(N, 10)) intList2QidList(NL)) .
eq intList2QidList(nil) = nil .
eq typeList2QidList(Ty TyL) = type2qid(Ty) typeList2QidList(TyL) .
eq typeList2QidList(nil) = nil .
*** Let us now give the equations for \texttt{setUpModExpDeps} on the
*** renaming module expression. Given a module expression of the form
*** \verb~ME *< VMAPS >~ such that \texttt{ME} is in the database, we just need
*** to add \verb~ME *< VMAPS >~ to the set of names of the modules depending on
*** \texttt{ME}. In this way, if \texttt{ME} is redefined or removed from the
*** database, \verb~ME *< VMAPS >~ will be removed as well.
eq setUpModExpDeps(ME * (VMAPS),
db(< ME ; DT ; U ; U' ; M ; VDS ; MNS ; VES > MIS,
MNS', VIS, VES', MNS'', MNS3, MNS4, QIL))
= db(< ME ; DT ; U ; U' ; M ; VDS ; MNS . ME * (VMAPS) ; VES > MIS,
MNS', VIS, VES', MNS'', MNS3, MNS4, QIL) .
eq setUpModExpDeps(ME * (VMAPS),
db(< ME ; DM ; U ; U' ; M ; VDS ; MNS ; VES > MIS,
MNS', VIS, VES', MNS'', MNS3, MNS4, QIL))
= db(< ME ; DM ; U ; U' ; M ; VDS ; MNS . ME * (VMAPS) ; VES > MIS,
MNS', VIS, VES', MNS'', MNS3, MNS4, QIL) .
ceq setUpModExpDeps(ME * (VMAPS), DB)
= warning(DB, '\r 'Error: '\o 'Module header2QidList(ME) 'not 'in 'database. '\n)
if not unitInDb(ME, DB) .
*** The definition of the \texttt{prepHeader} function on a renaming module
*** expression must take into account the possibility of having parameterized
*** sorts or parameterized class names in the maps of a renaming module
*** expression. The preparation of a renaming module expression must take
*** into account this fact and prepare accordingly all parameterized sorts and
*** classes appearing in it.
op prepare : RenamingSet Set{Tuple{ViewExp,ViewExp}} -> RenamingSet .
op prepare : TypeList Set{Tuple{ViewExp,ViewExp}} -> TypeList .
eq prepModExp(ME * (VMAPS), VEPS)
= _*`(_`)(prepModExp(ME, VEPS), prepare(VMAPS, VEPS)) .
*** For example, for sort maps the equation is as follows.
eq prepare((sort S to S'), VEPS)
= (sort prepSort(S, VEPS) to prepSort(S', VEPS)) .
eq prepare(((sort S to S'), VMAPS), VEPS)
= ((sort prepSort(S, VEPS) to prepSort(S', VEPS)),
prepare(VMAPS, VEPS)) .
eq prepare((class S to S'), VEPS)
= (class prepSort(S, VEPS) to prepSort(S', VEPS)) .
eq prepare(((class S to S'), VMAPS), VEPS)
= ((class prepSort(S, VEPS) to prepSort(S', VEPS)),
prepare(VMAPS, VEPS)) .
eq prepare((attr QI . S to QI'), VEPS)
= (attr QI . prepSort(S, VEPS) to QI') .
eq prepare(((attr QI . S to QI'), VMAPS), VEPS)
= ((attr QI . prepSort(S, VEPS) to QI'), prepare(VMAPS, VEPS)) .
eq prepare((op F to F' [AtS]), VEPS) = (op F to F' [AtS]) .
eq prepare(((op F to F' [AtS]), VMAPS), VEPS)
= ((op F to F' [AtS]), prepare(VMAPS, VEPS)) .
eq prepare((op F : TyL -> Ty to F' [AtS]), VEPS)
= (op F : prepare(TyL, VEPS) -> prepSort(Ty, VEPS) to F' [AtS]) .
eq prepare(((op F : TyL -> Ty to F' [AtS]), VMAPS), VEPS)
= (op F : prepare(TyL, VEPS) -> prepSort(Ty, VEPS) to F' [AtS],
prepare(VMAPS, VEPS)) .
eq prepare((label L to L'), VEPS) = (label L to L') .
eq prepare(((label L to L'), VMAPS), VEPS)
= ((label L to L'), prepare(VMAPS, VEPS)) .
eq prepare((msg F to F'), VEPS) = (msg F to F') .
eq prepare(((msg F to F'), VMAPS), VEPS)
= ((msg F to F'), prepare(VMAPS, VEPS)) .
eq prepare((msg F : TyL -> Ty to F'), VEPS)
= (msg F : prepare(TyL, VEPS) -> prepSort(Ty, VEPS) to F') .
eq prepare(((msg F : TyL -> Ty to F'), VMAPS), VEPS)
= ((msg F : prepare(TyL, VEPS) -> prepSort(Ty, VEPS) to F'),
prepare(VMAPS, VEPS)) .
eq prepare((none).RenamingSet, VEPS) = none .
eq prepare((Ty TyL), VEPS) = (prepSort(Ty, VEPS) prepare(TyL, VEPS)) .
eq prepare(nil, VEPS) = nil .
eq header2Qid(ME * (MAPS))
= qid(string(header2Qid(ME))
+ " * (" + string(qidList2Qid(maps2QidList(MAPS))) + ")")
[owise] .
ceq header2QidList(ME * (MAPS))
= (if QI == '\s then QIL QI else QIL QI '\s fi
'* '\s '`( maps2QidList(MAPS) '`))
if QIL QI := header2QidList(ME)
[owise] .
endfm
*******************************************************************************
***
*** The Union Module Expression
***
*** The syntax used for the union of module expressions is
*** op _+_ : ModuleExpression ModuleExpression -> ModuleExpression
*** [assoc prec 42] .
*** Its evaluation consists in generating a unit importing the two module
*** expressions given as arguments~\cite{Winkler91,OBJ92}.
*** As we explained in Sections~\ref{instantiation} and~\ref{renaming} for the
*** cases of the instantiation and the renaming module expressions,
*** respectively, the declaration of any new kind of module expression must
*** come together with the definition of the functions \texttt{evalModExp},
*** \texttt{header2QidList}, and \texttt{setUpModExpDeps} on the new
*** module operator. As discussed in Sections~\ref{instantiation}
*** and~\ref{parsing-unit-declarations}, equations for the \texttt{prepHeader}
*** and \texttt{parseModExp} functions have to be given as well.
fmod UNION-EXPR is
inc MOD-EXPR .
pr INST-EXPR-EVALUATION .
pr RENAMING-EXPR-EVALUATION .
pr EVALUATION .
vars QI X : Qid .
var PDL : ParameterDeclList .
vars DB DB' DB'' : Database .
vars T T' : Term .
vars DT DT' : Default{Term} .
var IL : ImportList .
var VEPS : Set{Tuple{ViewExp,ViewExp}} .
vars ME ME' ME'' ME3 : ModuleExpression .
vars PU PU' U U' U'' U3 DM DM' : Module .
vars M M' M'' M3 : Module .
vars MNS MNS' MNS'' MNS3 MNS4 MNS5 : Set{ModuleName} .
vars VES VES' VES'' : Set{ViewExp} .
vars PDS PDS' PDS'' : Set{ParameterDecl} .
vars MIS MIS' : Set{ModuleInfo} .
var VIS : Set{ViewInfo} .
vars QIL QIL' : QidList .
var VDS VDS' : OpDeclSet .
var B : Bool .
var MAPS : RenamingSet .
*** As mentioned above, the evaluation of a union module expression consists
*** in the creation of a new unit, with such a module expression as name,
*** which imports the two module expressions being united. Note, however,
*** that the unit being created has to be of the right type. The new unit
*** will be generated having one type or another, depending on the types of
*** the arguments of the union module expression.
*** The function \texttt{rightEmptyModule} generates an empty unit of the
*** lowest of the sorts of its two arguments. In case of having a nonstructured
*** module as argument, the corresponding structured one is considered. If one
*** of the two module expressions corresponds to a theory, then a theory is
*** generated, and the lowest sort is taken between the sort of such a theory
*** and the \texttt{Module} sort immediately above the sort of the other unit;
*** that is, sorts \texttt{FModule}, \texttt{SModule}, or \texttt{OModule} are
*** considered to do the comparison.
---- ceq evalModExpAux(ME + ME', PDL, DB)
---- = if unitInDb(ME'' + ME3, DB'') or-else not (unitInDb(ME'', DB'') and-then unitInDb(ME3, DB''))
---- then < DB'' ; ME'' + ME3 >
---- else < evalModule(
---- addImports(including ME'' . including ME3 .,
---- setName(
---- rightEmptyModule(
---- getTopModule(ME'', DB''),
---- getTopModule(ME3, DB'')),
---- ME'' + ME3)),
---- none,
---- DB'') ;
---- ME'' + ME3 >
---- fi
---- if < DB' ; ME3 > := evalModExpAux(ME', PDL, DB)
---- /\ < DB'' ; ME'' > := evalModExpAux(ME, PDL, DB') .
ceq evalModExp(ME + ME', PDL, DB)
= if unitInDb(ME'', DB') or-else not summandsInDB(ME'', DB')
then < DB' ; ME'' >
else < evalModule(
addImports(unfoldSummands(ME''),
setName(rightEmptyModule(ME'', DB'), ME'')),
none,
DB')
; ME'' >
fi
if < DB' ; ME'' > := evalModExp+(ME + ME', PDL, DB) .
op summandsInDB : ModuleExpression Database -> Bool .
eq summandsInDB(ME + ME', DB)
= summandsInDB(ME, DB) and-then summandsInDB(ME', DB) .
eq summandsInDB(ME, DB) = unitInDb(ME, DB) [owise] .
op unfoldSummands : ModuleExpression -> ImportList .
eq unfoldSummands(ME + ME') = unfoldSummands(ME) unfoldSummands(ME') .
eq unfoldSummands(ME) = (including ME .) [owise] .
op rightEmptyModule : ModuleExpression Database -> Module .
eq rightEmptyModule(ME, DB) = emptyModule(kindOfModule(ME, DB)) .
op evalModExp+ : ModuleExpression ParameterDeclList Database -> Tuple{Database, ModuleExpression} .
eq evalModExp+(ME + ME', PDL, DB)
= < database(evalModExp+(ME', PDL, database(evalModExp+(ME, PDL, DB))))
; modExp(evalModExp+(ME', PDL, database(evalModExp+(ME, PDL, DB))))
+ modExp(evalModExp+(ME, PDL, DB)) > .
eq evalModExp+(ME, PDL, DB) = evalModExp(ME, PDL, DB) [owise] .
op kindOfModule : ModuleExpression Database -> Qid .
eq kindOfModule(ME + ME', DB) = greaterLowest(kindOfModule(ME, DB), kindOfModule(ME', DB)) .
eq kindOfModule(ME, DB) = kindOfModule(getTopModule(ME, DB)) [owise] .
op kindOfModule : Module -> Qid .
eq kindOfModule(U:OModule)
= if U:OModule :: FModule
then 'fmod
else if U:OModule :: SModule
then 'mod
else 'omod
fi
fi .
eq kindOfModule(U:OTheory)
= if U:OTheory :: FTheory
then 'fmod
else if U:OTheory :: STheory
then 'mod
else 'omod
fi
fi .
eq kindOfModule(unitError(QIL)) = qidError(QIL) .
op greaterLowest : Qid Qid ~> Qid [comm] .
eq greaterLowest('fmod, 'fmod) = 'fmod .
eq greaterLowest('fmod, 'fth) = 'fth .
eq greaterLowest('fth, 'fth) = 'fth .
eq greaterLowest('mod, 'fmod) = 'mod .
eq greaterLowest('mod, 'mod) = 'mod .
eq greaterLowest('mod, 'fth) = 'th .
eq greaterLowest('fmod, 'th) = 'th .
eq greaterLowest('mod, 'th) = 'th .
eq greaterLowest('th, 'th) = 'th .
eq greaterLowest('omod, 'fmod) = 'omod .
eq greaterLowest('omod, 'mod) = 'omod .
eq greaterLowest('omod, 'omod) = 'omod .
eq greaterLowest('omod, 'fth) = 'oth .
eq greaterLowest('omod, 'th) = 'oth .
eq greaterLowest('omod, 'oth) = 'oth .
eq greaterLowest('fmod, 'oth) = 'oth .
eq greaterLowest('mod, 'oth) = 'oth .
eq greaterLowest('oth, 'th) = 'oth .
eq greaterLowest('oth, 'fth) = 'oth .
eq greaterLowest('oth, 'oth) = 'oth .
op emptyModule : Qid ~> Module .
eq emptyModule('fmod) = emptyFModule .
eq emptyModule('fth) = emptyFTheory .
eq emptyModule('mod) = emptySModule .
eq emptyModule('th) = emptySTheory .
eq emptyModule('omod) = emptyOModule .
eq emptyModule('oth) = emptyOTheory .
---- op rightEmptyModule : Module Module -> Module [comm] .
----
---- eq rightEmptyModule(U1:FModule, U2:FModule) = emptyFModule .
---- eq rightEmptyModule(U1:FModule, U2:FTheory) = emptyFTheory .
---- eq rightEmptyModule(U1:FTheory, U2:FModule) = emptyFTheory .
---- eq rightEmptyModule(U1:FTheory, U2:FTheory) = emptyFTheory .
---- ceq rightEmptyModule(U1:SModule, U2:SModule) = emptySModule if not U1:SModule :: FModule or not U2:SModule :: FModule .
---- ceq rightEmptyModule(U1:STheory, U2:SModule) = emptySTheory if not U1:STheory :: FTheory or not U2:SModule :: FModule .
---- ceq rightEmptyModule(U1:SModule, U2:STheory) = emptySTheory if not U1:SModule :: FModule or not U2:STheory :: FTheory .
---- ceq rightEmptyModule(U1:STheory, U2:STheory) = emptySTheory if not U1:STheory :: FTheory or not U2:STheory :: FTheory .
---- ceq rightEmptyModule(U1:OModule, U2:OModule) = emptyOModule if not U1:OModule :: SModule or not U2:OModule :: SModule .
---- ceq rightEmptyModule(U1:OTheory, U2:OModule) = emptyOTheory if not U1:OTheory :: STheory or not U2:OModule :: SModule .
---- ceq rightEmptyModule(U1:OModule, U2:OTheory) = emptyOTheory if not U1:OModule :: SModule or not U2:OTheory :: STheory .
---- ceq rightEmptyModule(U1:OTheory, U2:OTheory) = emptyOTheory if not U1:OTheory :: STheory or not U2:OTheory :: STheory .
---- eq rightEmptyModule(unitError(QIL), U) = unitError(QIL) .
---- eq rightEmptyModule(U, unitError(QIL)) = unitError(QIL) .
---- eq rightEmptyModule(unitError(QIL), unitError(QIL')) = unitError(QIL QIL') .
*** As pointed out in Section~\ref{module-names}, for each new module
*** expression operator being introduced, we need to add equations for the
*** \texttt{header2Qid} function. For the union module expression we only
*** need the following equation:
eq header2Qid(ME + ME')
= qidList2Qid(header2QidList(ME) '+ header2QidList(ME')) .
eq header2Qid(_*`(_`)(ME + ME', MAPS))
= qid("(" + string(header2Qid(ME + ME')) + ")"
+ " * (" + string(qidList2Qid(maps2QidList(MAPS))) + ")") .
eq header2QidList(ME + ME')
= (header2QidList(ME) '+ header2QidList(ME')) .
ceq header2QidList(_*`(_`)(ME + ME', MAPS))
= (if QI == '\s then '`( QIL '`) QI else '`( QIL QI '`) '\s fi
'* '\s '`( maps2QidList(MAPS) '`))
if QIL QI := header2QidList(ME + ME') .
*** Given a module
*** expression of the form \verb~ME + ME'~ such that \texttt{ME} and
*** \texttt{ME'} are in the database, we need to add \verb~ME + ME'~ to
*** the set of names of the modules depending on \texttt{ME} and \texttt{ME'}.
*** In this way, if \texttt{ME} or \texttt{ME'} are redefined or removed from
*** the database, \verb~ME + ME'~ will be removed as well.
op setUpModExpDepsAux : ModuleExpression ModuleExpression Database -> Database .
eq setUpModExpDeps(ME + ME', DB) = setUpModExpDepsAux(ME + ME', ME + ME', DB) .
eq setUpModExpDepsAux(ME, ME' + ME'', DB)
= setUpModExpDepsAux(ME, ME', setUpModExpDepsAux(ME, ME'', DB)) .
eq setUpModExpDepsAux(ME, ME',
db(< ME' ; DT ; U ; U' ; M ; VDS ; MNS ; VES > MIS, MNS'', VIS, VES'', MNS3, MNS4, MNS5, QIL))
= db(< ME' ; DT ; U ; U' ; M ; VDS ; MNS . ME ; VES > MIS, MNS'', VIS, VES'', MNS3, MNS4, MNS5, QIL)
[owise] .
eq setUpModExpDepsAux(ME, ME',
db(< ME' ; DM ; U ; U' ; M ; VDS ; MNS ; VES > MIS, MNS'', VIS, VES'', MNS3, MNS4, MNS5, QIL))
= db(< ME' ; DM ; U ; U' ; M ; VDS ; MNS . ME ; VES > MIS, MNS'', VIS, VES'', MNS3, MNS4, MNS5, QIL)
[owise] .
---( eq setUpModExpDeps((ME + ME'),
db((< ME ; DT ; U ; U' ; M ; VDS ; MNS ; VES >
< ME' ; DT' ; U'' ; U3 ; M' ; VDS' ; MNS' ; VES' > MIS),
MNS'', VIS, VES'', MNS3, MNS4, MNS5, QIL))
= db((< ME ; DT ; U ; U' ; M ; VDS ; MNS . (ME + ME') ; VES >
< ME' ; DT' ; U'' ; U3 ; M' ; VDS' ; MNS' . (ME + ME') ; VES' >
MIS),
MNS'', VIS, VES'', MNS3, MNS4, MNS5, QIL) .
eq setUpModExpDeps((ME + ME'),
db((< ME ; DT ; U ; U' ; M ; VDS ; MNS ; VES >
< ME' ; DM ; U'' ; U3 ; M' ; VDS' ; MNS' ; VES' > MIS),
MNS'', VIS, VES'', MNS3, MNS4, MNS5, QIL))
= db((< ME ; DT ; U ; U' ; M ; VDS ; MNS . (ME + ME') ; VES >
< ME' ; DM ; U'' ; U3 ; M' ; VDS' ; MNS' . (ME + ME') ; VES' >
MIS),
MNS'', VIS, VES'', MNS3, MNS4, MNS5, QIL) .
eq setUpModExpDeps((ME + ME'),
db((< ME ; DM ; U ; U' ; M ; VDS ; MNS ; VES >
< ME' ; DT ; U'' ; U3 ; M' ; VDS' ; MNS' ; VES' > MIS),
MNS'', VIS, VES'', MNS3, MNS4, MNS5, QIL))
= db((< ME ; DM ; U ; U' ; M ; VDS ; MNS . (ME + ME') ; VES >
< ME' ; DT ; U'' ; U3 ; M' ; VDS' ; MNS' . (ME + ME') ; VES' >
MIS),
MNS'', VIS, VES'', MNS3, MNS4, MNS5, QIL) .
eq setUpModExpDeps((ME + ME'),
db((< ME ; DM ; U ; U' ; M ; VDS ; MNS ; VES >
< ME' ; DM' ; U'' ; U3 ; M' ; VDS' ; MNS' ; VES' > MIS),
MNS'', VIS, VES'', MNS3, MNS4, MNS5, QIL))
= db((< ME ; DM ; U ; U' ; M ; VDS ; MNS . (ME + ME') ; VES >
< ME' ; DM' ; U'' ; U3 ; M' ; VDS' ; MNS' . (ME + ME') ; VES' >
MIS),
MNS'', VIS, VES'', MNS3, MNS4, MNS5, QIL) .
ceq setUpModExpDeps((ME + ME'), DB)
= warning(DB, ('\r 'Error: '\o 'Module header2QidList(ME) 'not 'in 'database. '\n))
if not unitInDb(ME, DB) .
ceq setUpModExpDeps((ME + ME'), DB)
= warning(DB, ('\r 'Error: '\o 'Module header2QidList(ME') 'not 'in 'database. '\n))
if not unitInDb(ME', DB) .
---)
*** The \texttt{prepHeader} function on a union module expression makes
*** recursive calls with each of the module expressions given as arguments.
eq prepModExp(ME + ME', VEPS)
= prepModExp(ME, VEPS) + prepModExp(ME', VEPS) .
*** Finally, the equation for the \texttt{parseModExp} function is as follows:
eq labelInModExp(X, ME + ME')
= labelInModExp(X, ME) or-else labelInModExp(X, ME') .
endfm
*******************************************************************************
***
*** The $n$-tuple Module Expression
***
*** The syntax used for the $n$-tuple module expression is as follows:
*** op TUPLE[_] : Token -> ModuleExpression .
*** Its evaluation consists in the generation of a parameterized functional
*** module with the number of \texttt{TRIV} parameters specified by the
*** argument. A sort for tuples of such size, and the corresponding constructor
*** and selector operators, are also defined. Note that the \texttt{TRIV}
*** theory is predefined in Full Maude (see Sections~\ref{main-module}
*** and~\ref{non-built-in-predefined}). For example, the module expression
*** \verb~TUPLE[3]~ produces the following module.
*** fmod TUPLE[3][C1 :: TRIV, C2 :: TRIV, C3 :: TRIV] is
*** sorts 3Tuple .
*** op p1_ : 3Tuple -> Elt.C1 .
*** op p2_ : 3Tuple -> Elt.C2 .
*** op p3_ : 3Tuple -> Elt.C3 .
*** var E1 : Elt.C1 .
*** var E2 : Elt.C2 .
*** var E3 : Elt.C3 .
*** eq p1(E1, E2, E3) = E1 .
*** eq p2(E1, E2, E3) = E2 .
*** eq p3(E1, E2, E3) = E3 .
*** endfm
*** Even though the $n$-tuple module expression is in principle of a completely
*** different nature, the way of handling it is the same as the way of handling
*** any other module expression. Its evaluation produces a new unit, a
*** parameterized functional module in this case, wtupleParList(N)ith the module expression as
*** name. New equations defining the semantics of functions
*** \texttt{evalModExp}, \texttt{header2QidList},
*** \texttt{setUpModExpDeps}, \texttt{prepHeader}, and
*** \texttt{parseModExp} are given for this module expression.
fmod N-TUPLE-EXPR is
inc MOD-EXPR .
pr INST-EXPR-EVALUATION .
pr EVALUATION .
vars N N' : NzNat .
var PDL : ParameterDeclList .
var DB : Database .
var T : Term .
var IL : ImportList .
var VEPS : Set{Tuple{ViewExp,ViewExp}} .
var X : Qid .
var S : Sort .
*** The equation for the \texttt{evalModExp} is reduced to the creation of a
*** module as indicated above. Some auxiliary functions are defined in order
*** to generate the different declarations in the module.
op tupleParList : NzNat -> ParameterDeclList .
op tupleImportList : NzNat -> ImportList .
op createCopyPars : NzNat Database -> Database .
op tupleOps : NzNat -> OpDeclSet .
op tupleOpsCtor : NzNat -> OpDecl .
op tupleOpsCtorName : NzNat -> String .
op tupleOpsCtorArity : NzNat -> QidList .
op tupleOpsSelectors : NzNat NzNat -> OpDeclSet .
op tupleEqSet : NzNat -> EquationSet .
op tupleEqSetAux : NzNat Term -> EquationSet .
op tupleTermArgs : NzNat -> TermList .
ops tupleSort tupleSortAux : NzNat -> Sort .
eq evalModExp(TUPLE[N], PDL, DB)
= if unitInDb(TUPLE[N], DB)
then < DB ; TUPLE[N] >
else < evalModule(
fmod TUPLE[N]{tupleParList(N)} is
nil ---- tupleImportList(N)
sorts tupleSort(N) .
none
tupleOps(N)
none
tupleEqSet(N)
endfm,
none,
createCopyPars(N, DB)) ;
TUPLE[N] >
fi .
eq createCopyPars(N, DB)
= if N == 1
then createCopy((qid("C" + string(N, 10)) :: 'TRIV), DB)
else createCopyPars(_-_(N, 1),
createCopy((qid("C" + string(N, 10)) :: 'TRIV), DB))
fi .
eq tupleParList(N)
= if N == 1
then (qid("C" + string(N, 10)) :: 'TRIV)
else (tupleParList(_-_(N, 1)), (qid("C" + string(N, 10)) :: 'TRIV))
fi .
eq tupleImportList(N)
= if N == 1
then (including pd(qid("C" + string(N, 10)) :: 'TRIV) .)
else (tupleImportList(_-_(N, 1))
(including pd(qid("C" + string(N, 10)) :: 'TRIV) .))
fi .
eq tupleSort(N) = makeSort('Tuple, tupleSortAux(N)) .
eq tupleSortAux(N)
= if N == 1
then qid("C" + string(N, 10))
else (tupleSortAux(_-_(N, 1)), qid("C" + string(N, 10)))
fi .
eq tupleOps(N)
= (tupleOpsCtor(N) tupleOpsSelectors(N, N)) .
eq tupleOpsCtor(N)
= (op qid("(" + tupleOpsCtorName(N) + ")") :
tupleOpsCtorArity(N) -> tupleSort(N) [none] .) .
eq tupleOpsCtorName(N)
= if N == 1
then "_"
else "_," + tupleOpsCtorName(_-_(N, 1))
fi .
eq tupleOpsCtorArity(N)
= if N == 1
then qid("C" + string(N, 10) + "$Elt")
else tupleOpsCtorArity(_-_(N, 1)) qid("C" + string(N, 10) + "$Elt")
fi .
eq tupleOpsSelectors(N, N')
= if N == 1
then (op qid("p" + string(N, 10) + "_") :
tupleSort(N') -> qid("C" + string(N, 10) + "$Elt") [none] .)
else (tupleOpsSelectors(_-_(N, 1), N')
(op qid("p" + string(N, 10) + "_") :
tupleSort(N') -> qid("C" + string(N, 10) + "$Elt") [none] .))
fi .
eq tupleEqSet(N)
= tupleEqSetAux(N,
(qid("(" + tupleOpsCtorName(N) + ")") [ tupleTermArgs(N) ])) .
eq tupleTermArgs(N)
= if N == 1
then qid("V" + string(N, 10) + ":C" + string(N, 10) + "$Elt")
else (tupleTermArgs(_-_(N, 1)),
qid("V" + string(N, 10) + ":C" + string(N, 10) + "$Elt"))
fi .
eq tupleEqSetAux(N, T)
= if N == 1
then (eq qid("p" + string(N, 10) + "_")[T]
= qid("V" + string(N, 10) + ":C" + string(N, 10) + "$Elt")
[none] .)
else (tupleEqSetAux(_-_(N, 1), T)
(eq qid("p" + string(N, 10) + "_")[T]
= qid("V" + string(N, 10) + ":C" + string(N, 10) + "$Elt")
[none] .))
fi .
*** The equations for the \texttt{header2QidList},
*** \texttt{parseModExp}, \texttt{prepHeader}, and
*** \texttt{setUpModExpDeps} functions on the $n$-tuple module
*** expression are as follows:
eq header2Qid(TUPLE[N]) = qid("TUPLE[" + string(N, 10) + "]") .
eq header2QidList(TUPLE[N]) = ('TUPLE '`[ qid(string(N, 10)) '`]) .
eq prepModExp(TUPLE[N], VEPS) = TUPLE[N] .
eq setUpModExpDeps(TUPLE[N], DB) = DB .
endfm
fmod N-POWER-EXPR is
inc MOD-EXPR .
pr INST-EXPR-EVALUATION .
pr EVALUATION .
vars N N' : NzNat .
var PDL : ParameterDeclList .
var DB : Database .
var T : Term .
var IL : ImportList .
var VEPS : Set{Tuple{ViewExp,ViewExp}} .
var X : Qid .
var S : Sort .
*** As for TUPLE, the equation for the \texttt{evalModExp} is reduced to the
*** creation of a new module. A module expression POWER[n]{Nat} produces a
*** module
***
*** fmod POWER[n]{X :: TRIV} is
*** inc TUPLE[n]{X, X, ..., X} .
*** endfm
***
*** which is then instantiated by the Nat view.
*** Some auxiliary functions are defined in order
*** to generate the different declarations in the module.
op powImportList : NzNat -> ImportList .
op powTupleImportation : NzNat -> ViewExp .
eq evalModExp(POWER[N], PDL, DB)
= if unitInDb(POWER[N], DB)
then < DB ; POWER[N] >
else < evalModule(
fmod POWER[N]{'X :: 'TRIV} is
powImportList(N)
sorts none .
none
none
none
none
endfm,
none,
createCopy('X :: 'TRIV, DB)) ;
POWER[N] >
fi .
eq powImportList(N)
= (including TUPLE[N]{powTupleImportation(N)} .) .
eq powTupleImportation(N)
= if N == 1
then 'X
else ('X, powTupleImportation(sd(N, 1)))
fi .
*** The equations for the \texttt{header2QidList},
*** \texttt{parseModExp}, \texttt{prepHeader}, and
*** \texttt{setUpModExpDeps} functions on the $n$-tuple module
*** expression are as follows:
eq header2Qid(POWER[N]) = qid("POWER[" + string(N, 10) + "]") .
eq header2QidList(POWER[N]) = ('POWER '`[ qid(string(N, 10)) '`]) .
eq prepModExp(POWER[N], VEPS) = POWER[N] .
eq setUpModExpDeps(POWER[N], DB) = DB .
endfm
*******************************************************************************
***
*** 8 Input/Output Processing
***
*** In this section we discuss how the preterm resulting from the call to the
*** function \texttt{metaParse} with the input and the top-level signature of
*** Full Maude is transformed into a term of sort \texttt{Module}, representing
*** a preunit or a term of sort \texttt{PreView}. In the case of commands,
*** they are evaluated giving the corresponding results in the appropriate
*** form.
***
*** 8.1 Input Parsing
***
*** Let us recall here the example presented in Section~\ref{bubbles}. Calling
*** \texttt{metaParse} with the module \texttt{NAT3} given there and the
*** signature of Full Maude presented in Section~\ref{sec:signature}, we
*** obtain the following term.
*** 'fmod_is_endfm[
*** 'token[{''NAT3}'Qid],
*** '__['sort_.['token[{''Nat3}'Qid]],
*** '__['op_:_->_.['token[{''s_}'Qid],
*** 'neTokenList[{''Nat3}'Qid],
*** 'token[{''Nat3}'Qid]],
*** '__['op_:`->_.['token[{''0}'Qid],
*** 'token[{''Nat3}'Qid]],
*** 'eq_=_.['bubble['__[{''s}'Qid, {''s}'Qid,
*** {''s}'Qid, {''0}'Qid]],
*** 'bubble[{''0}'Qid]]]]]]
*** Given each one of the subterms representing declarations in terms
*** representing modules as the previous one, the function \texttt{parseDecl}
*** generates the corresponding declaration, with no bubbles in it, and the
*** corresponding predeclaration, with the bubbles appearing in the term. For
*** example, for the term
***
*** 'op_:_->_.['token[{''s_}'Qid],
*** 'neTokenList[{''Nat3}'Qid],
*** 'token[{''Nat3}'Qid]]
***
*** the following operator declaration is generated:
***
*** op 's_ : 'Nat3 -> 'Nat3 [none] .
***
*** Note that in this case, since the operator is declared without identity
*** element (the only place a bubble might appear), the declaration and the
*** predeclaration generated by \texttt{parseDecl} coincide.
*** In the following sections we shall see how this approach is followed for
*** declarations appearing in units and in views.
***
*** 8.1.1 Parsing of Module Declarations
***
*** The \texttt{parseDecl} function takes a term (which corresponds to a
*** declaration to be parsed), a preunit (to which the parsed declaration with
*** its bubbles in it will be added), and a unit (to which the parsed
*** declaration without bubbles will be added to build up the signature). For
*** example, a term corresponding to an unconditional equation, that is, a term
*** of the form \verb~'eq_=_.[T, T']~ will be added to the set of equations of
*** the preunit as \verb~eq T = T' .~, but nothing will be added to the unit.
*** Note that according to the signature used in the call to
*** \texttt{metaParse} (see Sections~\ref{sec:signature}
*** and~\ref{main-module}), \texttt{T} and \texttt{T'} are bubbles.
*** Declarations of sorts, subsort relations, operators, classes, subclass
*** relations, messages, and variables will be added to both of them. In the
*** case of operator declarations, identity element attributes, which in
*** general can be terms, are not included in the added declaration.
*** As in Core Maude, declarations in a module can be given in any order, and
*** therefore we follow a two-step approach consisting in first building the
*** signature to parse the bubbles, and then generating the unit without
*** bubbles in it. It could be different for other languages. For example, in
*** some languages we may be able to assume that each operator and sort has
*** been defined before being used, allowing then an incremental processing of
*** the input.
---- fmod MAYBE{X :: TRIV} is
---- sort Maybe{X} .
---- subsort X$Elt < Maybe{X} .
---- op maybe : -> Maybe{X} .
---- endfm
fmod UNIT-DECL-PARSING is
pr DATABASE .
pr MOVE-DOWN .
pr INST-EXPR-EVALUATION .
pr RENAMING-EXPR-EVALUATION .
pr UNION-EXPR .
pr N-TUPLE-EXPR .
pr N-POWER-EXPR .
pr DEFAULT-VALUE{Term} .
pr META-FULL-MAUDE-SIGN .
pr UNIT-BUBBLE-PARSING .
vars PU U : Module .
vars T T' T'' T''' T3 T4 : Term .
vars QI QI' QI'' L F : Qid .
vars QIL QIL' : QidList .
vars S S' : Sort .
vars SS SS' : TypeSet .
vars TyL TyL' : TypeList .
var TSL : TypeSetList .
var AtS : AttrSet .
vars TL TL' TL'' : TermList .
var Ct : Constant .
var VDS : OpDeclSet .
vars Ty Tp : Type .
var N : Nat .
var DT : Default{Term} .
*** Similarly, auxiliary functions parsing other elements in units
*** are defined.
op parsePreAttrs : Term Nat -> AttrSet .
op parsePreHookList : Term -> HookList .
op parseVars : QidList [Type] -> OpDeclSet .
op parseSubsortRel : Term -> TypeListSet .
op parseAttrDeclList : Term -> AttrDeclSet .
op unfoldOpDecl : QidList TypeList Sort AttrSet -> OpDeclSet .
op unfoldMultipleMsgDecl : QidList TypeList Sort -> MsgDeclSet .
op unfoldSubsortRel : TypeSetList ~> SubsortDeclSet .
op unfoldSubclassRel : TypeSetList ~> SubclassDeclSet .
eq parseSubsortRel('_<_[T, T'])
= _l_(parseSortSet(T), parseSubsortRel(T')) .
eq parseSubsortRel('__[T, T']) = parseSortSet('__[T, T']) .
eq parseSubsortRel('sortToken[T]) = downQid(T) .
eq parseSubsortRel('_`{_`}['sortToken[T], T'])
= makeSort(downQid(T), parseParameterList(T')) .
eq parseSubsortRel('_`{_`}['_`{_`}[T, T'], T''])
= makeSort(parseSubsortRel('_`{_`}[T, T']), parseParameterList(T'')) .
eq unfoldOpDecl((QI QIL), TyL, Ty, AtS)
= ((op QI : TyL -> Ty [AtS] .) unfoldOpDecl(QIL, TyL, Ty, AtS)) .
eq unfoldOpDecl(nil, TyL, Ty, AtS) = none .
eq unfoldMultipleMsgDecl((QI QIL), TyL, Ty)
= ((msg QI : TyL -> Ty .) unfoldMultipleMsgDecl(QIL, TyL, Ty)) .
eq unfoldMultipleMsgDecl(nil, TyL, Ty) = none .
eq unfoldSubsortRel(_l_((S ; SS), (S' ; SS'), TSL))
= ((subsort S < S' .)
unfoldSubsortRel(_l_(S, SS'))
unfoldSubsortRel(_l_(SS, (S' ; SS')))
unfoldSubsortRel(_l_((S' ; SS'), TSL))) .
eq unfoldSubsortRel(_l_(SS, none)) = none .
eq unfoldSubsortRel(_l_(none, SS)) = none .
eq unfoldSubsortRel(SS) = none .
eq unfoldSubsortRel(qidError(QIL)) = subsortDeclError(QIL) .
eq unfoldSubclassRel(_l_((S ; SS), (S' ; SS'), TSL))
= ((subclass S < S' .)
unfoldSubclassRel(_l_(S, SS'))
unfoldSubclassRel(_l_(SS, (S' ; SS')))
unfoldSubclassRel(_l_((S' ; SS'), TSL))) .
eq unfoldSubclassRel(_l_(SS, none)) = none .
eq unfoldSubclassRel(_l_(none, SS)) = none .
eq unfoldSubclassRel(SS) = none .
eq unfoldSubclassRel(qidError(QIL)) = subclassDeclError(QIL) .
eq parseVars((QI QIL), Tp)
= ((op QI : nil -> Tp [none] .) parseVars(QIL, Tp)) .
eq parseVars(nil, Tp) = none .
eq parseVars(QIL, qidError(QIL')) = opDeclError(QIL') .
eq parsePreAttrs('__[T, T'], N)
= (parsePreAttrs(T, N) parsePreAttrs(T', N)) .
eq parsePreAttrs('assoc.@Attr@, N) = assoc .
eq parsePreAttrs('associative.@Attr@, N) = assoc .
eq parsePreAttrs('comm.@Attr@, N) = comm .
eq parsePreAttrs('commutative.@Attr@, N) = comm .
eq parsePreAttrs('idem.@Attr@, N) = idem .
eq parsePreAttrs('idempotent.@Attr@, N) = idem .
eq parsePreAttrs('id:_[T], N) = id(T) .
eq parsePreAttrs('identity:_[T], N) = id(T) .
eq parsePreAttrs('left`id:_[T], N) = left-id(T) .
eq parsePreAttrs('left`identity:_[T], N) = left-id(T) .
eq parsePreAttrs('right`id:_[T], N) = right-id(T) .
eq parsePreAttrs('right`identity:_[T], N) = right-id(T) .
eq parsePreAttrs('poly`(_`)[T], N) = poly(parseInt(T)) .
eq parsePreAttrs('strat`(_`)[T], N) = strat(parseInt(T)) .
eq parsePreAttrs('strategy`(_`)[T], N) = strat(parseInt(T)) .
eq parsePreAttrs('frozen.@Attr@, N)
= if N == 0
then none
else frozen(from 1 to N list)
fi .
eq parsePreAttrs('frozen`(_`)[T], N) = frozen(parseInt(T)) .
eq parsePreAttrs('memo.@Attr@, N) = memo .
eq parsePreAttrs('memoization.@Attr@, N) = memo .
eq parsePreAttrs('ctor.@Attr@, N) = ctor .
eq parsePreAttrs('constructor.@Attr@, N) = ctor .
eq parsePreAttrs('prec_['token[T]], N) = prec(parseNat(T)) .
eq parsePreAttrs('gather`(_`)['neTokenList[T]], N) = gather(downQidList(T)) .
eq parsePreAttrs('special`(_`)[T], N) = special(parsePreHookList(T)) .
eq parsePreAttrs('format`(_`)['neTokenList[T]], N) = format(downQidList(T)) .
eq parsePreAttrs('iter.@Attr@, N) = iter .
eq parsePreAttrs('ditto.@Attr@, N) = ditto .
eq parsePreAttrs('config.@Attr@, N) = config .
eq parsePreAttrs('object.@Attr@, N) = object .
eq parsePreAttrs('msg.@Attr@, N) = msg .
eq parsePreAttrs('message.@Attr@, N) = msg .
eq parsePreAttrs('metadata_['token[T]], N) = metadata(downString(downQid(T))) .
eq parsePreAttrs('nonexec.@Attr@, N) = nonexec .
eq parsePreAttrs('variant.@Attr@, N) = variant .
eq parsePreHookList('__[T, TL]) = parsePreHookList(T) parsePreHookList(TL) .
eq parsePreHookList('id-hook_['token[T]]) = id-hook(downQid(T), nil) .
eq parsePreHookList('id-hook_`(_`)['token[T], 'neTokenList[T']])
= id-hook(downQid(T), downQidList(T')) .
eq parsePreHookList(
'op-hook_`(_:_->_`)[
'token[T], 'token[T'], 'neTokenList[T''], 'token[T3]])
= op-hook(downQid(T), downQid(T'), downTypes(T''), downQid(T3)) .
eq parsePreHookList('op-hook_`(_:`->_`)['token[T], 'token[T'], 'token[T'']])
= op-hook(downQid(T), downQid(T'), nil, downQid(T'')) .
eq parsePreHookList(
'op-hook_`(_:_~>_`)[
'token[T], 'token[T'], 'neTokenList[T''], 'token[T3]])
= op-hook(downQid(T), downQid(T'), downTypes(T''), downQid(T3)) .
eq parsePreHookList('op-hook_`(_:`~>_`)['token[T], 'token[T'], 'token[T'']])
= op-hook(downQid(T), downQid(T'), nil, downQid(T'')) .
eq parsePreHookList('term-hook_`(_`)['token[T], T'])
= term-hook(downQid(T), T') .
eq parseAttrDeclList('_`,_[T, T'])
= (parseAttrDeclList(T), parseAttrDeclList(T')) .
eq parseAttrDeclList('_:_['token[T], T'])
= (attr downQid(T) : parseType(T')) .
*** Given a term representing a declaration or a predeclaration, the function
*** \texttt{parseDecl} must generate and update both the unit and the preunit
*** that it takes as arguments. Note that in the case of rules, for example,
*** only a prerule is generated.
*** Since the preunit and the unit may be modified, they have to be returned as
*** a pair, which will be used to extract the corresponding arguments for the
*** following calls. Note that the \texttt{parseDecl} functions are in fact
*** partial functions. Each parsing function assumes that it is possible to
*** parse the given term.
sort ParseDeclResult .
op <_;_;_> : Module Module OpDeclSet -> ParseDeclResult .
op preModule : ParseDeclResult -> Module .
op unit : ParseDeclResult -> Module .
op vars : ParseDeclResult -> OpDeclSet .
eq preModule(< PU ; U ; VDS >) = PU .
eq preModule(< unitError(QIL) ; V:[Module] ; V:[OpDeclSet] >) = unitError(QIL) .
eq preModule(< V:[Module] ; unitError(QIL) ; V:[OpDeclSet] >) = unitError(QIL) .
eq preModule(< V:[Module] ; V':[Module] ; opDeclError(QIL) >) = unitError(QIL) .
eq unit(< PU ; U ; VDS >) = U .
eq unit(< unitError(QIL) ; V':[Module] ; V:[OpDeclSet] >) = unitError(QIL) .
eq unit(< V:[Module] ; unitError(QIL) ; V:[OpDeclSet] >) = unitError(QIL) .
eq unit(< V:[Module] ; V':[Module] ; opDeclError(QIL) >) = unitError(QIL) .
eq vars(< PU ; U ; VDS >) = VDS .
eq vars(< unitError(QIL) ; V:[Module] ; V:[OpDeclSet] >) = opDeclError(QIL) .
eq vars(< V:[Module] ; unitError(QIL) ; V:[OpDeclSet] >) = opDeclError(QIL) .
eq vars(< V:[Module] ; V':[Module] ; opDeclError(QIL) >) = opDeclError(QIL) .
op parseDecl : Term Module Module OpDeclSet -> ParseDeclResult .
*** changed 03/27/02
*** In the case of importation declarations, since internally only the
*** \texttt{including} mode is handled, all importations are generated in
*** this mode, independently of the keyword used in the input.
eq parseDecl('inc_.[T], PU, U, VDS)
= parseDecl('including_.[T], PU, U, VDS) .
eq parseDecl('ex_.[T], PU, U, VDS)
= parseDecl('extending_.[T], PU, U, VDS) .
eq parseDecl('pr_.[T], PU, U, VDS)
= parseDecl('protecting_.[T], PU, U, VDS) .
eq parseDecl('including_.[T], PU, U, VDS)
= < addImports((including parseModExp(T) .), PU) ; U ; VDS > .
eq parseDecl('extending_.[T], PU, U, VDS)
= < addImports((extending parseModExp(T) .), PU) ; U ; VDS > .
eq parseDecl('protecting_.[T], PU, U, VDS)
= < addImports((protecting parseModExp(T) .), PU) ; U ; VDS > .
eq parseDecl('sort_.[T], PU, U, VDS) = parseDecl('sorts_.[T], PU, U, VDS) .
eq parseDecl('sorts_.[T], PU, U, VDS)
= < addSorts(parseSortSet(T), PU) ; addSorts(parseSortSet(T), U) ; VDS > .
eq parseDecl('subsort_.[T], PU, U, VDS)
= parseDecl('subsorts_.[T], PU, U, VDS) .
eq parseDecl('subsorts_.[T], PU, U, VDS)
= < addSubsorts(unfoldSubsortRel(parseSubsortRel(T)), PU) ;
addSubsorts(unfoldSubsortRel(parseSubsortRel(T)), U) ; VDS > .
*** As pointed out in Section~\ref{SyntacticalRequirementsAndCaveats}, the
*** name of operators in operator declaration has to be given as a single
*** token identifier (see Section~\ref{order-sorted}). We assume that when
*** declaring a multitoken operator, its name is given as a single quoted
*** identifier in which each token is preceded by a backquote. Thus, the name
*** of an operator \verb~_(_)~, for example, is given as \verb~_`(_`)~.
eq parseDecl('op_:`->_.['token[T], T'], PU, U, VDS)
= < addOps((op downQid(T) : nil -> parseType(T') [none] .), PU) ;
addOps((op downQid(T) : nil -> parseType(T') [none] .), U) ;
VDS > .
eq parseDecl('op_:`->_`[_`].['token[T], T', T''], PU, U, VDS)
= < addOps(
(op downQid(T) : nil -> parseType(T') [parsePreAttrs(T'', 0)] .),
PU) ;
addOps(
(op downQid(T) : nil -> parseType(T') [parseAttrs(T'')] .),
U) ;
VDS > .
eq parseDecl('op_:_->_.['token[T], T', T''], PU, U, VDS)
= < addOps(
(op downQid(T) : parseTypeList(T') -> parseType(T'') [none] .),
PU) ;
addOps(
(op downQid(T) : parseTypeList(T') -> parseType(T'') [none] .),
U) ;
VDS > .
eq parseDecl('op_:_->_`[_`].['token[T], T', T'', T3], PU, U, VDS)
= < addOps(
(op downQid(T) : parseTypeList(T') -> parseType(T'')
[parsePreAttrs(T3, size(parseTypeList(T')))] .), PU) ;
addOps(
(op downQid(T) : parseTypeList(T') -> parseType(T'')
[parseAttrs(T3)] .), U) ;
VDS > .
ceq parseDecl('op_:`->_.[F[TL], T], PU, U, VDS)
= < PU ; U ; VDS >
if F =/= 'token .
ceq parseDecl('op_:`->_`[_`].[F[TL], T, T'], PU, U, VDS)
= < PU ; U ; VDS >
if F =/= 'token .
ceq parseDecl('op_:_->_.[F[TL], T, T'], PU, U, VDS)
= < PU ; U ; VDS >
if F =/= 'token .
ceq parseDecl('op_:_->_`[_`].[F[TL], T, T', T''], PU, U, VDS)
= < PU ; U ; VDS >
if F =/= 'token .
eq parseDecl('ops_:`->_.['neTokenList[T], T'], PU, U, VDS)
= < addOps(
unfoldOpDecl(downTypes(T), nil, parseType(T'), none), PU) ;
addOps(
unfoldOpDecl(downTypes(T), nil, parseType(T'), none), U) ;
VDS > .
eq parseDecl('ops_:`->_`[_`].['neTokenList[T], T', T''], PU, U, VDS)
= < addOps(
unfoldOpDecl(downTypes(T), nil, parseType(T'),
parsePreAttrs(T'', 0)),
PU) ;
addOps(
unfoldOpDecl(downTypes(T), nil, parseType(T'),
parseAttrs(T'')),
U) ;
VDS > .
eq parseDecl('ops_:_->_.['neTokenList[T], T', T''], PU, U, VDS)
= < addOps(
unfoldOpDecl(downTypes(T), parseTypeList(T'),
parseType(T''), none),
PU) ;
addOps(
unfoldOpDecl(downTypes(T), parseTypeList(T'),
parseType(T''), none),
U) ;
VDS > .
eq parseDecl('ops_:_->_`[_`].['neTokenList[T], T', T'', T3], PU, U, VDS)
= < addOps(
unfoldOpDecl(downTypes(T), parseTypeList(T'), parseType(T''),
parsePreAttrs(T3, size(parseTypeList(T')))), PU) ;
addOps(
unfoldOpDecl(downTypes(T),
parseTypeList(T'), parseType(T''), parseAttrs(T3)), U) ;
VDS > .
eq parseDecl('op_:`~>_.['token[T], T'], PU, U, VDS)
= < addOps((op downQid(T) : nil -> kind(parseType(T')) [none] .), PU) ;
addOps((op downQid(T) : nil -> kind(parseType(T')) [none] .), U) ;
VDS > .
eq parseDecl('op_:`~>_`[_`].['token[T], T', T''], PU, U, VDS)
= < addOps((op downQid(T) : nil -> kind(parseType(T'))
[parsePreAttrs(T'', 0)] .), PU) ;
addOps((op downQid(T) : nil -> kind(parseType(T'))
[parseAttrs(T'')] .), U) ;
VDS > .
eq parseDecl('op_:_~>_.['token[T], T', T''], PU, U, VDS)
= < addOps((op downQid(T) : kind(parseTypeList(T')) -> kind(parseType(T''))
[none] .), PU) ;
addOps((op downQid(T) : kind(parseTypeList(T')) -> kind(parseType(T''))
[none] .), U) ;
VDS > .
eq parseDecl('op_:_~>_`[_`].['token[T], T', T'', T3], PU, U, VDS)
= < addOps((op downQid(T) : kind(parseTypeList(T')) -> kind(parseType(T''))
[parsePreAttrs(T3, size(parseTypeList(T')))] .), PU) ;
addOps((op downQid(T) : kind(parseTypeList(T')) -> kind(parseType(T''))
[parseAttrs(T3)] .), U) ;
VDS > .
ceq parseDecl('op_:`~>_.[F[TL], T], PU, U, VDS)
= < PU ; U ; VDS >
if F =/= 'token .
ceq parseDecl('op_:`~>_`[_`].[F[TL], T, T'], PU, U, VDS)
= < PU ; U ; VDS >
if F =/= 'token .
ceq parseDecl('op_:_~>_.[F[TL], T, T'], PU, U, VDS)
= < PU ; U ; VDS >
if F =/= 'token .
ceq parseDecl('op_:_~>_`[_`].[F[TL], T, T', T''], PU, U, VDS)
= < PU ; U ; VDS >
if F =/= 'token .
eq parseDecl('ops_:`~>_.['neTokenList[T], T'], PU, U, VDS)
= < addOps(
unfoldOpDecl(downTypes(T), nil, kind(parseType(T')), none),
PU) ;
addOps(
unfoldOpDecl(downTypes(T), nil, kind(parseType(T')), none),
U) ;
VDS > .
eq parseDecl('ops_:`~>_`[_`].['neTokenList[T], T', T''], PU, U, VDS)
= < addOps(
unfoldOpDecl(downTypes(T), nil, kind(parseType(T')),
parsePreAttrs(T'', 0)),
PU) ;
addOps(
unfoldOpDecl(downTypes(T), nil, kind(parseType(T')),
parseAttrs(T'')), U) ;
VDS > .
eq parseDecl('ops_:_~>_.['neTokenList[T], T', T''], PU, U, VDS)
= < addOps(
unfoldOpDecl(downTypes(T), parseTypeList(T'),
kind(parseType(T'')), none),
PU) ;
addOps(
unfoldOpDecl(downTypes(T), parseTypeList(T'),
kind(parseType(T'')), none),
U) ;
VDS > .
eq parseDecl('ops_:_~>_`[_`].['neTokenList[T], T', T'', T3], PU,
U, VDS)
= < addOps(
unfoldOpDecl(downTypes(T), parseTypeList(T'), parseType(T''),
parsePreAttrs(T3, size(parseTypeList(T')))),
PU) ;
addOps(
unfoldOpDecl(downTypes(T),
parseTypeList(T'), parseType(T''), parseAttrs(T3)), U) ;
VDS > .
eq parseDecl('var_:_.['neTokenList[T], T'], PU, U, VDS)
= parseDecl('vars_:_.['neTokenList[T], T'], PU, U, VDS) .
eq parseDecl('vars_:_.['neTokenList[T], T'], PU, U, VDS)
= < PU ; U ; VDS parseVars(downQidList(T), parseType(T')) > .
eq parseDecl('mb_:_.['bubble['__[''`[.Qid, L, ''`].Qid]], T], PU, U, VDS)
= < addMbs((mb getTerm(breakMb(T, VDS)) : getSort(breakMb(T, VDS))
[label(downQid(L)) getAttrSet(breakMb(T, VDS))] .), PU) ; U ; VDS > .
eq parseDecl('mb_:_.[T, T'], PU, U, VDS)
= < addMbs((mb T : getSort(breakMb(T', VDS)) [getAttrSet(breakMb(T', VDS))] .), PU) ; U ; VDS >
[owise] .
eq parseDecl('cmb_:_if_.[T, T', T''], PU, U, VDS)
= < addMbs(
(cmb T : getSort(breakMb(T', VDS))
if term(pullStmtAttrOut(T'', VDS)) = 'true.Bool
[attrSet(pullStmtAttrOut(T'', VDS))] .), PU) ; U ; VDS > .
eq parseDecl('cmb`[_`]:_:_if_.['token[T'''], T, T', T''], PU, U, VDS)
= < addMbs(
(cmb T : getSort(breakMb(T', VDS))
if term(pullStmtAttrOut(T'', VDS)) = 'true.Bool
[attrSet(pullStmtAttrOut(T'', VDS)) label(downQid(T'''))] .), PU) ; U ; VDS > .
sort Tuple{Default{Term},Sort,AttrSet} .
op breakMb : Term OpDeclSet -> [Tuple{Default{Term},Sort,AttrSet}] .
op breakMbAux : Term TermList AttrSet OpDeclSet -> [Tuple{Default{Term},Sort,AttrSet}] .
op {_,_,_} : Default{Term} Sort AttrSet -> Tuple{Default{Term},Sort,AttrSet} .
op getTerm : Tuple{Default{Term},Sort,AttrSet} -> Default{Term} .
op getSort : Tuple{Default{Term},Sort,AttrSet} -> Sort .
op getAttrSet : Tuple{Default{Term},Sort,AttrSet} -> AttrSet .
eq getTerm({DT, S, AtS}) = DT .
eq getTerm({DT, qidError(QIL), AtS}) = DT .
eq getSort({DT, S, AtS}) = S .
eq getSort({DT, qidError(QIL), AtS}) = qidError(QIL) .
eq getAttrSet({DT, S, AtS}) = AtS .
eq getAttrSet({DT, qidError(QIL), AtS}) = AtS .
---- eq breakMb('bubble[QI]) = {maybe, downQidList(QI), none} .
---- eq breakMb('bubble['__[QI, QI']])
---- = {maybe, getType(parseTypeMb('bubble['__[QI, QI']])), none} .
---- eq breakMb('bubble['__[QI, QI', QI'']])
---- = {getTerm(parseTypeMb('bubble['__[QI, QI', QI'']])),
---- getType(parseTypeMb('bubble['__[QI, QI', QI'']])),
---- none} .
eq breakMb('bubble['__[QI, QI', TL, QI'']], VDS)
= if QI'' =/= ''`].Qid
then {getTerm(parseTypeMb('bubble['__[QI, QI', TL, QI'']])),
getType(parseTypeMb('bubble['__[QI, QI', TL, QI'']])),
none}
else breakMbAux('bubble['__[QI, QI', TL, QI'']], (QI, QI', TL), none, VDS)
fi .
eq breakMb('sortToken[T], VDS) = {null, parseType('sortToken[T]), none} [owise] .
eq breakMb('_`{_`}[T, T'], VDS) = {null, parseType('_`{_`}[T, T']), none} [owise] .
eq breakMb(T, VDS) = {null, getType(parseTypeMb(T)), none} [owise] .
eq breakMbAux(T, (TL, ''`[.Qid), AtS, VDS)
= if AtS =/= none
then {null, getType(parseTypeMb('bubble[TL])), AtS}
else {null, T, none}
fi .
eq breakMbAux(T, (TL, QI, QI', ''`[.Qid), AtS, VDS)
= if AtS =/= none
then {getTerm(parseTypeMb('bubble['__[TL, QI, QI']])),
getType(parseTypeMb('bubble['__[TL, QI, QI']])), AtS}
else {getTerm(parseTypeMb(T)), getType(parseTypeMb(T)), none}
fi .
eq breakMbAux(T, (TL, QI, ''nonexec.Qid), AtS, VDS)
= breakMbAux(T, (TL, QI), AtS nonexec, VDS) .
eq breakMbAux(T, (TL, QI, ''variant.Qid), AtS, VDS)
= breakMbAux(T, (TL, QI), AtS variant, VDS) .
eq breakMbAux(T, (TL, QI, ''owise.Qid), AtS, VDS)
= breakMbAux(T, (TL, QI), AtS owise, VDS) .
eq breakMbAux(T, (TL, QI, ''otherwise.Qid), AtS, VDS)
= breakMbAux(T, (TL, QI), AtS owise, VDS) .
eq breakMbAux(T, (TL, QI, ''label.Qid, QI'), AtS, VDS)
= if downQid(QI') :: Qid
then breakMbAux(T, (TL, QI), AtS label(downQid(QI')), VDS)
else {null, T, none}
fi .
eq breakMbAux(T, (TL, QI, ''metadata.Qid, QI'), AtS, VDS)
= if downString(downQid(QI')) :: String
then breakMbAux(T, (TL, QI), AtS metadata(downString(downQid(QI'))), VDS)
else {null, T, none}
fi .
ceq breakMbAux(T, (TL, QI, ''`[.Qid, TL', ''print.Qid, TL''), AtS, VDS)
= breakMbAux(T, (TL, QI, ''`[.Qid, TL'), AtS print(printArg(TL'', VDS)), VDS)
if printArg(TL'', VDS) : QidList .
eq breakMbAux(T, TL, AtS, VDS) = {null, T, none} [owise] .
op parseTypeMb : Term ~> ResultPair .
---- eq parseTypeMb('bubble[T])
---- = parseType(getTerm(metaParse(upModule('EXTENDED-SORTS, false), downQidList(T), '@Sort@))) .
eq parseTypeMb('bubble[TL])
= if metaParse(
addOps(
op '_:_ : '@Bubble@ '@Sort@ -> '@TermSort@ [none] .,
addSorts('@TermSort@, GRAMMAR)),
downQidList(TL), '@TermSort@) :: ResultPair
then breakTermSort(
getTerm(
metaParse(
addOps(
op '_:_ : '@Bubble@ '@Sort@ -> '@TermSort@ [none] .,
addSorts('@TermSort@, GRAMMAR)),
downQidList(TL), '@TermSort@)))
else {null, parseType(getTerm(metaParse(GRAMMAR, downQidList(TL), '@Sort@)))}
fi .
op breakTermSort : Term ~> ResultPair .
eq breakTermSort('_:_[T, T']) = {T, parseType(T')} .
eq parseDecl('eq_=_.[T, T'], PU, U, VDS)
= < addEqs((eq T = T' [none] .), PU) ; U ; VDS > .
eq parseDecl('ceq_=_if_.[T, T', T''], PU, U, VDS)
= < addEqs((ceq T = T' if T'' = 'true.Bool [none] .), PU) ; U ; VDS > .
eq parseDecl('cq_=_if_.[T, T', T''], PU, U, VDS)
= < addEqs((ceq T = T' if T'' = 'true.Bool [none] .), PU) ; U ; VDS > .
eq parseDecl('rl_=>_.[T, T'], PU, U, VDS)
= < addRls((rl T => T' [none] .), PU) ; U ; VDS > .
eq parseDecl('crl_=>_if_.[T, T', T''], PU, U, VDS)
= < addRls((crl T => T' if T'' = 'true.Bool [none] .), PU) ; U ; VDS > .
eq parseDecl('class_.[T], PU, U, VDS)
= < addClasses((class parseType(T) | none .), PU) ;
addClasses((class parseType(T) | none .), U) ; VDS > .
eq parseDecl('class_|_.[T, T'], PU, U, VDS)
= < addClasses((class parseType(T) | parseAttrDeclList(T') .), PU) ;
addClasses((class parseType(T) | parseAttrDeclList(T') .), U) ; VDS > .
eq parseDecl('subclass_.[T], PU, U, VDS)
= < addSubclasses(unfoldSubclassRel(parseSubsortRel(T)), PU) ;
addSubclasses(unfoldSubclassRel(parseSubsortRel(T)), U) ; VDS > .
eq parseDecl('subclasses_.[T], PU, U, VDS)
= < addSubclasses(unfoldSubclassRel(parseSubsortRel(T)), PU) ;
addSubclasses(unfoldSubclassRel(parseSubsortRel(T)), U) ; VDS > .
eq parseDecl('msg_:_->_.['token[T], T', T''], PU, U, VDS)
= < addMsgs((msg downQid(T) : parseTypeList(T') -> parseType(T'') .), PU)
;
addMsgs((msg downQid(T) : parseTypeList(T') -> parseType(T'') .), U)
;
VDS > .
eq parseDecl('msg_:`->_.['token[T], T'], PU, U, VDS)
= < addMsgs((msg downQid(T) : nil -> parseType(T') .), PU) ;
addMsgs((msg downQid(T) : nil -> parseType(T') .), U) ; VDS > .
eq parseDecl('msgs_:_->_.['neTokenList[T], T', T''], PU, U, VDS)
= < addMsgs(unfoldMultipleMsgDecl(downQidList(T), parseTypeList(T'), parseType(T'')), PU) ;
addMsgs(unfoldMultipleMsgDecl(downQidList(T), parseTypeList(T'), parseType(T'')), U) ;
VDS > .
eq parseDecl('msgs_:`->_.['neTokenList[T], T'], PU, U, VDS)
= < addMsgs(unfoldMultipleMsgDecl(downQidList(T), nil, parseType(T')), PU) ;
addMsgs(unfoldMultipleMsgDecl(downQidList(T), nil, parseType(T')), U) ; VDS > .
endfm
*******************************************************************************
***
*** 8.1.2 Parsing of View Declarations
***
*** A similar approach is followed for the parsing of declarations in views.
fmod VIEW-DECL-PARSING is
pr PRE-VIEW .
pr VIEW .
pr UNIT .
pr UNIT-DECL-PARSING .
vars T T' : Term .
var OPDS : OpDeclSet .
var MDS : MsgDeclSet .
var M : Module .
vars F F' : Qid .
vars S S' : Sort .
vars Ty Ty' : Type .
vars TyL TyL' : TypeList .
vars T'' T3 : Term .
var PV : PreView .
var OPD : OpDecl .
var OPDS' : OpDeclSet .
var AtS : AttrSet .
var MD : MsgDecl .
var MDS' : MsgDeclSet .
var VDS : OpDeclSet .
*** Operator and message name maps of the form \verb~F to F'~ are substituted
*** by an equivalent set of maps of the form \verb~F : TyL -> S to F'~. One
*** of these maps is added for each family of subsort-overloaded operators in
*** the source theory of the view.
*** The following functions \texttt{genOpMaps} and \texttt{genMsgMaps}
*** take, respectively, an operator and a message map of the form
*** \verb~F to F'~, a set of operator or message declarations, and a term of
*** sort \texttt{Module}, and return, respectively, a set of operator maps and
*** a set of message maps, with each of the members of those sTS having the
*** general form \verb~F : TyL -> S to F'~. One of these maps is generated
*** for each family of subsort-overloaded operators or messages with name
*** \texttt{F} in the module given as argument.
op genOpMaps : Renaming OpDeclSet Module -> RenamingSet .
op genMsgMaps : Renaming MsgDeclSet Module -> RenamingSet .
op genOpMapsAux : OpDeclSet Qid -> RenamingSet .
op genMsgMapsAux : MsgDeclSet Qid -> RenamingSet .
op getOpDeclSet : Qid Module -> OpDeclSet .
op getOpDeclSetAux : Qid OpDeclSet -> OpDeclSet .
*** getOpDeclSet(F, U) returns the set of declarations of operators with
*** name F in the unit U
op getMsgDeclSet : Qid Module -> MsgDeclSet .
op getMsgDeclSetAux : Qid MsgDeclSet -> MsgDeclSet .
*** getMsgDeclSet(F, U) returns the set of declarations of messages with
*** name F in the unit U
op gTSubsortOverloadedFamilies :
OpDeclSet OpDeclSet Module -> OpDeclSet .
op gTSubsortOverloadedFamilies :
MsgDeclSet MsgDeclSet Module -> MsgDeclSet .
*** gTSubsortOverloadedFamilies returns a declaration of operator or
*** message for each family of subsort-overloaded operators or messages.
op selectOpDeclSet : Qid OpDeclSet -> OpDeclSet .
op selectMsgDeclSet : Qid MsgDeclSet -> MsgDeclSet .
*** selectOpDeclSet and selectMsgDeclSet returns, respectively, the subset
*** of those declarations of ops and msgs which name coincides with the
*** qid given ar argument.
op opFamilyIn : OpDecl OpDeclSet Module -> Bool .
op msgFamilyIn : MsgDecl MsgDeclSet Module -> Bool .
*** Check whether the family of the subsort-overloaded operator given as
*** argument has already a representative in the set of declarations given.
eq genOpMaps((op F to F' [none]), OPDS, M)
= genOpMapsAux(
gTSubsortOverloadedFamilies(selectOpDeclSet(F, OPDS), none, M),
F') .
eq genMsgMaps((msg F to F'), MDS, M)
= genMsgMapsAux(
gTSubsortOverloadedFamilies(selectMsgDeclSet(F, MDS), none, M),
F') .
eq selectOpDeclSet(F, ((op F' : TyL -> Ty [AtS] .) OPDS))
= ((if F == F'
then (op F' : TyL -> Ty [AtS] .)
else none
fi)
selectOpDeclSet(F, OPDS)) .
eq selectOpDeclSet(F, none) = none .
eq selectMsgDeclSet(F, ((msg F' : TyL -> Ty .) MDS))
= ((if F == F'
then (msg F' : TyL -> Ty .)
else none
fi)
selectMsgDeclSet(F, MDS)) .
eq selectMsgDeclSet(F, none) = none .
eq genOpMapsAux(((op F : TyL -> Ty [AtS] .) OPDS), F')
= ((op F : TyL -> Ty to F' [none]), genOpMapsAux(OPDS, F')) .
eq genOpMapsAux(none, F') = none .
eq genMsgMapsAux(((msg F : TyL -> Ty .) MDS), F')
= ((msg F : TyL -> Ty to F'), genMsgMapsAux(MDS, F')) .
eq genMsgMapsAux(none, F') = none .
eq gTSubsortOverloadedFamilies((OPD OPDS), OPDS', M)
= if opFamilyIn(OPD, OPDS', M)
then gTSubsortOverloadedFamilies(OPDS, OPDS', M)
else gTSubsortOverloadedFamilies(OPDS, (OPD OPDS'), M)
fi .
eq gTSubsortOverloadedFamilies(none, OPDS, M) = OPDS .
eq gTSubsortOverloadedFamilies((MD MDS), MDS', M)
= if msgFamilyIn(MD, MDS', M)
then gTSubsortOverloadedFamilies(MDS, MDS', M)
else gTSubsortOverloadedFamilies(MDS, (MD MDS'), M)
fi .
eq gTSubsortOverloadedFamilies(none, MDS, M) = MDS .
eq opFamilyIn(
(op F : TyL -> Ty [AtS] .), ((op F' : TyL' -> Ty' [AtS] .) OPDS), M)
= ((F == F') and-then sameKind(M, TyL, TyL')) or-else
opFamilyIn((op F : TyL -> Ty [AtS] .), OPDS, M) .
eq opFamilyIn((op F : TyL -> Ty [AtS] .), none, M) = false .
eq msgFamilyIn((msg F : TyL -> Ty .), ((msg F' : TyL' -> Ty' .) MDS), M)
= ((F == F') and-then sameKind(M, TyL, TyL'))
or-else
msgFamilyIn((msg F : TyL -> Ty .), MDS, M) .
eq msgFamilyIn((msg F : TyL -> Ty .), none, M) = false .
*** In the case of views, the \texttt{parseDecl} function takes the term
*** representing the corresponding declaration and a preview in which the
*** declarations are introduced. Note that in the case of views, the approach
*** followed in the evaluation is somewhat different. The only predeclarations
*** in a preview correspond to the term premaps of sort \texttt{PreTermMap},
*** for which, in addition to solving the bubbles in them, we have to convert
*** them into term maps of sort \texttt{TermMap} associating to them the set
*** of declarations of variables in the view which are used in them (see
*** Section~\ref{view-processing}).
*** The function \texttt{parseDecl} for declarations in views takes then the
*** term representing such declaration and a preview in which the result of
*** adding the declaration will be returned. To be able to generate the sTS
*** of equivalent operator and message maps as indicated above, the function
*** takes also as parameters the sTS of declarations of operators and messages
*** in the theory part of the source theory of the view in question, and the
*** signature of such theory to make the necessary sort comparisons.
op parseDecl : Term PreView OpDeclSet MsgDeclSet Module -> PreView .
eq parseDecl('sort_to_.[T, T'], PV, OPDS, MDS, M)
= addMaps((sort parseType(T) to parseType(T')), PV) .
eq parseDecl('class_to_.[T, T'], PV, OPDS, MDS, M)
= addMaps((class parseType(T) to parseType(T')), PV) .
eq parseDecl('vars_:_.['neTokenList[T], T'], PV, OPDS, MDS, M)
= addVars(parseVars(downQidList(T), parseType(T')), PV).
eq parseDecl('var_:_.['neTokenList[T], T'], PV, OPDS, MDS, M)
= addVars(parseVars(downQidList(T), parseType(T')), PV).
eq parseDecl('op_to`term_.[T, T'], PV, OPDS, MDS, M)
= addMaps(preTermMap(T, T'), PV) .
eq parseDecl('op_to_.['token[T], 'token[T']], PV, OPDS, MDS, M)
= addMaps(genOpMaps((op downQid(T) to downQid(T') [none]), OPDS, M), PV) .
eq parseDecl('op_:_->_to_.['token[T], T', T'', 'token[T3]], PV, OPDS, MDS, M)
= addMaps(
op downQid(T) : parseTypeList(T') -> parseType(T'') to downQid(T3)
[none],
PV) .
eq parseDecl('op_:`->_to_.['token[T], T', 'token[T'']], PV, OPDS, MDS, M)
= addMaps((op downQid(T) : nil -> parseType(T') to downQid(T'') [none]),
PV) .
eq parseDecl('msg_to_.['token[T], 'token[T']], PV, OPDS, MDS, M)
= addMaps(genMsgMaps((msg downQid(T) to downQid(T')), MDS, M), PV) .
eq parseDecl('msg_:_->_to_.['token[T], T', T'', 'token[T3]],
PV, OPDS, MDS, M)
= addMaps(
msg downQid(T) : parseTypeList(T') -> parseType(T'') to downQid(T3),
PV) .
eq parseDecl('msg_:`->_to_.['token[T], T', 'token[T'']], PV, OPDS, MDS, M)
= addMaps((msg downQid(T) : nil -> parseType(T') to downQid(T'')), PV) .
eq parseDecl('label_to_.['token[T], 'token[T']], PV, OPDS, MDS, M)
= addMaps((label downQid(T) to downQid(T')), PV) .
eq parseDecl('attr_._to_.[T', 'token[T], 'token[T'']], PV, OPDS, MDS, M)
= addMaps((attr downQid(T) . parseType(T') to downQid(T'')), PV) .
eq parseDecl(T, PV, OPDS, MDS, M) = PV [owise] .
endfm
*******************************************************************************
***
*** 8.2 Meta Pretty Printing
***
*** To be able to show to the user the modules, theories, views, and terms
*** resulting from the different commands, the built-in function
*** \texttt{meta-pretty-print} is extended in the modules in this section to
*** deal with units and views.
***
*** 8.2.1 Meta Pretty Printing of Declarations
***
*** The predefined function \texttt{meta-pretty-print} is extended in the
*** following module \texttt{DECL-META-PRETTY-PRINT} to handle any declaration
*** that can appear in a unit. Note that the following
*** \texttt{meta-pretty-print} functions, as the built-in one, return a list
*** terms---such as equations, rules,* operator declarations with an identity
*** attribute, etc.---they have been defined with a term of operator
*** declarations with an identity attribute, etc.---they have been defined
*** with a term of sort \texttt{Module} as argument. In the other cases the
*** module is not necessary.
fmod DECL-META-PRETTY-PRINT is
pr EXT-DECL .
pr O-O-DECL .
pr UNIT .
pr CONVERSION .
pr INT-LIST .
pr VIEW-EXPR-TO-QID .
op eMetaPrettyPrint : Sort -> QidList .
op eMetaPrettyPrint : SortSet -> QidList .
op eMetaPrettyPrint : TypeList -> QidList .
op eMetaPrettyPrint : SubsortDeclSet -> QidList .
op eMetaPrettyPrint : ClassDeclSet -> QidList .
op eMetaPrettyPrint : SubclassDeclSet -> QidList .
op eMetaPrettyPrint : Module OpDeclSet -> QidList .
op eMetaPrettyPrintVars : OpDeclSet -> QidList .
op eMetaPrettyPrint : MsgDeclSet -> QidList .
op eMetaPrettyPrint : Module MembAxSet -> QidList .
op eMetaPrettyPrint : Module EquationSet -> QidList .
op eMetaPrettyPrint : Module RuleSet -> QidList .
op eMetaPrettyPrint : Module Condition -> QidList .
op eMetaPrettyPrint : Module Term -> QidList .
---- error handling
---(
eq metaPrettyPrint(M, T, POS:PrintOptionSet)
= 'Module getName(M) 'contains 'errors. .
---)
eq eMetaPrettyPrint(U, T) = metaPrettyPrint(U, T) . ----, mixfix flat format) .
eq eMetaPrettyPrint(U, qidError(QIL)) = QIL .
eq eMetaPrettyPrint(qidError(QIL)) = QIL .
op eMetaPrettyPrint : Module AttrSet -> QidList .
op eMetaPrettyPrint : IntList -> QidList .
op eMetaPrettyPrint : AttrDeclSet -> QidList .
op eMetaPrettyPrint : Module HookList -> QidList .
vars QI QI' QI'' F V L : Qid .
var QIL : QidList .
var St : String .
var M : Module .
var U : Module .
vars VE VE' : ViewExp .
vars SS : SortSet .
vars S S' : Sort .
var TyL : TypeList .
var Ty : Type .
var SSDS : SubsortDeclSet .
var OPDS : OpDeclSet .
var AtS : AttrSet .
var MAS : MembAxSet .
var EqS : EquationSet .
var RlS : RuleSet .
var Hk : Hook .
var HkL : HookList .
var I : Int .
var NL : IntList .
vars T T' T'' T3 : Term .
var CDS : ClassDeclSet .
var SCDS : SubclassDeclSet .
var MDS : MsgDeclSet .
var ADS : AttrDeclSet .
var Cond : Condition .
var K : Kind .
--- eq eMetaPrettyPrint(Ty) = Ty .
eq eMetaPrettyPrint(S)
= if getPars(S) == empty
then S
else getName(S) '`{ parameterList2QidList(getPars(S)) '`}
fi .
eq eMetaPrettyPrint(K) = '`[ eMetaPrettyPrint(getSort(K)) '`] .
eq eMetaPrettyPrint((S ; SS))
= (eMetaPrettyPrint(S) eMetaPrettyPrint(SS))
[owise] .
eq eMetaPrettyPrint((none).SortSet) = nil .
eq eMetaPrettyPrint(Ty TyL)
= eMetaPrettyPrint(Ty) eMetaPrettyPrint(TyL)
[owise] .
eq eMetaPrettyPrint((nil).TypeList) = nil .
eq eMetaPrettyPrint(((subsort S < S' .) SSDS))
= ('\s '\s '\b
'subsort '\o eMetaPrettyPrint(S) '\b
'< '\o eMetaPrettyPrint(S') '\b '. '\o '\n
eMetaPrettyPrint(SSDS)) .
eq eMetaPrettyPrint((none).SubsortDeclSet) = nil .
eq eMetaPrettyPrint(M, ((op F : TyL -> Ty [none] .) OPDS))
= ('\s '\s
'\b 'op '\o F '\b ': '\o eMetaPrettyPrint(TyL)
'\b '-> '\o eMetaPrettyPrint(Ty) '\b '. '\o '\n
eMetaPrettyPrint(M, OPDS)) .
eq eMetaPrettyPrint(M, ((op F : TyL -> Ty [AtS] .) OPDS))
= ('\s '\s
'\b 'op '\o F '\b ': '\o eMetaPrettyPrint(TyL)
'\b '-> '\o eMetaPrettyPrint(Ty) '\n
'\s '\s '\s '\s '\b '`[ '\o eMetaPrettyPrint(M, AtS) '\b '`] '\s '. '\o '\n
eMetaPrettyPrint(M, OPDS))
[owise] .
eq eMetaPrettyPrint(M, (none).OpDeclSet) = nil .
eq eMetaPrettyPrintVars((op F : nil -> Ty [none] .) OPDS)
= ('\s '\s '\b 'var '\o F '\b ': '\o eMetaPrettyPrint(Ty) '\b '. '\o '\n
eMetaPrettyPrintVars(OPDS)) .
eq eMetaPrettyPrintVars((none).OpDeclSet) = nil .
eq eMetaPrettyPrint(M, (mb T : S [none] .) MAS)
= ('\s '\s '\b 'mb '\o eMetaPrettyPrint(M, T) '\b ': '\o eMetaPrettyPrint(S) '\b '. '\o '\n
eMetaPrettyPrint(M, MAS)) .
eq eMetaPrettyPrint(M, (mb T : S [AtS] .) MAS)
= ('\s '\s '\b 'mb '\o eMetaPrettyPrint(M, T)
'\b ': '\o eMetaPrettyPrint(S)
'\s '\b '`[ '\o eMetaPrettyPrint(M, AtS) '\b '`] '\s '. '\o '\n
eMetaPrettyPrint(M, MAS))
[owise] .
eq eMetaPrettyPrint(M, (cmb T : S if Cond [none] .) MAS)
= ('\s '\s '\b 'cmb '\o eMetaPrettyPrint(M, T)
'\b ': '\o eMetaPrettyPrint(S) '\n
'\s '\s '\s '\s '\b 'if '\o eMetaPrettyPrint(M, Cond) '\b '. '\o '\n
eMetaPrettyPrint(M, MAS)) .
eq eMetaPrettyPrint(M, (cmb T : S if Cond [AtS] .) MAS)
= ('\s '\s '\b 'cmb '\o eMetaPrettyPrint(M, T)
'\b ': '\o eMetaPrettyPrint(S) '\n
'\s '\s '\s '\s '\b 'if '\o eMetaPrettyPrint(M, Cond)
'\s '\b '`[ '\o eMetaPrettyPrint(M, AtS) '\b '`] '\s '. '\o '\n
eMetaPrettyPrint(M, MAS))
[owise] .
eq eMetaPrettyPrint(M, (none).MembAxSet) = nil .
eq eMetaPrettyPrint(M, ((eq T = T' [none] .) EqS))
= ('\s '\s '\b 'eq '\s '\o eMetaPrettyPrint(M, T) '\n
'\s '\s '\s '\s '\b '= '\s '\o eMetaPrettyPrint(M, T') '\b '\s '. '\n
'\o
eMetaPrettyPrint(M, EqS)) .
eq eMetaPrettyPrint(M, ((eq T = T' [AtS] .) EqS))
= ('\s '\s '\b 'eq '\s '\o eMetaPrettyPrint(M, T) '\n
'\s '\s '\s '\s '\b '= '\s '\o eMetaPrettyPrint(M, T')
'\s '\b '`[ '\o eMetaPrettyPrint(M, AtS) '\b '`] '\s '. '\o '\n
eMetaPrettyPrint(M, EqS))
[owise] .
eq eMetaPrettyPrint(M, ((ceq T = T' if Cond [none] .) EqS))
= ('\s '\s '\b 'ceq '\s '\o eMetaPrettyPrint(M, T) '\n
'\s '\s '\s '\s '\b '= '\s '\o eMetaPrettyPrint(M, T') '\n
'\s '\s '\s '\s '\b 'if '\o '\s eMetaPrettyPrint(M, Cond) '\b '\s '. '\o '\n
eMetaPrettyPrint(M, EqS)) .
eq eMetaPrettyPrint(M, ((ceq T = T' if Cond [AtS] .) EqS))
= ('\s '\s '\b 'ceq '\s '\o eMetaPrettyPrint(M, T) '\n
'\s '\s '\s '\s '\b '= '\s '\o eMetaPrettyPrint(M, T') '\n
'\s '\s '\s '\s '\b 'if '\o '\s eMetaPrettyPrint(M, Cond)
'\s '\b '`[ '\o eMetaPrettyPrint(M, AtS) '\b '`] '\s '. '\o '\n
eMetaPrettyPrint(M, EqS))
[owise] .
eq eMetaPrettyPrint(M, (none).EquationSet) = nil .
eq eMetaPrettyPrint(M, ((rl T => T' [none] .) RlS))
= ('\s '\s '\b 'rl '\s '\o eMetaPrettyPrint(M, T) '\n
'\s '\s '\s '\s '\b '=> '\o '\s eMetaPrettyPrint(M, T') '\b '\s '. '\n '\o
eMetaPrettyPrint(M, RlS)) .
eq eMetaPrettyPrint(M, ((rl T => T' [AtS] .) RlS))
= ('\s '\s '\b 'rl '\s '\o eMetaPrettyPrint(M, T) '\n
'\s '\s '\s '\s '\b '=> '\o '\s eMetaPrettyPrint(M, T')
'\s '\b '`[ '\o eMetaPrettyPrint(M, AtS) '\b '`] '\s '. '\o '\n
eMetaPrettyPrint(M, RlS))
[owise] .
eq eMetaPrettyPrint(M, ((crl T => T' if Cond [none] .) RlS))
= ('\s '\s '\b 'crl '\s '\o eMetaPrettyPrint(M, T) '\n
'\s '\s '\s '\s '\b '=> '\o '\s eMetaPrettyPrint(M, T') '\n
'\s '\s '\s '\s '\b 'if '\o '\s eMetaPrettyPrint(M, Cond) '\b '\s '. '\o '\n
eMetaPrettyPrint(M, RlS)) .
eq eMetaPrettyPrint(M, ((crl T => T' if Cond [AtS] .) RlS))
= ('\s '\s '\b 'crl '\s '\o eMetaPrettyPrint(M, T) '\n
'\s '\s '\s '\s '\b '=> '\o '\s eMetaPrettyPrint(M, T') '\n
'\s '\s '\s '\s '\b 'if '\o '\s eMetaPrettyPrint(M, Cond)
'\s '\b '`[ '\o eMetaPrettyPrint(M, AtS) '\b '`] '\s '. '\o '\n
eMetaPrettyPrint(M, RlS))
[owise] .
eq eMetaPrettyPrint(M, (none).RuleSet) = nil .
eq eMetaPrettyPrint(M, T = T' /\ Cond)
= (eMetaPrettyPrint(M, T) '\b '= '\o eMetaPrettyPrint(M, T') '\b
'/\ '\o eMetaPrettyPrint(M, Cond))
[owise] .
eq eMetaPrettyPrint(M, T : S /\ Cond)
= (eMetaPrettyPrint(M, T) '\b ': '\o eMetaPrettyPrint(S) '\b
'/\ '\o eMetaPrettyPrint(M, Cond))
[owise] .
eq eMetaPrettyPrint(M, T := T' /\ Cond)
= (eMetaPrettyPrint(M, T) '\b ':= '\o eMetaPrettyPrint(M, T') '\b
'/\ '\o eMetaPrettyPrint(M, Cond))
[owise] .
eq eMetaPrettyPrint(M, T => T' /\ Cond)
= (eMetaPrettyPrint(M, T) '\b '=> '\o eMetaPrettyPrint(M, T') '\b
'/\ '\o eMetaPrettyPrint(M, Cond))
[owise] .
eq eMetaPrettyPrint(M, T = T')
= (eMetaPrettyPrint(M, T) '\b '= '\o eMetaPrettyPrint(M, T')) .
eq eMetaPrettyPrint(M, T : S)
= (eMetaPrettyPrint(M, T) '\b ': '\o eMetaPrettyPrint(S)) .
eq eMetaPrettyPrint(M, T := T')
= (eMetaPrettyPrint(M, T) '\b ':= '\o eMetaPrettyPrint(M, T')) .
eq eMetaPrettyPrint(M, T => T')
= (eMetaPrettyPrint(M, T) '\b '=> '\o eMetaPrettyPrint(M, T')) .
eq eMetaPrettyPrint(M, (nil).EqCondition) = nil .
eq eMetaPrettyPrint(M, (assoc AtS))
= ('\b 'assoc '\o eMetaPrettyPrint(M, AtS)) .
eq eMetaPrettyPrint(M, (comm AtS))
= ('\b 'comm '\o eMetaPrettyPrint(M, AtS)) .
eq eMetaPrettyPrint(M, (memo AtS))
= ('\b 'memo '\o eMetaPrettyPrint(M, AtS)) .
eq eMetaPrettyPrint(M, (idem AtS))
= ('\b 'idem '\o eMetaPrettyPrint(M, AtS)) .
eq eMetaPrettyPrint(M, (id(T) AtS))
= ('\b 'id: '\o eMetaPrettyPrint(M, T) eMetaPrettyPrint(M, AtS)) .
eq eMetaPrettyPrint(M, (right-id(T) AtS))
= ('\b 'right 'id: '\o eMetaPrettyPrint(M, T) eMetaPrettyPrint(M, AtS)) .
eq eMetaPrettyPrint(M, (left-id(T) AtS))
= ('\b 'left 'id: '\o eMetaPrettyPrint(M, T) eMetaPrettyPrint(M, AtS)) .
eq eMetaPrettyPrint(M, (poly(NL) AtS))
= ('\b 'poly '`( '\o eMetaPrettyPrint(NL) '\b '`)
'\o eMetaPrettyPrint(M, AtS)) .
eq eMetaPrettyPrint(M, (strat(NL) AtS))
= ('\b 'strat '`( '\o eMetaPrettyPrint(NL) '\b '`)
'\o eMetaPrettyPrint(M, AtS)) .
eq eMetaPrettyPrint(M, (memo AtS))
= ('\b 'memo '\o eMetaPrettyPrint(M, AtS)) .
eq eMetaPrettyPrint(M, (prec(I) AtS))
= ('\b 'prec '\o eMetaPrettyPrint(I) eMetaPrettyPrint(M, AtS)) .
eq eMetaPrettyPrint(M, (gather(QIL) AtS))
= ('\b 'gather '\o '`( QIL '`) eMetaPrettyPrint(M, AtS)) .
eq eMetaPrettyPrint(M, (format(QIL) AtS))
= ('\b 'format '\o '`( QIL '`) eMetaPrettyPrint(M, AtS)) .
eq eMetaPrettyPrint(M, (ctor AtS))
= ('\b 'ctor '\o eMetaPrettyPrint(M, AtS)) .
eq eMetaPrettyPrint(M, (frozen(NL) AtS))
= ('\b 'frozen '`( '\o eMetaPrettyPrint(NL) '\b '`)
'\o eMetaPrettyPrint(M, AtS)) .
eq eMetaPrettyPrint(M, (iter AtS))
= ('\b 'iter '\o eMetaPrettyPrint(M, AtS)) .
eq eMetaPrettyPrint(M, (special(HkL) AtS))
= ('\b 'special '`( '\o eMetaPrettyPrint(M, HkL) '\b '`)
'\o eMetaPrettyPrint(M, AtS)) .
eq eMetaPrettyPrint(M, (config AtS))
= ('\b 'config '\o eMetaPrettyPrint(M, AtS)) .
eq eMetaPrettyPrint(M, (object AtS))
= ('\b 'object '\o eMetaPrettyPrint(M, AtS)) .
eq eMetaPrettyPrint(M, (msg AtS))
= ('\b 'msg '\o eMetaPrettyPrint(M, AtS)) .
eq eMetaPrettyPrint(M, (label(QI) AtS))
= ('\b 'label '\o QI '\b '\o eMetaPrettyPrint(M, AtS)) .
eq eMetaPrettyPrint(M, (metadata(St) AtS))
= ('\b 'metadata '\o qid("\"" + St + "\"") '\b
'\o eMetaPrettyPrint(M, AtS)) .
eq eMetaPrettyPrint(M, (nonexec AtS))
= ('\b 'nonexec '\o eMetaPrettyPrint(M, AtS)) .
eq eMetaPrettyPrint(M, (variant AtS))
= ('\b 'variant '\o eMetaPrettyPrint(M, AtS)) .
eq eMetaPrettyPrint(M, (owise AtS))
= ('\b 'owise '\o eMetaPrettyPrint(M, AtS)) .
eq eMetaPrettyPrint(M, (print(QIL) AtS))
= ('\b 'print QIL '\o eMetaPrettyPrint(M, AtS)) .
eq eMetaPrettyPrint(M, (none).AttrSet) = nil .
ceq eMetaPrettyPrint(M, (Hk HkL))
= (eMetaPrettyPrint(M, Hk) eMetaPrettyPrint(M, HkL))
if HkL =/= nil .
eq eMetaPrettyPrint(M, id-hook(QI, nil)) = ('\b 'id-hook '\o QI) .
eq eMetaPrettyPrint(M, id-hook(QI, QIL))
= ('\b 'id-hook '\o QI '\b '`( '\o QIL '\b '`) '\o )
[owise] .
eq eMetaPrettyPrint(M, op-hook(QI, QI', nil, QI''))
= ('\b 'op-hook '\o QI '\b '`( '\o QI' ': '~> QI'' '\b '`) '\o) .
eq eMetaPrettyPrint(M, op-hook(QI, QI', QIL, QI''))
= ('\b 'op-hook '\o QI '\b '`( '\o QI' ': QIL '~> QI'' '\b '`) '\o)
[owise] .
eq eMetaPrettyPrint(M, term-hook(QI, T))
= ('\b 'term-hook '\o QI '\b '`( '\o eMetaPrettyPrint(M, T) '\b '`) '\o) .
eq eMetaPrettyPrint((I NL)) = (qid(string(I, 10)) eMetaPrettyPrint(NL)) .
eq eMetaPrettyPrint((nil).NatList) = nil .
eq eMetaPrettyPrint((class S | ADS .) CDS)
= ((if ADS == none
then ('\s '\s '\b 'class '\o eMetaPrettyPrint(S) '\b '. '\o '\n)
else ('\s '\s '\b 'class '\o eMetaPrettyPrint(S) '\b '| '\o eMetaPrettyPrint(ADS) '\b '. '\o '\n)
fi)
eMetaPrettyPrint(CDS)) .
eq eMetaPrettyPrint((none).ClassDeclSet) = nil .
eq eMetaPrettyPrint((subclass S < S' .) SCDS)
= ('\s '\s '\b 'subclass '\o eMetaPrettyPrint(S) '\b
'< '\o eMetaPrettyPrint(S') '\b '. '\o '\n
eMetaPrettyPrint(SCDS)) .
eq eMetaPrettyPrint((none).SubclassDeclSet) = nil .
eq eMetaPrettyPrint((msg F : TyL -> Ty .) MDS)
= ('\s '\s '\b 'msg '\o F '\b ': '\o eMetaPrettyPrint(TyL) '\b '-> '\o eMetaPrettyPrint(Ty) '\b '. '\o '\n
eMetaPrettyPrint(MDS)) .
eq eMetaPrettyPrint((none).MsgDeclSet) = nil .
eq eMetaPrettyPrint(((attr F : S), ADS))
= (F '\b ': '\o eMetaPrettyPrint(S) '\b '`, '\o '\s eMetaPrettyPrint(ADS))
[owise] .
eq eMetaPrettyPrint((attr F : S)) = (F '\b ': '\o eMetaPrettyPrint(S)) .
eq eMetaPrettyPrint((none).AttrDeclSet) = nil .
endfm
*******************************************************************************
***
*** 8.2.2 Meta Pretty Printing of Modules
***
*** In the following module, the \texttt{meta-pretty-print} function is
*** defined on sort \texttt{Module}.
fmod UNIT-META-PRETTY-PRINT is
pr UNIT .
pr RENAMING-EXPR-EVALUATION .
pr DECL-META-PRETTY-PRINT .
op eMetaPrettyPrint : Module Module -> QidList .
op eMetaPrettyPrint : Module Module -> QidList .
op eMetaPrettyPrint : Header -> QidList .
op eMetaPrettyPrint : ParameterDeclList -> QidList .
op eMetaPrettyPrint : ImportList -> QidList .
var M : Module .
vars QI F F' L L' : Qid .
var QIL : QidList .
var ME : ModuleExpression .
vars S S' : Sort .
var Ty : Type .
var TyL : TypeList .
var SS : SortSet .
var PD : ParameterDecl .
var PDL : ParameterDeclList .
vars IL IL' : ImportList .
var SSDS : SubsortDeclSet .
var OPDS : OpDeclSet .
var MAS : MembAxSet .
var EqS : EquationSet .
var RlS : RuleSet .
var CDS : ClassDeclSet .
var SCDS : SubclassDeclSet .
var MDS : MsgDeclSet .
var U : Module .
var AtS : AttrSet .
var MN : ModuleName .
ceq eMetaPrettyPrint(ME)
= if QI == '`) or QI == '`] or QI == '`}
then QIL QI '\s
else QIL QI
fi
if QIL QI := header2QidList(ME) .
eq eMetaPrettyPrint(W:[Module], unitError(QIL)) = QIL .
eq eMetaPrettyPrint(unitError(QIL), noModule) = QIL .
eq eMetaPrettyPrint(noModule, noModule) = nil .
eq eMetaPrettyPrint(M, mod ME is IL sorts SS . SSDS OPDS MAS EqS RlS endm)
= ('\b
'mod '\o eMetaPrettyPrint(ME) '\b 'is '\o '\n
eMetaPrettyPrint(IL)
(if SS == none
then nil
else ('\s '\s '\b 'sorts '\o eMetaPrettyPrint(SS) '\b '. '\o '\n)
fi)
eMetaPrettyPrint(SSDS)
eMetaPrettyPrint(M, OPDS)
eMetaPrettyPrint(M, MAS)
eMetaPrettyPrint(M, EqS)
eMetaPrettyPrint(M, RlS)
'\b 'endm '\o '\n) .
eq eMetaPrettyPrint(M, mod ME{PDL} is IL sorts SS . SSDS OPDS MAS EqS RlS endm)
= ('\b
'mod '\o eMetaPrettyPrint(ME) (if PDL == nil
then nil
else '`{ eMetaPrettyPrint(PDL) '`} '\s
fi) '\b 'is '\o '\n
eMetaPrettyPrint(IL)
(if SS == none
then nil
else ('\s '\s '\b 'sorts '\o eMetaPrettyPrint(SS) '\b '. '\o '\n)
fi)
eMetaPrettyPrint(SSDS)
eMetaPrettyPrint(M, OPDS)
eMetaPrettyPrint(M, MAS)
eMetaPrettyPrint(M, EqS)
eMetaPrettyPrint(M, RlS)
'\b 'endm '\o '\n) .
eq eMetaPrettyPrint(M, th MN is IL sorts SS . SSDS OPDS MAS EqS RlS endth)
= ('\b
'th '\o eMetaPrettyPrint(MN) '\b 'is '\o '\n
eMetaPrettyPrint(IL)
(if SS == none
then nil
else ('\s '\s '\b 'sorts '\o eMetaPrettyPrint(SS) '\b '. '\o '\n)
fi)
eMetaPrettyPrint(SSDS)
eMetaPrettyPrint(M, OPDS)
eMetaPrettyPrint(M, MAS)
eMetaPrettyPrint(M, EqS)
eMetaPrettyPrint(M, RlS)
'\b 'endth '\o '\n) .
eq eMetaPrettyPrint(M, fmod ME is IL sorts SS . SSDS OPDS MAS EqS endfm)
= ('\b
'fmod '\o eMetaPrettyPrint(ME) '\b 'is '\o '\n
eMetaPrettyPrint(IL)
(if SS == none
then nil
else ('\s '\s '\b 'sorts '\o eMetaPrettyPrint(SS) '\b '. '\o '\n)
fi)
eMetaPrettyPrint(SSDS)
eMetaPrettyPrint(M, OPDS)
eMetaPrettyPrint(M, MAS)
eMetaPrettyPrint(M, EqS)
'\b 'endfm '\o '\n) .
eq eMetaPrettyPrint(M, fmod ME{PDL} is IL sorts SS . SSDS OPDS MAS EqS endfm)
= ('\b
'fmod '\o eMetaPrettyPrint(ME) (if PDL == nil
then nil
else '`{ eMetaPrettyPrint(PDL) '`} '\s
fi) '\b 'is '\o '\n
eMetaPrettyPrint(IL)
(if SS == none
then nil
else ('\s '\s '\b 'sorts '\o eMetaPrettyPrint(SS) '\b '. '\o '\n)
fi)
eMetaPrettyPrint(SSDS)
eMetaPrettyPrint(M, OPDS)
eMetaPrettyPrint(M, MAS)
eMetaPrettyPrint(M, EqS)
'\b 'endfm '\o '\n) .
eq eMetaPrettyPrint(M, fth MN is IL sorts SS . SSDS OPDS MAS EqS endfth)
= ('\b
'fth '\o eMetaPrettyPrint(MN) '\b 'is '\o '\n
eMetaPrettyPrint(IL)
(if SS == none
then nil
else ('\s '\s '\b 'sorts '\o eMetaPrettyPrint(SS) '\b '. '\o '\n)
fi)
eMetaPrettyPrint(SSDS)
eMetaPrettyPrint(M, OPDS)
eMetaPrettyPrint(M, MAS)
eMetaPrettyPrint(M, EqS)
'\b 'endfth '\o '\n) .
eq eMetaPrettyPrint(M,
omod ME is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endom)
= ('\b
'omod '\o eMetaPrettyPrint(ME) '\b 'is '\o '\n
eMetaPrettyPrint(IL)
(if SS == none
then nil
else ('\s '\s '\b 'sorts '\o eMetaPrettyPrint(SS) '\b '. '\o '\n )
fi)
eMetaPrettyPrint(SSDS) eMetaPrettyPrint(CDS)
eMetaPrettyPrint(SCDS) eMetaPrettyPrint(M, OPDS)
eMetaPrettyPrint(MDS) eMetaPrettyPrint(M, MAS)
eMetaPrettyPrint(M, EqS) eMetaPrettyPrint(M, RlS)
'\b 'endom '\o '\n) .
eq eMetaPrettyPrint(M, omod ME{PDL} is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endom)
= ('\b
'omod '\o eMetaPrettyPrint(ME) (if PDL == nil
then nil
else ('`{ eMetaPrettyPrint(PDL) '`} '\s)
fi) '\b 'is '\o '\n
eMetaPrettyPrint(IL)
(if SS == none
then nil
else ('\s '\s '\b 'sorts '\o eMetaPrettyPrint(SS) '\b '. '\o '\n )
fi)
eMetaPrettyPrint(SSDS) eMetaPrettyPrint(CDS)
eMetaPrettyPrint(SCDS) eMetaPrettyPrint(M, OPDS)
eMetaPrettyPrint(MDS) eMetaPrettyPrint(M, MAS)
eMetaPrettyPrint(M, EqS) eMetaPrettyPrint(M, RlS)
'\b 'endom '\o '\n) .
eq eMetaPrettyPrint(M, oth MN is IL sorts SS . SSDS CDS SCDS OPDS MDS MAS EqS RlS endoth)
= ('\b
'oth '\o eMetaPrettyPrint(MN) '\b 'is '\o '\n
eMetaPrettyPrint(IL)
(if SS == none
then nil
else ('\s '\s '\b 'sorts '\o eMetaPrettyPrint(SS) '\b '. '\o '\n )
fi)
eMetaPrettyPrint(SSDS) eMetaPrettyPrint(CDS)
eMetaPrettyPrint(SCDS) eMetaPrettyPrint(M, OPDS)
eMetaPrettyPrint(MDS) eMetaPrettyPrint(M, MAS)
eMetaPrettyPrint(M, EqS) eMetaPrettyPrint(M, RlS) '\n '\b
'endoth '\o '\n) .
eq eMetaPrettyPrint((including ME .) IL)
= ('\s '\s '\b 'including '\o eMetaPrettyPrint(ME) '\b '. '\o '\n
eMetaPrettyPrint(IL)) .
eq eMetaPrettyPrint((extending ME .) IL)
= ('\s '\s '\b 'extending '\o eMetaPrettyPrint(ME) '\b '. '\o '\n
eMetaPrettyPrint(IL)) .
eq eMetaPrettyPrint((protecting ME .) IL)
= ('\s '\s '\b 'protecting '\o eMetaPrettyPrint(ME) '\b '. '\o '\n
eMetaPrettyPrint(IL)) .
eq eMetaPrettyPrint((protecting pd(QI :: ME) .) IL)
= eMetaPrettyPrint(IL) .
eq eMetaPrettyPrint((nil).ImportList) = nil .
eq eMetaPrettyPrint((QI :: ME, PDL))
= (QI ':: eMetaPrettyPrint(ME) '`, eMetaPrettyPrint(PDL))
[owise] .
eq eMetaPrettyPrint((QI :: ME)) = (QI ':: eMetaPrettyPrint(ME)) .
eq eMetaPrettyPrint((nil).ParameterDeclList) = (nil).QidList .
op eMetaPrettyPrint : ModuleExpression -> QidList .
eq eMetaPrettyPrint(QI + ME:ModuleExpression)
= QI '+ eMetaPrettyPrint(ME:ModuleExpression) .
eq eMetaPrettyPrint(QI * (RnS:RenamingSet))
= QI '* '\s '`( renamingSet2QidList(RnS:RenamingSet) '`) .
eq eMetaPrettyPrint(pd(PD)) = eMetaPrettyPrint(PD) .
op renamingSet2QidList : RenamingSet -> QidList .
eq renamingSet2QidList(((op F to F' [AtS]), RS:RenamingSet))
= if AtS == none
then ('op F 'to F' '`, '\s renamingSet2QidList(RS:RenamingSet))
else ('op F 'to F' '\s '`[ attrSet2QidList(AtS) '`] '`, '\s
renamingSet2QidList(RS:RenamingSet))
fi
[owise] .
eq renamingSet2QidList((op F to F' [AtS]))
= if AtS == none
then ('op F 'to F')
else ('op F 'to F' '\s '`[ attrSet2QidList(AtS) '`])
fi .
eq renamingSet2QidList(((op F : TyL -> Ty to F' [AtS]), RS:RenamingSet))
= if AtS == none
then ('op F ': typeList2QidList(TyL) '-> Ty 'to F' '`,
'\s renamingSet2QidList(RS:RenamingSet))
else ('op F ': typeList2QidList(TyL) '-> Ty 'to F'
'`[ attrSet2QidList(AtS) '`] '`,
'\s renamingSet2QidList(RS:RenamingSet))
fi
[owise] .
eq renamingSet2QidList((op F : TyL -> Ty to F' [AtS]))
= if AtS == none
then ('op F ': typeList2QidList(TyL) '-> Ty 'to F')
else ('op F ': typeList2QidList(TyL) '-> Ty 'to F'
'`[ attrSet2QidList(AtS) '`])
fi .
eq renamingSet2QidList(((sort S to S'), RS:RenamingSet))
= ('sort S 'to S' '`, '\s
renamingSet2QidList(RS:RenamingSet))
[owise] .
eq renamingSet2QidList((sort S to S')) = ('sort S 'to S') .
eq renamingSet2QidList(((label L to L'), RS:RenamingSet))
= ('label L 'to L' '`, '\s renamingSet2QidList(RS:RenamingSet))
[owise] .
eq renamingSet2QidList((label L to L')) = ('label L 'to L') .
endfm
*******************************************************************************
*** The function \texttt{meta-pretty-print} on units is defined recursively,
*** calling the \texttt{meta-pretty-print} functions for the different
*** declarations in the unit defined in module \texttt{DECL-META-PRETTY-PRINT}.
***
*** 8.2.3 Meta Pretty Printing of Maps and Views
***
*** We define in the following module the function \texttt{meta-pretty-print}
*** on maps.
fmod MAP-SET-META-PRETTY-PRINT is
pr DECL-META-PRETTY-PRINT .
pr FMAP .
pr UNIT .
op eMetaPrettyPrint : RenamingSet -> QidList .
var MAP : Renaming .
var MAPS : RenamingSet .
vars QI QI' F F' L L' : Qid .
var AtS : AttrSet .
vars S S' : Sort .
var Ty : Type .
var TyL : TypeList .
eq eMetaPrettyPrint((MAP, MAPS))
= (eMetaPrettyPrint(MAP) '`, '\s '\s eMetaPrettyPrint(MAPS))
[owise] .
eq eMetaPrettyPrint((none).RenamingSet) = nil .
eq eMetaPrettyPrint(op F to F' [AtS])
= if AtS == none
then ('\b 'op '\o F '\b 'to '\o F')
else ('\b 'op F '\b 'to '\o F' '\b
'`[ '\o eMetaPrettyPrint(noModule, AtS) '\b '`] '\o)
*** In a map there should not be attributes requiring a module
fi .
eq eMetaPrettyPrint(op F : TyL -> Ty to F' [AtS])
= if AtS == none
then ('\b 'op '\o F '\b ':
'\o eMetaPrettyPrint(TyL) '\b '-> '\o eMetaPrettyPrint(Ty)
'\b 'to '\o F')
else ('\b 'op '\o F '\b ':
'\o eMetaPrettyPrint(TyL) '\b '-> '\o eMetaPrettyPrint(Ty)
'\b 'to '\o F'
'\b '`[ '\o eMetaPrettyPrint(noModule, AtS) '\b '`] '\o)
*** In a map there should not be attributes requiring a module
fi .
eq eMetaPrettyPrint(sort S to S')
= ('\b 'sort '\o eMetaPrettyPrint(S) '\b 'to '\o eMetaPrettyPrint(S')) .
eq eMetaPrettyPrint(label L to L') = ('\b 'label '\o L '\b 'to '\o L') .
eq eMetaPrettyPrint(class S to S')
= ('\b 'class '\o eMetaPrettyPrint(S) '\b 'to '\o eMetaPrettyPrint(S')) .
eq eMetaPrettyPrint(attr QI . S to QI')
= ('\b 'attr '\o eMetaPrettyPrint(S) '\b '. '\o QI '\b 'to '\o QI') .
eq eMetaPrettyPrint(msg F to F') = ('\b 'msg '\o F '\b 'to '\o F') .
eq eMetaPrettyPrint(msg F : TyL -> Ty to F')
= ('\b 'msg '\o F '\b ':
'\o eMetaPrettyPrint(TyL) '\b '-> '\o eMetaPrettyPrint(Ty)
'\b 'to '\o F') .
endfm
*******************************************************************************
*** Finally, in the \texttt{VIEW-META-PRETTY-PRINT} module, the
*** \texttt{meta-pretty-print} function is defined on views.
fmod VIEW-META-PRETTY-PRINT is
pr DATABASE .
pr MAP-SET-META-PRETTY-PRINT .
pr VIEW-MAP-SET-APPL-ON-UNIT .
pr UNIT-META-PRETTY-PRINT .
op eMetaPrettyPrint : Database View -> QidList .
op eMetaPrettyPrint : ViewExp -> QidList .
op eMetaPrettyPrint : ModuleExpression ModuleExpression Database RenamingSet
RenamingSet -> QidList .
var QI : Qid .
var QIL : QidList .
var DB : Database .
vars ME ME' : ModuleExpression .
var MAP : Renaming .
var VMAP : ViewMap .
vars VMAPS VMAPS' : Set{ViewMap} .
vars T T' : Term .
var PDL : ParameterDeclList .
vars VE VE' : ViewExp .
var DT : Default{Term} .
ceq eMetaPrettyPrint(DB, view VE from ME to ME' is VMAPS endv)
= ('\b 'view '\o
QIL QI
if QI == '`) then '\s else nil fi
'\b 'from '\o eMetaPrettyPrint(ME)
'\b 'to '\o eMetaPrettyPrint(ME') '\b 'is '\o '\n
'\s '\s eMetaPrettyPrint(ME, ME', DB, VMAPS, VMAPS)
'\b 'endv '\o '\n)
if QIL QI := eMetaPrettyPrint(VE) .
ceq eMetaPrettyPrint(DB, view VE{PDL} from ME to ME' is VMAPS endv)
= ('\b 'view '\o
QIL QI
(if PDL == nil
then if QI == '`) then '\s else nil fi
else '`{ eMetaPrettyPrint(PDL) '`} '\s
fi)
'\b 'from '\o eMetaPrettyPrint(ME)
'\b 'to '\o eMetaPrettyPrint(ME') '\b 'is '\o '\n
'\s '\s eMetaPrettyPrint(ME, ME', DB, VMAPS, VMAPS)
'\b 'endv '\o '\n )
if QIL QI := eMetaPrettyPrint(VE) .
eq eMetaPrettyPrint(DB, viewError(QIL)) = QIL .
ceq eMetaPrettyPrint(QI) = QI if not QI :: Type .
ceq eMetaPrettyPrint(((VE, VE')))
= eMetaPrettyPrint(VE) '`, '\s eMetaPrettyPrint(VE')
if VE =/= nil /\ VE' =/= nil .
eq eMetaPrettyPrint(QI{VE}) = QI '`{ eMetaPrettyPrint(VE) '`} '\s .
eq eMetaPrettyPrint(ME, ME', DB, (VMAP, VMAPS), VMAPS')
= (eMetaPrettyPrint(ME, ME', DB, VMAP, VMAPS') '\n
'\s '\s eMetaPrettyPrint(ME, ME', DB, VMAPS, VMAPS'))
[owise] .
eq eMetaPrettyPrint(ME, ME', DB, none, VMAPS) = nil .
eq eMetaPrettyPrint(ME, ME', DB, MAP, VMAPS) = eMetaPrettyPrint(MAP) '. .
eq eMetaPrettyPrint(ME, ME', DB, termMap(T, T'), VMAPS)
= ('\b 'op '\o eMetaPrettyPrint(getFlatModule(ME, DB), T) '\b 'to
'term '\o eMetaPrettyPrint(getFlatModule(ME', DB), T') '\b '. '\o) .
eq eMetaPrettyPrint(termMap(T, T'))
= ('op eMetaPrettyPrint(T) '\b 'to '\o eMetaPrettyPrint(T')) .
endfm
*******************************************************************************
***
*** 8.3 Input Processing
***
*** The processing functions presented in the following modules are in charge
*** of taking each term generated by the \texttt{metaParse} function and,
*** after transforming it into an element of the data types \texttt{Module} or
*** \texttt{View}, or generating some output, returning the database resulting
*** from introducing in it such a term. We shall see in
*** Section~\ref{database-handling} how the appropriate function is called
*** after having performed a first analysis of the term, in which it is
*** detected whether the input corresponds to a unit, view, or command. In the
*** cases of units and views the processing is quite similar. After a
*** preprocessing of the term, the function \texttt{parseDecl} is called with
*** each of the subterms representing declarations, resulting in units or
*** views with the parsed declarations in it.
***
*** 8.3.1 Module Processing
***
*** The processing of a term resulting from the parsing of some input
*** corresponding to a unit is accomplished by the \texttt{procModule} function.
*** This function takes as arguments a term of sort \texttt{Term}, which
*** represents some preunit, and a database. The function then enters into the
*** given database the unit obtained from the transformation of such term
*** into a term of sort \texttt{Module}.
fmod UNIT-PROCESSING is
pr DATABASE .
pr UNIT-DECL-PARSING .
pr EVALUATION .
pr VIEW-MAP-SET-APPL-ON-UNIT .
pr META-FULL-MAUDE-SIGN .
pr MOD-EXP-PARSING .
vars QI F X : Qid .
var M : Module .
vars PU PU' U U' : Module .
vars DB DB' : Database .
vars T T' T'' T3 : Term .
var TL : TermList .
vars PL PL' PL'' : ParameterList .
var PDL : ParameterDeclList .
var IL IL' : ImportList .
var ME : ModuleExpression .
var S : Sort .
var SS : SortSet .
var ME' : ModuleExpression .
var VMAPS : RenamingSet .
var B : Bool .
var VDS : OpDeclSet .
var QIL : QidList .
var PDR : ParseDeclResult .
var DT : Default{Term} .
*** The \texttt{parseParList} takes a term representing a list of parameters
*** and returns the corresponding list.
op parseParList : Term -> ParameterDeclList .
eq parseParList('_::_['token[T], T']) = downQid(T) :: parseModExp(T') .
eq parseParList('_`,_[T, T']) = (parseParList(T), parseParList(T')) .
*** All the operators declared as constructors of sort \texttt{PreModule} in
*** the signature of Full Maude, given in Appendix~\ref{signature-full-maude},
*** are declared with two arguments, namely, the name, or name and interface,
*** of the unit, and the list of declarations of such units. The function
*** \texttt{procModule3} is called with the term corresponding to the name, or
*** name and interface, of the module as first argument, the term corresponding
*** to the set of declarations as second argument, and an empty module of the
*** appropriate type, in which the different declarations will be accumulated,
*** as third argument.
*** The task of the function \texttt{procModule4} is then to make a second
*** level parsing of the input, building up, simultaneously, the preunit
*** represented in the term passed as argument, and the unit resulting from the
*** declarations without bubbles. This unit without bubbles will be used by the
*** \texttt{evalPreModule} function to build the signature with which to
*** analyze the bubbles in the preunit (see Section~\ref{evaluation}).
*** The case of parameterized modules requires a special treatment of the
*** parameters. These parameters are evaluated and are added as submodules in
*** the appropriate way.
*** When the last declaration is parsed, the function \texttt{evalPreModule} is
*** called with the preunit (the top module with bubbles) as first argument,
*** the empty copy of it as second argument, the top module without bubbles as
*** third argument, and the database.
*** Note that the \texttt{procModule} function adds a declaration importing the
*** module \texttt{CONFIGURATION+}, presented in
*** Section~\ref{non-built-in-predefined}, to the object-oriented modules, and
*** that \texttt{procModule4} adds a declaration importing the built-in module
*** \texttt{BOOL} to all modules.
op procModule : Term Database -> Database .
*** moved to MOD-EXPR-EVAL to solve dependency
*** op procModule : Qid Database -> Database .
op procModule2 : Term Term Database -> Database .
op procModule2 : Term Database -> Database .
op procModule3 : Term Term Term Module Database -> Database .
op procModule3 : Term Term Module Database -> Database .
op procModule4 : Term Term Module Module OpDeclSet Database -> Database .
op procModule4 : Term Module Module OpDeclSet Database -> Database .
*** When recompiling a module, it's called with a Qid, and it's
*** not reentered into the database.
ceq procModule(QI, DB)
= if DT == null
then evalModule(U, VDS, DB)
else procModule2(DT, DB)
fi
if < DT ; VDS ; U > := getTermModule(QI, DB) .
eq procModule(T, DB) = procModule2(T, T, DB) .
*** procModule2 just calls procModule3 with the name and the declarations of
*** the module, and an empty unit of the right type.
eq procModule2(T, 'fmod_is_endfm[T', T''], DB)
= procModule3(T, T', T'', emptyFModule, DB) .
eq procModule2(T, 'obj_is_endo[T', T''], DB)
= procModule3(T, T', T'', emptyFModule, DB) .
eq procModule2(T, 'obj_is_jbo[T', T''], DB)
= procModule3(T, T', T'', emptyFModule, DB) .
eq procModule2(T, 'mod_is_endm[T', T''], DB)
= procModule3(T, T', T'', emptySModule, DB) .
eq procModule2(T, 'omod_is_endom[T', T''], DB)
= procModule3(T, T', T'',
addImports((including 'CONFIGURATION . including 'CONFIGURATION+ .),
emptyOModule),
DB) .
eq procModule2(T, 'fth_is_endfth[T', T''], DB)
= procModule3(T, T', T'', emptyFTheory, DB) .
eq procModule2(T, 'th_is_endth[T', T''], DB)
= procModule3(T, T', T'', emptySTheory, DB) .
eq procModule2(T, 'oth_is_endoth[T', T''], DB)
= procModule3(T, T', T'',
addImports((including 'CONFIGURATION . including 'CONFIGURATION+ .),
emptyOTheory),
DB) .
eq procModule2('fmod_is_endfm[T, T'], DB)
= procModule3(T, T', emptyFModule, DB) .
eq procModule2('obj_is_endo[T, T'], DB)
= procModule3(T, T', emptyFModule, DB) .
eq procModule2('obj_is_jbo[T, T'], DB)
= procModule3(T, T', emptyFModule, DB) .
eq procModule2('mod_is_endm[T, T'], DB)
= procModule3(T, T', emptySModule, DB) .
eq procModule2('omod_is_endom[T, T'], DB)
= procModule3(T, T',
addImports((including 'CONFIGURATION+ .),
emptyOModule),
DB) .
eq procModule2('fth_is_endfth[T, T'], DB)
= procModule3(T, T', emptyFTheory, DB) .
eq procModule2('th_is_endth[T, T'], DB)
= procModule3(T, T', emptySTheory, DB) .
eq procModule2('oth_is_endoth[T, T'], DB)
= procModule3(T, T',
addImports((including 'CONFIGURATION+ .),
emptyOTheory),
DB) .
*** procModule3 evaluates the name of the module and calls procModule4
*** with the declarations, two empty units (one to contain the declarations
*** with bubbles and another one the declarations without bubbles), and
*** a set of op decls initialy empty in which to store the variables
ceq procModule3(T, 'token[T'], T'', U, DB)
= procModule4(T, T'', setName(U, QI), setName(U, QI), none, DB)
if QI := downQid(T') .
ceq procModule3(T, '_`{_`}['token[T'], T''], T3, U, DB)
= procModule4(T, T3, setPars(setName(U, QI), parseParList(T'')),
setName(U, QI), none, DB)
if QI := downQid(T') .
ceq procModule3('token[T], T', U, DB)
= procModule4(T', setName(U, QI), setName(U, QI), none, DB)
if QI := downQid(T) .
ceq procModule3('_`{_`}['token[T], T'], T'', U, DB)
= procModule4(T'', setPars(setName(U, QI), parseParList(T')),
setName(U, QI), none, DB)
if QI := downQid(T) .
*** procModule4 parses one by one each of the declarations in the module.
*** Note that is parseDecl that adds the parsed declaration to the right
*** place. When it is done, it calls evalPreModule with the resulting
*** preModule-unit-vars triple.
ceq procModule4(T, '__[T', T''], PU, U, VDS, DB)
= procModule4(T, T'', preModule(PDR), unit(PDR), vars(PDR), DB)
if PDR := parseDecl(T', PU, U, VDS) .
ceq procModule4(T, F[TL], PU, U, VDS, DB)
= evalPreModule(preModule(PDR), unit(PDR), vars(PDR),
insTermModule(getName(U), T, DB))
if F =/= '__
/\ PDR := parseDecl(F[TL], PU, U, VDS) .
eq procModule4(T, T', unitError(QIL), V:[Module], V:[OpDeclSet], DB)
= warning(DB, QIL) .
eq procModule4(T, T', V:[Module], unitError(QIL), V:[OpDeclSet], DB)
= warning(DB, QIL) .
eq procModule4(T, T', V:[Module], V':[Module], opDeclError(QIL), DB)
= warning(DB, QIL) .
ceq procModule4('__[T, T'], PU, U, VDS, DB)
= procModule4(T', preModule(PDR), unit(PDR), vars(PDR), DB)
if PDR := parseDecl(T, PU, U, VDS) .
ceq procModule4(F[TL], PU, U, VDS, DB)
= evalPreModule(preModule(PDR), unit(PDR), vars(PDR), DB)
if F =/= '__
/\ PDR := parseDecl(F[TL], PU, U, VDS) .
eq procModule4(T, unitError(QIL), U, VDS, DB) = warning(DB, QIL) .
eq procModule4(T, PU, unitError(QIL), VDS, DB) = warning(DB, QIL) .
eq procModule4(T, PU, U, opDeclError(QIL), DB) = warning(DB, QIL) .
endfm
*******************************************************************************
***
*** 8.3.2 View Processing
***
*** A similar process is followed for views. Note that in case of operator
*** maps going to derived terms we have bubbles, which will have to be treated
*** using the signatures of the appropriate modules.
fmod VIEW-PROCESSING is
pr UNIT-PROCESSING .
pr VIEW-DECL-PARSING .
pr VIEW-BUBBLE-PARSING .
vars QI X F : Qid .
var QIL : QidList .
vars T T' T'' T3 T4 : Term .
var M : Module .
var VE : ViewExp .
vars PV PV' : PreView .
vars ME ME' : ModuleExpression .
vars DB DB' : Database .
vars OPDS VDS VDS' VDS'' : OpDeclSet .
var MDS : MsgDeclSet .
var TL : TermList .
vars PDL PDL' : ParameterDeclList .
var H : Header .
var IL : ImportList .
var PVMAPS : Set{PreViewMap} .
*** As the functions \texttt{getThSorts} and \texttt{getThClasses}
*** presented in Section~\ref{instantiation}, the functions
*** \texttt{getThOpDeclSet} and \texttt{getThMsgDeclSet} return, respectively,
*** the set of declarations of operators, and the set of declarations of
*** messages in the theory part of the structure of the module given as
*** argument.
op getThOpDeclSet : Header Database -> OpDeclSet .
op getThMsgDeclSet : Header Database -> MsgDeclSet .
op getThOpDeclSetAux : ImportList Database -> OpDeclSet .
op getThMsgDeclSetAux : ImportList Database -> MsgDeclSet .
eq getThOpDeclSet(ME, DB)
= if theory(getTopModule(ME, DB))
then (getThOpDeclSetAux(getImports(getTopModule(ME, DB)), DB)
getOps(getTopModule(ME, DB)))
else none
fi .
eq getThOpDeclSetAux(((including ME .) IL), DB)
= (getThOpDeclSet(ME, DB) getThOpDeclSetAux(IL, DB)) .
eq getThOpDeclSetAux(((extending ME .) IL), DB)
= (getThOpDeclSet(ME, DB) getThOpDeclSetAux(IL, DB)) .
eq getThOpDeclSetAux(((protecting ME .) IL), DB)
= (getThOpDeclSet(ME, DB) getThOpDeclSetAux(IL, DB)) .
eq getThOpDeclSetAux(nil, DB) = none .
eq getThMsgDeclSet(ME, DB)
= if theory(getTopModule(ME, DB))
then (getThMsgDeclSetAux(getImports(getTopModule(ME, DB)), DB)
getMsgs(getTopModule(ME, DB)))
else none
fi .
eq getThMsgDeclSetAux(((including ME .) IL), DB)
= (getThMsgDeclSet(ME, DB) getThMsgDeclSetAux(IL, DB)) .
eq getThMsgDeclSetAux(((extending ME .) IL), DB)
= (getThMsgDeclSet(ME, DB) getThMsgDeclSetAux(IL, DB)) .
eq getThMsgDeclSetAux(((protecting ME .) IL), DB)
= (getThMsgDeclSet(ME, DB) getThMsgDeclSetAux(IL, DB)) .
eq getThMsgDeclSetAux(nil, DB) = none .
*** The processing of terms representing previews accomplished by the function
*** \texttt{procView} is quite similar to the one accomplished by
*** \texttt{procModule} on terms representing preunits. The algorithms followed
*** are also quite similar. Both proceed recursively on the list of
*** declarations, accumulating them in a preunit or in a preview.
*** The solving of bubbles in views requires the signatures of the source and
*** target units extended, respectively, with the declarations of variables in
*** the view and with the mappings of these declarations. As we shall see in
*** Section~\ref{databaseADT}, the signatures of the built-in modules are not
*** accesible at the metalevel, and thus built-in modules cannot be used
*** directly as arguments of built-in functions. Thus, to be able to use them
*** as targTS of views, a `dummy' module is created importing the
*** corresponding predefined module. The source and target module expressions
*** of the view are evaluated before the view processing itself starts.
*** As we saw in Section~\ref{view-decl-parsing}, parsing of terms representing
*** operator and message maps requires the set of operator and message
*** declarations in the theory part of the source theory.
op procPars : ParameterDeclList Database -> Database .
eq procPars((X :: ME, PDL), DB)
= procPars(PDL, createCopy((X :: ME), database(evalModExp(ME, DB)))) .
eq procPars((nil).ParameterDeclList, DB) = DB .
op procView : Term Database -> Database .
op procView2 : Term Database -> Database .
op procView : Term PreView Database -> Database .
op procViewAux :
Term PreView OpDeclSet MsgDeclSet Module Database -> Database .
eq procView(QI, DB)
= procView2(getTermView(QI, DB), DB) .
eq procView2('view_from_to_is_endv['token[T], T', T'', T3], DB)
= procView(T3,
emptyPreView(downQid(T), parseModExp(T'), parseModExp(T'')),
DB) .
eq procView2('view_from_to_is_endv['_`{_`}['token[T], T'], T'', T3, T4], DB)
= procView(T4,
setPars(
emptyPreView(downQid(T), parseModExp(T''), parseModExp(T3)),
parseParList(T')),
procPars(parseParList(T'), DB)) .
eq procView('view_from_to_is_endv['token[T], T', T'', T3], DB)
= procView(T3,
emptyPreView(downQid(T), parseModExp(T'), parseModExp(T'')),
insertTermView(downQid(T),
'view_from_to_is_endv['token[T], T', T'', T3], DB)) .
eq procView('view_from_to_is_endv['_`{_`}['token[T], T'], T'', T3, T4], DB)
= procView(T4,
setPars(
emptyPreView(downQid(T), parseModExp(T''), parseModExp(T3)),
parseParList(T')),
procPars(parseParList(T'),
insertTermView(downQid(T),
'view_from_to_is_endv['_`{_`}['token[T], T'], T'', T3, T4],
DB))) .
ceq procView(T, PV, DB)
= procViewAux(T, PV,
getThOpDeclSet(ME, DB'),
getThMsgDeclSet(ME, DB'),
getFlatModule(ME, DB'),
DB')
if preview_from_to_is__endpv(VE, ME, ME', none, none) := PV
/\ DB' := database(evalModExp(ME', nil, database(evalModExp(ME, nil, DB)))) .
ceq procView(T, PV, DB)
= procViewAux(T, PV,
getThOpDeclSet(ME, DB':[Database]),
getThMsgDeclSet(ME, DB':[Database]),
getFlatModule(ME, DB':[Database]),
DB':[Database])
if preview_from_to_is__endpv(VE{PDL}, ME, ME', none, none) := PV
/\ DB':[Database] := database(evalModExp(ME', PDL, database(evalModExp(ME, PDL, DB)))) .
eq procViewAux('none.ViewDeclSet, preview_from_to_is__endpv(VE{PDL}, ME, ME', VDS, PVMAPS), OPDS, MDS, M, DB)
= insertView(view VE{PDL} from ME to ME' is none endv, DB) .
eq procViewAux('none.ViewDeclSet, preview_from_to_is__endpv(VE, ME, ME', VDS, PVMAPS), OPDS, MDS, M, DB)
= insertView(view VE from ME to ME' is none endv, DB) .
eq procViewAux('__[T, T'], PV, OPDS, MDS, M, DB)
*** - OPDS and MDS are, respectively, the set of operation and
*** message declarations in the theory part of the source.
*** - M is the signature of the source theory.
= procViewAux(T', parseDecl(T, PV, OPDS, MDS, M), OPDS, MDS, M, DB) .
ceq procViewAux(F[TL], PV, OPDS, MDS, M, DB)
= insertView(
view VE{PDL} from ME to ME' is
solveBubbles(
PVMAPS,
VDS, VDS',
addOps(VDS, M),
addOps(VDS', getFlatModule(ME', DB)))
endv,
DB)
if F =/= '__
/\ preview_from_to_is__endpv(VE{PDL}, ME, ME', VDS, PVMAPS)
:= parseDecl(F[TL], PV, OPDS, MDS, M)
/\ VDS' := applyMapsToOps(sortMaps(PVMAPS), none, VDS, M) .
ceq procViewAux(F[TL], PV, OPDS, MDS, M, DB)
= insertView(
view VE from ME to ME' is
solveBubbles(
PVMAPS,
VDS, VDS',
addOps(VDS, M),
addOps(VDS', getFlatModule(ME', DB)))
endv,
DB)
if F =/= '__
/\ preview_from_to_is__endpv(VE, ME, ME', VDS, PVMAPS)
:= parseDecl(F[TL], PV, OPDS, MDS, M)
/\ VDS' := applyMapsToOps(sortMaps(PVMAPS), none, VDS, M) .
eq procViewAux(T, PV, OPDS, MDS, unitError(QIL), DB) = warning(DB, QIL) .
endfm
*******************************************************************************
***
*** 8.3.3 Command Processing
***
*** The function \texttt{procCommand} only handles the \texttt{reduce},
*** \texttt{rewrite}, and \texttt{down} commands. The other commands are
*** directly evaluated by the rules for the top-level handling of the
*** database (see Section~\ref{database-handling}). The \texttt{procCommand}
*** function takes a term, which represents one of these commands, the name of
*** the default module, and a database. The result is a list of quoted
*** identifiers representing the result of the evaluation of the command that
*** will be placed in the read-eval-print loop to be printed in the terminal.
*** The \texttt{reduce} and \texttt{rewrite} commands are basically evaluated
*** calling the built-in functions \texttt{metaReduce} and
*** \texttt{metaRewrite}, respectively. These functions are called with the
*** appropriate modules. In the case of commands in which an explicit module
*** is not specified the default module is used.
*** The preparation of the output for these functions becomes more complex
*** when the \texttt{down} command is used. To deal with the \texttt{down}
*** command, an auxiliary function \texttt{procCommand2} is introduced,
*** returning the term resulting from the evaluation of the command.
fmod COMMAND-PROCESSING is
pr UNIT-PROCESSING .
pr UNIT-META-PRETTY-PRINT .
inc (2TUPLE * (op `(_`,_`) to <<_;_>>,
op p1_ to getDatabase,
op p2_ to getQidList)) {Database, QidList} .
pr META-FULL-MAUDE-SIGN .
pr META-NARROWING-SEARCH * (op addOps to addOpsSE, op addEqs to addEqsSE, op addSorts to addSortsSE) .
eq getDatabase(<< DB ; qidError(QIL) >>) = warning(DB, QIL) .
eq getQidList(<< DB ; qidError(QIL) >>) = QIL .
op {_,_} : Term Type ~> ResultPair [ctor] .
op {_,_,_} : Term Type Substitution ~> ResultTriple [ctor] .
op {_,_,_,_} : Term Type Substitution Context ~> Result4Tuple [ctor] .
op {_,_} : Substitution Context ~> MatchPair [ctor] .
*** projection functions (from prelude.maude)
op getTerm : ResultPair ~> Term .
eq getTerm({T:[Term], T':[Type]}) = T:[Term] .
op getType : ResultPair ~> Type .
eq getType({T:[Term], T':[Type]}) = T':[Type] .
op getTerm : ResultTriple ~> Term .
eq getTerm({T:[Term], T':[Type], S:[Substitution]}) = T:[Term] .
op getType : ResultTriple ~> Type .
eq getType({T:[Term], T':[Type], S:[Substitution]}) = T':[Type] .
op gTSubstitution : ResultTriple ~> Substitution .
eq gTSubstitution({T:[Term], T':[Type], S:[Substitution]})
= S:[Substitution] .
op getTerm : Result4Tuple ~> Term .
eq getTerm({T:[Term], T':[Type], S:[Substitution], C:[Context]}) = T:[Term] .
op getType : Result4Tuple ~> Type .
eq getType({T:[Term], T':[Type], S:[Substitution], C:[Context]}) = T':[Type] .
op gTSubstitution : Result4Tuple ~> Substitution .
eq gTSubstitution({T:[Term], T':[Type], S:[Substitution], C:[Context]})
= S:[Substitution] .
op getContext : Result4Tuple ~> Context .
eq getContext({T:[Term], T':[Type], S:[Substitution], C:[Context]})
= C:[Context] .
op gTSubstitution : MatchPair ~> Substitution .
eq gTSubstitution({S:[Substitution], C:[Context]}) = S:[Substitution] .
op getContext : MatchPair ~> Context .
eq getContext({S:[Substitution], C:[Context]}) = C:[Context] .
vars T T' T'' T''' : Term .
var TL : TermList .
vars DB DB' DB'' : Database .
var DB? : [Database] .
vars M M' : Module .
var M? : [Module] .
vars ME ME' : ModuleExpression .
vars H H' : Header .
vars MNS MNS' MNS'' MNS3 MNS4 : Set{ModuleName} .
var VE : ViewExp .
var VES : Set{ViewExp} .
vars N I J : Nat .
var I? : [Nat] .
vars D D' : Bound .
var D? : [Bound] .
var B : Bool .
var B? : [Bool] .
vars MIS MIS' : Set{ModuleInfo} .
var VIS : Set{ViewInfo} .
vars PDS PDS' : Set{ParameterDecl} .
var QIL : QidList .
var SS : SortSet .
var SSDS : SubsortDeclSet .
vars VS VDS OPDS : OpDeclSet .
var OPDS? : [OpDeclSet] .
var MAS : MembAxSet .
var EqS : EquationSet .
var RlS : RuleSet .
vars QI QI' F V O : Qid .
var Ct : Constant .
var IL : ImportList .
var TM : [Tuple{Term,Module,Bool,OpDeclSet,Database}] .
var TMVB : [Tuple{Term,Module,Bool,OpDeclSet,Bound,Database}] .
var TMVBN : [Tuple{Term,Module,OpDeclSet,Bound,Nat}] .
var T? : [Term] .
var RP : [ResultPair] .
var RT : [ResultTriple] .
var Sb? : [Substitution] .
var MP? : [MatchPair] .
var CD : Condition .
var Sb : Substitution .
var UP? : [UnificationPair] .
var UP : UnificationProblem .
---- sorts Tuple{Term,Module,Bool,OpDeclSet,Database}
---- Tuple{Term,Module,Bool,OpDeclSet,Bound,Database}
---- Tuple{Term,Module,OpDeclSet,Bound,Nat} .
---- op `{_`,_`,_`,_`,_`} : Term Module Bool OpDeclSet Database
---- -> Tuple{Term,Module,Bool,OpDeclSet,Database} .
---- op `{_`,_`,_`,_`,_`,_`} : Term Module Bool OpDeclSet Bound Database
---- -> Tuple{Term,Module,Bool,OpDeclSet,Bound,Database} .
---- op `{_`,_`,_`,_`,_`} : Term Module OpDeclSet Bound Nat
---- -> Tuple{Term,Module,OpDeclSet,Bound,Nat} .
op tupleTMBODerror : QidList -> [Tuple{Term,Module,Bool,OpDeclSet,Database}] .
op tupleTMBOBDerror : QidList -> [Tuple{Term,Module,Bool,OpDeclSet,Bound,Database}] .
op tupleTMOBNerror : QidList -> [Tuple{Term,Module,OpDeclSet,Bound,Nat}] .
pr 5TUPLE{Term,Module,Bool,OpDeclSet,Database}
* (op ((_,_,_,_,_)) to `{_`,_`,_`,_`,_`},
op p1_ to getTerm,
op p2_ to getModule,
op p3_ to getBool,
op p4_ to getVars,
op p5_ to getDatabase) .
pr 6TUPLE{Term,Module,Bool,OpDeclSet,Bound,Database}
* (op ((_,_,_,_,_,_)) to `{_`,_`,_`,_`,_`,_`},
op p1_ to getTerm,
op p2_ to getModule,
op p3_ to getBool,
op p4_ to getVars,
op p5_ to getBound,
op p6_ to getDatabase) .
pr 5TUPLE{Term,Module,OpDeclSet,Bound,Nat}
* (op ((_,_,_,_,_)) to `{_`,_`,_`,_`,_`},
op p1_ to getTerm,
op p2_ to getModule,
op p3_ to getVars,
op p4_ to getBound,
op p5_ to getNat) .
op boundError : QidList -> [Bound] .
---- op getTerm : Tuple{Term,Module,Bool,OpDeclSet,Database} ~> Term .
---- op getModule : Tuple{Term,Module,Bool,OpDeclSet,Database} ~> Module .
---- op getVars : Tuple{Term,Module,Bool,OpDeclSet,Database} ~> OpDeclSet .
---- op getBool : Tuple{Term,Module,Bool,OpDeclSet,Database} ~> Bool .
---- op getDatabase : Tuple{Term,Module,Bool,OpDeclSet,Database} ~> Database .
---- op getTerm : Tuple{Term,Module,Bool,OpDeclSet,Bound,Database} ~> Term .
---- op getModule : Tuple{Term,Module,Bool,OpDeclSet,Bound,Database} ~> Module .
---- op getVars : Tuple{Term,Module,Bool,OpDeclSet,Bound,Database} ~> OpDeclSet .
---- op getBound : Tuple{Term,Module,Bool,OpDeclSet,Bound,Database} ~> Bound .
---- op getBool : Tuple{Term,Module,Bool,OpDeclSet,Bound,Database} ~> Bool .
---- op getDatabase : Tuple{Term,Module,Bool,OpDeclSet,Bound,Database} ~> Database .
---- op getTerm : Tuple{Term,Module,OpDeclSet,Bound,Nat} ~> Term .
---- op getModule : Tuple{Term,Module,OpDeclSet,Bound,Nat} ~> Module .
---- op getVars : Tuple{Term,Module,OpDeclSet,Bound,Nat} ~> OpDeclSet .
---- op getBound : Tuple{Term,Module,OpDeclSet,Bound,Nat} ~> Bound .
---- op getNat : Tuple{Term,Module,OpDeclSet,Bound,Nat} ~> Nat .
---- eq {qidError(QIL), M?, B?, OPDS?, DB?} = tupleTMBODerror(QIL) .
---- eq {qidError(QIL), M?, B?, OPDS?, D?, DB?} = tupleTMBOBDerror(QIL) .
---- eq {qidError(QIL), M?, OPDS?, D?, I?} = tupleTMOBNerror(QIL) .
eq getTerm({T, M, B, VDS, DB}) = T .
eq getTerm(tupleTMBODerror(QIL)) = qidError(QIL) .
eq getModule({T, M, B, VDS, DB}) = M .
eq getModule(tupleTMBODerror(QIL)) = unitError(QIL) .
eq getVars({T, M, B, VDS, DB}) = VDS .
eq getVars(tupleTMBODerror(QIL)) = opDeclError(QIL) .
eq getBool({T, M, B, VDS, DB}) = B .
eq getBool(tupleTMBODerror(QIL)) = false .
eq getDatabase({T, M, B, VDS, DB}) = DB .
eq getDatabase(tupleTMBODerror(QIL)) = emptyDatabase .
eq getTerm({T, M, B, VDS, D, DB}) = T .
---- eq getTerm(error(QIL)) = qidError(QIL) .
eq getModule({T, M, B, VDS, D, DB}) = M .
---- eq getModule(error(QIL)) = unitError(QIL) .
eq getVars({T, M, B, VDS, D, DB}) = VDS .
---- eq getVars(error(QIL)) = opDeclError(QIL) .
eq getBound({T, M, B, VDS, D, DB}) = D .
---- eq getBound(error(QIL)) = boundError(QIL) .
eq getBool({T, M, B, VDS, D, DB}) = B .
---- eq getBool(error(QIL)) = false .
eq getDatabase({T, M, B, VDS, D, DB}) = DB .
---- eq getDatabase(error(QIL)) = emptyDatabase .
eq getTerm({T, M, VDS, D, I}) = T .
---- eq getTerm(error(QIL)) = qidError(QIL) .
eq getModule({T, M, VDS, D, I}) = M .
---- eq getModule(error(QIL)) = unitError(QIL) .
eq getVars({T, M, VDS, D, I}) = VDS .
---- eq getVars(error(QIL)) = opDeclError(QIL) .
eq getBound({T, M, VDS, D, I}) = D .
---- eq getBound(error(QIL)) = boundError(QIL) .
eq getNat({T, M, VDS, D, I}) = I .
---- eq getNat(error(QIL)) = numberError(QIL) .
---- procLoad
op procLoad : Term ModuleExpression Database -> Tuple{Database,QidList} .
op procLoad : Term ModuleExpression Module OpDeclSet Database -> Tuple{Database,QidList} .
eq procLoad(T, ME, DB)
= if compiledModule(ME, DB)
then procLoad(T, ME, getFlatModule(ME, DB), getVars(ME, DB), DB)
else procLoad(T, modExp(evalModExp(ME, DB)),
getFlatModule(modExp(evalModExp(ME, DB)),
database(evalModExp(ME, DB))),
getVars(modExp(evalModExp(ME, DB)), database(evalModExp(ME, DB))),
database(evalModExp(ME, DB)))
fi
[owise] .
ceq procLoad(T, ME, M, VDS, DB)
= if downTerm(T:[Term], emptyFModule) =/= emptyFModule
then << evalModule(downModule(T:[Term]), none, DB) ; 'Introduced 'module header2Qid(getName(downModule(T:[Term]))) '\n >>
else << DB ; '\r 'Error: '\o 'Incorrect 'metamodule. '\n >>
fi
if T:[Term] := getTerm(metaReduce(M, solveBubbles(T, M, true, VDS, DB))) .
---(
eq procLoad(T, ME, M, VDS, DB)
= if downModule(getTerm(metaReduce(M, solveBubbles(T, M, true, VDS, DB)))) :: Module
then << evalModule(downModule(getTerm(metaReduce(M, solveBubbles(T, M, true, VDS, DB)))), none, DB) ;
'Introduced 'module header2Qid(getName(downModule(getTerm(metaReduce(M, solveBubbles(T, M, true, VDS, DB)))))) '\n >>
else << DB ; '\r 'Error: '\o 'Incorrect 'metamodule. '\n >>
fi .
)
---- procCommand
op procCommand : Term ModuleExpression Database -> Tuple{Database,QidList} .
op procCommand : Term ModuleExpression Module OpDeclSet Database -> QidList .
op procDownCommand : Term ModuleExpression Database -> Tuple{Database,QidList} .
op procParse : ModuleExpression Module Term OpDeclSet Database -> QidList .
op procRed : ModuleExpression Module Term OpDeclSet Database -> QidList .
op solveBubblesRed : Term Module Bool OpDeclSet Database
-> [Tuple{Term,Module,Bool,OpDeclSet,Database}] .
op solveBubblesRed2 : Term Database -> [Tuple{Term,Module,Bool,OpDeclSet,Database}] .
op solveBubblesRed3 : Term Module ModuleExpression OpDeclSet Database -> [Tuple{Term,Module,Bool,OpDeclSet,Database}] .
op procRew : ModuleExpression Module Term OpDeclSet Database -> QidList .
op solveBubblesRew : Term Module Bool Bound OpDeclSet Database -> [Tuple{Term,Module,Bool,OpDeclSet,Bound,Database}] .
op solveBubblesRew2 : Term Module Bool OpDeclSet Database -> [Tuple{Term,Module,Bool,OpDeclSet,Bound,Database}] .
op procFrew : ModuleExpression Module Term Bound Nat OpDeclSet Database -> QidList .
op solveBubblesFrew : Term Module Bool Bound Nat OpDeclSet Database -> [Tuple{Term,Module,OpDeclSet,Bound,Nat}] .
op solveBubblesFrew2 : Term Module Bool Nat OpDeclSet Database -> [Tuple{Term,Module,OpDeclSet,Bound,Nat}] .
op procSearch : ModuleExpression Module Term Term Qid Bound Bound OpDeclSet Database -> QidList .
op solveBubblesSearchL : Module Term Term Qid Bound Bound Bool OpDeclSet Database -> QidList .
op solveBubblesSearchL1 : Module Term Term Qid Bound Bound Bool OpDeclSet Database -> QidList .
op solveBubblesSearchR : Module Term Term Qid Bound Bound Bool OpDeclSet Database -> QidList .
op solveBubblesSearchR1 : Module Module Term Term Qid Bound Bound Bool OpDeclSet Database -> QidList .
op solveBubblesSearchR2 : Module Term Term Qid Bound Bound OpDeclSet -> QidList .
op procSearch2 : Module Term Term Condition Qid Bound Bound -> QidList .
op procSearch3 : Module Term Term Condition Qid Bound Nat Bound -> QidList .
op procNarrowSearch : ModuleExpression Module Term Term Qid Bound Bound OpDeclSet Database -> QidList .
op solveBubblesNarrowSearchL : Module Term Term Qid Bound Bound Bool OpDeclSet Database -> QidList .
op solveBubblesNarrowSearchL1 : Module Term Term Qid Bound Bound Bool OpDeclSet Database -> QidList .
op solveBubblesNarrowSearchR : Module Term Term Qid Bound Bound Bool OpDeclSet Database -> QidList .
op solveBubblesNarrowSearchR1 : Module Module Term Term Qid Bound Bound Bool OpDeclSet Database -> QidList .
op solveBubblesNarrowSearchR2 : Module Term Term Qid Bound Bound OpDeclSet -> QidList .
op procNarrowSearch2 : Module Term Term Condition Qid Bound Bound -> QidList .
op procNarrowSearch3 : Module Nat TermList ResultTripleSet -> QidList .
op procMatch : ModuleExpression Module Term Term Qid Bound OpDeclSet Database -> QidList .
op procMatch2 : Module Term Term Condition Qid Bound -> QidList .
op procMatch3 : Module Term Term Condition Qid Bound Nat -> QidList .
op solveBubblesMatch : Module Module Term Term Qid Bound Bool OpDeclSet Database ~> QidList .
op solveBubblesMatch2 : Module Term Term Qid Bound OpDeclSet ~> QidList .
op procUnify : ModuleExpression Module Term Bound OpDeclSet Database -> QidList .
op procUnify2 : ModuleExpression Module Term Bound OpDeclSet Database -> QidList .
op addInfoUnify : Module -> [Module] .
op parseUnify : Term OpDeclSet -> UnificationProblem .
op procUnify2 : Module UnificationProblem Bound -> QidList .
op eMetaPrettyPrint : Module UnificationProblem -> QidList .
op procUnify3 : Module UnificationProblem Bound Nat -> QidList .
op procUnify3Aux : Module UnificationPair Nat -> QidList .
op unificationProblemError : QidList -> [UnificationProblem] .
op procIdUnify : ModuleExpression Module Term Bound OpDeclSet Database -> QidList .
op addInfoIdUnify : Module -> [Module] .
op parseIdUnify : Term OpDeclSet -> UnificationProblem .
op procIdUnify2 : Module UnificationProblem Bound -> QidList .
op procIdUnify3 : Module UnificationProblem Nat SubstitutionSet -> QidList .
op solveBubblesUnify : Module Term OpDeclSet ~> UnificationProblem .
op solveBubblesRedUnify : Term Module Bool OpDeclSet Database
-> [Tuple{Term,Module,Bool,OpDeclSet,Database}] .
op solveBubblesRedUnify2 : Term Database -> [Tuple{Term,Module,Bool,OpDeclSet,Database}] .
op solveBubblesRedUnify3 : Term Module ModuleExpression OpDeclSet Database
-> [Tuple{Term,Module,Bool,OpDeclSet,Database}] .
op procRewUnify : ModuleExpression Module Term OpDeclSet Database -> QidList .
op solveBubblesRewUnify : Term Module Bool Bound OpDeclSet Database
-> [Tuple{Term,Module,Bool,OpDeclSet,Bound,Database}] .
op solveBubblesRewUnify2 : Term Module Bool OpDeclSet Database
-> [Tuple{Term,Module,Bool,OpDeclSet,Bound,Database}] .
op eMetaPrettyPrint : Module Substitution -> QidList .
eq eMetaPrettyPrint(M, V <- T ; Sb:Substitution)
= V '--> '\s eMetaPrettyPrint(M, T)
if eMetaPrettyPrint(M, Sb:Substitution) == nil
then nil
else '; eMetaPrettyPrint(M, Sb:Substitution)
fi .
eq eMetaPrettyPrint(M, (none).Substitution) = nil .
op procCommandUp : ModuleExpression Module Term OpDeclSet Database -> Term .
op procRedUp : ModuleExpression Module Term OpDeclSet Database -> Term .
op procRewUp : ModuleExpression Module Term Bound OpDeclSet Database -> Term .
op procFrewUp : ModuleExpression Module Term Bound Nat OpDeclSet Database -> Term .
*** Processing of commands.
ceq procDownCommand('down_:_[T, T'], ME, DB)
= if T'':[Term] :: Term
then << DB'' ;
('\b 'result '\o
'\s eMetaPrettyPrint(leastSort(M, T'':[Term]))
'\s '\b ': '\o '\n '\s '\s
eMetaPrettyPrint(M, T'':[Term]) '\n) >>
else << DB ; ('\r 'Error: '\o 'Incorrect 'input. '\n) >>
fi
if DB' := database(evalModExp(ME, DB))
/\ < DB'' ; ME' > := evalModExp(parseModExp(T), DB')
/\ M := getFlatModule(ME', DB'')
/\ T'':[Term] := procCommandUp(ME, getFlatModule(ME, DB''), T', getVars(ME, DB''), DB'').
eq procCommand(T, ME, DB)
= if compiledModule(ME, DB)
then << DB ; procCommand(T, ME, getFlatModule(ME, DB), getVars(ME, DB), DB) >>
else << database(evalModExp(ME, DB)) ;
procCommand(T, modExp(evalModExp(ME, DB)),
getFlatModule(modExp(evalModExp(ME, DB)), database(evalModExp(ME, DB))),
getVars(modExp(evalModExp(ME, DB)), database(evalModExp(ME, DB))),
database(evalModExp(ME, DB))) >>
fi
[owise] .
---- eq procCommand(T, ME, unitError(QIL), VS, DB) = qidError(QIL) .
eq procCommand(T, ME, unitError(QIL), VS, DB) = QIL .
eq procCommand('parse_.['bubble[T]], ME, M, VS, DB)
= procParse(ME, M, 'bubble[T], VS, DB) .
eq procCommand('reduce_.['bubble[T]], ME, M, VS, DB)
= procCommand('red_.['bubble[T]], ME, M, VS, DB) .
eq procCommand('red_.['bubble[T]], ME, M, VS, DB)
= procRed(ME, M, 'bubble[T], VS, DB) .
eq procCommand('rewrite_.['bubble[T]], ME, M, VS, DB)
= procCommand('rew_.['bubble[T]], ME, M, VS, DB) .
eq procCommand('rew_.['bubble[T]], ME, M, VS, DB)
= procRew(ME, M, 'bubble[T], VS, DB) .
eq procCommand('frewrite_.['bubble[T]], ME, M, VS, DB)
= procCommand('frew_.['bubble[T]], ME, M, VS, DB) .
eq procCommand('frew_.['bubble[T]], ME, M, VS, DB)
= procFrew(ME, M, 'bubble[T], unbounded, 1, VS, DB) .
eq procCommand('search_=>1_.['bubble[T], 'bubble[T']], ME, M, VS, DB)
= procSearch(ME, M, 'bubble[T], 'bubble[T'], '+, unbounded, 1, VS, DB) .
eq procCommand('search_=>*_.['bubble[T], 'bubble[T']], ME, M, VS, DB)
= procSearch(ME, M, 'bubble[T], 'bubble[T'], '*, unbounded, unbounded, VS, DB) .
eq procCommand('search_=>+_.['bubble[T], 'bubble[T']], ME, M, VS, DB)
= procSearch(ME, M, 'bubble[T], 'bubble[T'], '+, unbounded, unbounded, VS, DB) .
eq procCommand('search_=>!_.['bubble[T], 'bubble[T']], ME, M, VS, DB)
= procSearch(ME, M, 'bubble[T], 'bubble[T'], '!, unbounded, unbounded, VS, DB) .
eq procCommand('search_~>1_.['bubble[T], 'bubble[T']], ME, M, VS, DB)
= procNarrowSearch(ME, M, 'bubble[T], 'bubble[T'], '+, unbounded, 1, VS, DB) .
eq procCommand('search_~>*_.['bubble[T], 'bubble[T']], ME, M, VS, DB)
= procNarrowSearch(ME, M, 'bubble[T], 'bubble[T'], '*, unbounded, unbounded, VS, DB) .
eq procCommand('search_~>+_.['bubble[T], 'bubble[T']], ME, M, VS, DB)
= procNarrowSearch(ME, M, 'bubble[T], 'bubble[T'], '+, unbounded, unbounded, VS, DB) .
eq procCommand('search_~>!_.['bubble[T], 'bubble[T']], ME, M, VS, DB)
= procNarrowSearch(ME, M, 'bubble[T], 'bubble[T'], '!, unbounded, unbounded, VS, DB) .
eq procCommand('match_<=?_.['bubble[T], 'bubble[T']], ME, M, VS, DB)
= procMatch(ME, M, 'bubble[T], 'bubble[T'], 'match, 0, VS, DB) .
eq procCommand('xmatch_<=?_.['bubble[T], 'bubble[T']], ME, M, VS, DB)
= procMatch(ME, M, 'bubble[T], 'bubble[T'], 'xmatch, 0, VS, DB) .
eq procCommand('unify_.['bubble[T]], ME, M, VS, DB)
= procUnify(ME, M, 'bubble[T], unbounded, VS, DB) .
eq procCommand('id-unify_.['bubble[T]], ME, M, VS, DB)
= procIdUnify(ME, M, 'bubble[T], unbounded, VS, DB) .
eq procCommandUp(ME, M, 'down_:_[T, T'], VDS, DB)
= downTerm(procCommandUp(ME, M, T', VDS, DB)) .
eq procCommandUp(ME, M, 'red_.['bubble[T]], VDS, DB)
= downTerm(procRedUp(ME, M, 'bubble[T], VDS, DB)) .
eq procCommandUp(ME, M, 'reduce_.['bubble[T]], VDS, DB)
= downTerm(procRedUp(ME, M, 'bubble[T], VDS, DB)) .
eq procCommandUp(ME, M, 'rew_.['bubble[T]], VDS, DB)
= downTerm(procRewUp(ME, M, 'bubble[T], unbounded, VDS, DB)) .
eq procCommandUp(ME, M, 'rewrite_.['bubble[T]], VDS, DB)
= downTerm(procRewUp(ME, M, 'bubble[T], unbounded, VDS, DB)) .
eq procCommandUp(ME, M, 'frew_.['bubble[T]], VDS, DB)
= downTerm(procFrewUp(ME, M, 'bubble[T], unbounded, 0, VDS, DB)) .
eq procCommandUp(ME, M, 'frewrite_.['bubble[T]], VDS, DB)
= downTerm(procFrewUp(ME, M, 'bubble[T], unbounded, 0, VDS, DB)) .
ceq procRedUp(ME, M, T, VDS, DB)
= if metaReduce(getModule(TM), getTerm(TM)) :: ResultPair
then getTerm(metaReduce(getModule(TM), getTerm(TM)))
else qidError('\r 'Error: '\o 'Incorrect 'command. '\n)
fi
if TM := solveBubblesRed(T, M,
included('META-MODULE, getImports(getTopModule(ME, DB)), DB),
VDS, DB) .
ceq procRewUp(ME, M, T, D, VDS, DB)
= if metaRewrite(getModule(TMVB), getTerm(TMVB), getBound(TMVB))
:: ResultPair
then getTerm(metaRewrite(getModule(TMVB), getTerm(TMVB), getBound(TMVB)))
else qidError('\r 'Error: '\o 'Incorrect 'command. '\n)
fi
if TMVB := solveBubblesRew(T, M,
included('META-MODULE, getImports(getTopModule(ME, DB)), DB),
D, VDS, DB) .
ceq procFrewUp(ME, M, T, D, I, VDS, DB)
= if metaFrewrite(
getModule(TMVBN), getTerm(TMVBN), getBound(TMVBN), getNat(TMVBN))
:: ResultPair
then getTerm(
metaFrewrite(getModule(TMVBN), getTerm(TMVBN),
getBound(TMVBN), getNat(TMVBN)))
else qidError('\r 'Error: '\o 'Incorrect 'command. '\n)
fi
if TMVBN := solveBubblesFrew(T, M,
included('META-MODULE, getImports(getTopModule(ME, DB)), DB),
D, I, VDS, DB) .
ceq procParse(ME, M, T, VDS, DB)
= if leastSort(getModule(TM), getTerm(TM)) :: Type
then (eMetaPrettyPrint(leastSort(getModule(TM), getTerm(TM)))
'\s '\b ': '\o '\n '\s '\s
eMetaPrettyPrint(getModule(TM), getTerm(TM)) '\n)
else getMsg(getTerm(TM))
fi
if TM := solveBubblesRed(T, M,
included('META-MODULE, getImports(getTopModule(ME, DB)), DB),
VDS, DB) .
eq procParse(ME, unitError(QIL), T, VDS, DB) = QIL .
eq procParse(ME, noModule, T, VDS, DB) = getMsg(DB) .
ceq procRed(ME, M, T, VDS, DB)
= if metaReduce(getModule(TM), getTerm(TM)) :: ResultPair
then ('\b 'reduce 'in
'\o eMetaPrettyPrint(getName(getModule(TM))) '\b ': '\o '\n '\s '\s
eMetaPrettyPrint(getModule(TM), getTerm(TM)) '\n
'\b 'result '\o '\s
eMetaPrettyPrint(getType(metaReduce(getModule(TM), getTerm(TM))))
'\s '\b ': '\o '\n '\s '\s
eMetaPrettyPrint(getModule(TM),
getTerm(metaReduce(getModule(TM), getTerm(TM))))
'\n)
else getMsg(getTerm(metaReduce(getModule(TM), getTerm(TM))))
fi
if TM := solveBubblesRed(T, M,
included('META-MODULE, getImports(getTopModule(ME, DB)), DB),
VDS, DB) .
eq procRed(ME, unitError(QIL), T, VDS, DB) = QIL .
eq procRed(ME, noModule, T, VDS, DB) = getMsg(DB) .
eq metaReduce(unitError(QIL), T) = {qidError(QIL), '`[Term`]} .
eq metaReduce(U:[Module], qidError(QIL)) = {qidError(QIL), '`[Term`]} .
ceq solveBubblesRed('bubble[QI], M, B, VDS, DB)
= if T? :: Term
then {T?, M, B, VDS, DB}
else tupleTMBODerror('\r 'Error: '\o 'no 'parse 'for downQidList(QI) '\n)
fi
if T? := solveBubbles('bubble[QI], M, B, VDS, DB) .
ceq solveBubblesRed('bubble['__[TL]], M, B, VDS, DB)
= if T? :: Term
then {T?, M, B, VDS, DB}
else if metaParse(GRAMMAR-RED, downQidList('__[TL, ''..Qid]), '@RedInPart@) :: ResultPair
then solveBubblesRed2(
getTerm(metaParse(GRAMMAR-RED, downQidList('__[TL, ''..Qid]), '@RedInPart@)),
DB)
else tupleTMBODerror(
'\r 'Warning: '\o
printSyntaxError(
metaParse(GRAMMAR-RED, downQidList('__[TL, ''..Qid]),
'@RedInPart@), downQidList('__[TL, ''..Qid])) '\n
'\r 'Error: '\o
'no 'parse 'for downQidList('__[TL, ''..Qid]) '\n)
fi
fi
if T? := solveBubbles('bubble['__[TL]], M, B, VDS, DB) .
*** There is some problem parsing 'in_:_ in solveBubblesRed, but it
*** seems to work with the additional '.
ceq solveBubblesRed2('in_:_.[T, T'], DB)
= if unitInDb(ME, DB')
then solveBubblesRed3(T', getFlatModule(ME, DB'), ME, getVars(ME, DB'), DB')
else tupleTMBODerror('\r 'Error: '\o 'It 'is 'not 'possible 'to 'compile eMetaPrettyPrint(ME) '. '\n)
fi
if < DB' ; ME > := evalModExp(parseModExp(T), DB) .
eq solveBubblesRed2('in_:_.[T, T'], DB)
= tupleTMBODerror('\r 'Error: '\o 'It 'isn't 'possible 'to 'compile eMetaPrettyPrint(parseModExp(T)) '. '\n)
[owise] .
eq solveBubblesRed3(T, M, ME, VDS, DB)
= {solveBubbles(T, M,
included('META-MODULE, getImports(getTopModule(ME, DB)), DB),
VDS, DB),
M,
included('META-MODULE, getImports(getTopModule(ME, DB)), DB),
VDS,
DB} .
op GRAMMAR-RED : -> FModule [memo] .
eq GRAMMAR-RED
= addImports((including 'MOD-EXPRS .),
addSorts('@RedInPart@,
addOps((op 'in_:_. : '@ModExp@ '@Bubble@ -> '@RedInPart@ [none] .),
BUBBLES))) .
ceq procRew(ME, M, T, VDS, DB)
= if RP :: ResultPair
then ('\b 'rewrite 'in '\o eMetaPrettyPrint(getName(getModule(TMVB)))
'\b ': '\o '\n '\s '\s
eMetaPrettyPrint(getModule(TMVB), getTerm(TMVB)) '\n
'\b 'result '\o '\s
eMetaPrettyPrint(getType(RP))
'\s '\b ': '\o '\n '\s '\s
eMetaPrettyPrint(getModule(TMVB), getTerm(RP))
'\n)
else getMsg(getTerm(TMVB))
fi
if TMVB := solveBubblesRew(T, M,
included('META-MODULE, getImports(getTopModule(ME, DB)), DB),
unbounded, VDS, DB)
/\ RP := metaRewrite(getModule(TMVB), getTerm(TMVB), getBound(TMVB)) .
eq procRew(ME, unitError(QIL), T, VDS, DB) = qidError(QIL) .
eq solveBubblesRew('bubble[QI], M, B, D, VDS, DB)
= if solveBubbles('bubble[QI], M, B, VDS, DB) :: Term
then {solveBubbles('bubble[QI], M, B, VDS, DB), M, B, VDS, unbounded, DB}
else tupleTMBOBDerror(
'\r 'Error: '\o 'no 'parsing 'for downQidList(QI) '\n)
fi .
eq solveBubblesRew('bubble['__[TL]], M, B, D, VDS, DB)
= if solveBubbles('bubble['__[TL]], M, B, VDS, DB) :: Term
then {solveBubbles('bubble['__[TL]], M, B, VDS, DB), M, B, VDS, unbounded, DB}
else if metaParse(GRAMMAR-REW, downQidList('__[TL, ''..Qid]), '@RewNuPart@)
:: ResultPair
then solveBubblesRew2(
getTerm(
metaParse(GRAMMAR-REW, downQidList('__[TL, ''..Qid]),
'@RewNuPart@)),
M, B, VDS, DB)
else {getTerm(solveBubblesRed('bubble['__[TL]], M, B, VDS, DB)),
getModule(solveBubblesRed('bubble['__[TL]], M, B, VDS, DB)),
getBool(solveBubblesRed('bubble['__[TL]], M, B, VDS, DB)),
getVars(solveBubblesRed('bubble['__[TL]], M, B, VDS, DB)),
unbounded,
getDatabase(solveBubblesRed('bubble['__[TL]], M, B, VDS, DB))}
fi
fi .
eq solveBubblesRew2('`[_`]_.['token[T], T'], M, B, VDS, DB)
= if downNat(downMetaNat(T)) :: Nat
and-then solveBubblesRed(T', M, B, VDS, DB)
:: Tuple{Term,Module,Bool,OpDeclSet,Database}
then {getTerm(solveBubblesRed(T', M, B, VDS, DB)),
getModule(solveBubblesRed(T', M, B, VDS, DB)),
getBool(solveBubblesRed(T', M, B, VDS, DB)),
getVars(solveBubblesRed(T', M, B, VDS, DB)),
downNat(downMetaNat(T)),
getDatabase(solveBubblesRed(T', M, B, VDS, DB))}
else tupleTMBOBDerror(
'\r 'Error: '\o 'Incorrect 'command. '\n)
fi .
op GRAMMAR-REW : -> FModule [memo] .
eq GRAMMAR-REW
= addSorts('@RewNuPart@ ; '@Token@ ; '@SortToken@ ; '@ViewToken@ ; '@NeTokenList@ ; '@Bubble@,
addOps((op '`[_`]_. : '@Token@ '@Bubble@ -> '@RewNuPart@ [none] .),
BUBBLES)) .
---- eq metaRewrite(fmod QI is IL sorts SS . SSDS OPDS MAS EqS endfm, T, D)
---- = metaReduce(fmod QI is IL sorts SS . SSDS OPDS MAS EqS endfm, T) .
---- eq metaRewrite(M, T, 0) = {T, leastSort(M, T)} .
*** FREW
ceq procFrew(ME, M, T, D, I, VDS, DB)
= if RP :: ResultPair
then ('\b 'frewrite 'in '\o eMetaPrettyPrint(getName(getModule(TMVBN)))
'\b ': '\o '\n '\s '\s
eMetaPrettyPrint(getModule(TMVBN), getTerm(TMVBN)) '\n
'\b 'result '\o '\s eMetaPrettyPrint(getType(RP))
'\s '\b ': '\o '\n '\s '\s
eMetaPrettyPrint(getModule(TMVBN), getTerm(RP)) '\n)
else ('\r 'Error: '\o 'Incorrect 'command. '\n)
fi
if TMVBN := solveBubblesFrew(T, M,
included('META-MODULE, getImports(getTopModule(ME, DB)), DB),
D, I, VDS, DB)
/\ RP := metaFrewrite(getModule(TMVBN), getTerm(TMVBN),
getBound(TMVBN), getNat(TMVBN)) .
eq procFrew(ME, unitError(QIL), T, D, I, VDS, DB) = qidError(QIL) .
eq solveBubblesFrew('bubble[QI], M, B, D, I, VDS, DB)
= if solveBubbles('bubble[QI], M, B, VDS, DB) :: Term
then {solveBubbles('bubble[QI], M, B, VDS, DB), M, VDS, unbounded, I}
else tupleTMOBNerror(
'\r 'Error: '\o 'no 'parse 'for downQidList(QI) '\n)
fi .
eq solveBubblesFrew('bubble['__[TL]], M, B, D, I, VDS, DB)
= if solveBubbles('bubble['__[TL]], M, B, VDS, DB) :: Term
then {solveBubbles('bubble['__[TL]], M, B, VDS, DB),
M, VDS, unbounded, I}
else if metaParse(GRAMMAR-FREW, downQidList('__[TL, ''..Qid]),
'@FrewNuPart@)
:: ResultPair
then solveBubblesFrew2(
getTerm(
metaParse(GRAMMAR-FREW, downQidList('__[TL, ''..Qid]),
'@FrewNuPart@)),
M, B, I, VDS, DB)
else {getTerm(solveBubblesRed('bubble['__[TL]], M, B, VDS, DB)),
getModule(solveBubblesRed('bubble['__[TL]], M, B, VDS, DB)),
getVars(solveBubblesRed('bubble['__[TL]], M, B, VDS, DB)),
unbounded, I}
fi
fi .
*** There is some problem parsing _ in solveBubblesRed, but it
*** seems to work with the additional '.
eq solveBubblesFrew2('`[_`]_.['token[T], T'], M, B, I, VDS, DB)
= if downNat(downMetaNat(T)) :: Nat
and-then solveBubblesRed(T', M, B, VDS, DB)
:: Tuple{Term,Module,Bool,OpDeclSet,Database}
then {getTerm(solveBubblesRed(T', M, B, VDS, DB)),
getModule(solveBubblesRed(T', M, B, VDS, DB)),
getVars(solveBubblesRed(T', M, B, VDS, DB)),
downNat(downMetaNat(T)),
I}
else tupleTMOBNerror(
'\r 'Error: '\o 'Incorrect 'command. '\n)
fi .
eq solveBubblesFrew2('`[_`,_`]_.['token[T], 'token[T'], T''],
M, B, I, VDS, DB)
= if downNat(downMetaNat(T)) :: Nat
and-then downNat(downMetaNat(T')) :: Nat
and-then solveBubblesRed(T'', M, B, VDS, DB)
:: Tuple{Term,Module,Bool,OpDeclSet,Database}
then {getTerm(solveBubblesRed(T'', M, B, VDS, DB)),
getModule(solveBubblesRed(T'', M, B, VDS, DB)),
getVars(solveBubblesRed(T'', M, B, VDS, DB)),
downNat(downMetaNat(T)),
downNat(downMetaNat(T'))}
else tupleTMOBNerror('\r 'Error: '\o 'Incorrect 'command. '\n)
fi .
op GRAMMAR-FREW : -> FModule [memo] .
eq GRAMMAR-FREW
= addSorts('@FrewNuPart@ ; '@Token@ ; '@SortToken@ ; '@ViewToken@ ; '@NeTokenList@ ; '@Bubble@,
addOps(
(op '`[_`]_. : '@Token@ '@Bubble@ -> '@FrewNuPart@ [none] .
op '`[_`,_`]_. : '@Token@ '@Token@ '@Bubble@ -> '@FrewNuPart@ [none] .),
BUBBLES)) .
eq metaFrewrite(fmod QI is IL sorts SS . SSDS OPDS MAS EqS endfm, T, D, I)
= metaReduce(fmod QI is IL sorts SS . SSDS OPDS MAS EqS endfm, T) .
eq metaFrewrite(M, T, 0, I) = {T, leastSort(M, T)} .
eq metaFrewrite(M, T, D, 0) = {T, leastSort(M, T)} .
*** SEARCH
op GRAMMAR-SEARCH : -> FModule [memo] .
eq GRAMMAR-SEARCH
= addSorts('@SearchNuPart@ ; '@Token@ ; '@SortToken@ ; '@ViewToken@ ; '@NeTokenList@ ; '@Bubble@,
addOps((op '`[_`,_`]_. : '@Token@ '@Token@ '@Bubble@ -> '@SearchNuPart@ [none] .)
(op '`[`,_`]_. : '@Token@ '@Bubble@ -> '@SearchNuPart@ [none] .),
BUBBLES)) .
ceq procSearch(ME, M, T, T', QI, D, D', VDS, DB)
*** D is a bound on the number of solutions, and D' is a bound on the depth of the search
= if solveBubblesRl(T, T', M, B, VDS, DB) :: Term
then procSearch2(addOps(VDS, M),
lhs(solveBubblesRl(T, T', M, B, VDS, DB)),
rhs(solveBubblesRl(T, T', M, B, VDS, DB)), nil, QI, D, D')
else solveBubblesSearchL(M, T, T', QI, D, D', B, VDS, DB)
fi
if B := included('META-MODULE, getImports(getTopModule(ME, DB)), DB) .
eq solveBubblesSearchL(M, 'bubble[QI], T, QI', D, D', B, VDS, DB)
= if solveBubbles('bubble[QI], M, B, VDS, DB) :: Term
then solveBubblesSearchR(M, solveBubbles('bubble[QI], M, B, VDS, DB), T, QI', D, D', B, VDS, DB)
else ('\r 'Error: '\o 'no 'parsing 'for downQidList(QI) '\n)
fi .
eq solveBubblesSearchL(M, 'bubble['__[TL]], T, QI, D, D', B, VDS, DB)
= if solveBubbles('bubble['__[TL]], M, B, VDS, DB) :: Term
then solveBubblesSearchR(M, solveBubbles('bubble['__[TL]], M, B, VDS, DB), T, QI, D, D', B, VDS, DB)
else if metaParse(GRAMMAR-SEARCH, downQidList('__[TL, ''..Qid]), '@SearchNuPart@) :: ResultPair
then solveBubblesSearchL1(
M,
getTerm(metaParse(GRAMMAR-SEARCH, downQidList('__[TL, ''..Qid]), '@SearchNuPart@)),
T, QI, D, D', B, VDS, DB)
else solveBubblesSearchR(
getModule(solveBubblesRew('bubble['__[TL]], M, B, D, VDS, DB)),
getTerm(solveBubblesRew('bubble['__[TL]], M, B, D, VDS, DB)),
T,
QI,
getBound(solveBubblesRew('bubble['__[TL]], M, B, D, VDS, DB)),
D',
getBool(solveBubblesRew('bubble['__[TL]], M, B, D, VDS, DB)),
getVars(solveBubblesRew('bubble['__[TL]], M, B, D, VDS, DB)),
getDatabase(solveBubblesRew('bubble['__[TL]], M, B, D, VDS, DB)))
fi
fi .
eq solveBubblesSearchL1(M, '`[`,_`]_.['token[T], T'], T'', QI, D, D', B, VDS, DB)
= if downNat(downMetaNat(T)) :: Nat
and-then solveBubblesRed(T', M, B, VDS, DB) :: Tuple{Term,Module,Bool,OpDeclSet,Database}
then solveBubblesSearchR(
getModule(solveBubblesRed(T', M, B, VDS, DB)),
getTerm(solveBubblesRed(T', M, B, VDS, DB)),
T'', QI, D,
downNat(downMetaNat(T)),
B,
getVars(solveBubblesRed(T', M, B, VDS, DB)),
DB)
else ('\r 'Error: '\o 'Incorrect 'command. '\n)
fi .
eq solveBubblesSearchL1(M, '`[_`,_`]_.['token[T], 'token[T'], T''], T''', QI, D, D', B, VDS, DB)
= if downNat(downMetaNat(T)) :: Nat
and-then downNat(downMetaNat(T')) :: Nat
and-then solveBubblesRed(T'', M, B, VDS, DB) :: Tuple{Term,Module,Bool,OpDeclSet,Database}
then solveBubblesSearchR(
getModule(solveBubblesRed(T'', M, B, VDS, DB)),
getTerm(solveBubblesRed(T'', M, B, VDS, DB)),
T''', QI,
downNat(downMetaNat(T)),
downNat(downMetaNat(T')),
B,
getVars(solveBubblesRed(T'', M, B, VDS, DB)),
DB)
else ('\r 'Error: '\o 'Incorrect 'command. '\n)
fi .
eq solveBubblesSearchR(M, T, T', QI, D, D', B, VDS, DB)
= solveBubblesSearchR1(
M,
addOps(
op '_s.t._. : leastSort(M, T) '@Condition@ -> 'PatternCondition [none] .
op '_such`that_. : leastSort(M, T) '@Condition@ -> 'PatternCondition [none] .,
addSorts('PatternCondition, addInfoConds(M))),
T,
T',
QI,
D,
D',
B,
VDS,
DB) .
eq solveBubblesSearchR(M:[Module], T:[Term], T':[Term], QI:[Qid], D:[Bound], D':[Bound], B:[Bool], VDS:[OpDeclSet], DB:[Database])
= ('\r 'Error: '\o 'Incorrect 'use 'of 'the 'search 'command. '\n) .
ceq solveBubblesSearchR1(M, M', T, 'bubble[QI], QI', D, D', B, VDS, DB)
= if T?:[Term] :: Term
then procSearch2(M, T, T?:[Term], nil, QI', D, D')
else ('\r 'Error: '\o 'Incorrect 'use 'of 'the 'search 'command. '\n)
fi
if T?:[Term] := solveBubbles('bubble[QI], M, B, VDS, DB) .
ceq solveBubblesSearchR1(M, M', T, 'bubble['__[TL]], QI, D, D', B, VDS, DB)
= if T?:[Term] :: Term
then procSearch2(M, T, T?:[Term], nil, QI, D, D')
else if metaParse(M', downQidList('__[TL, ''..Qid]), 'PatternCondition)
:: ResultPair
then solveBubblesSearchR2(M, T,
getTerm(
metaParse(M', downQidList('__[TL, ''..Qid]),
'PatternCondition)),
QI, D, D', VDS)
else '\r 'Error: '\o 'Incorrect 'use 'of 'the 'search 'command. '\n
fi
fi
if T?:[Term] := solveBubbles('bubble['__[TL]], M, B, VDS, DB) .
eq solveBubblesSearchR2(M, T, QI, QI', D, D', VDS)
= procSearch2(M, T, constsToVars(QI, VDS), nil, QI', D, D') .
eq solveBubblesSearchR2(M, T, F[T], QI, D, D', VDS)
= procSearch2(M, T, constsToVars(F[T], VDS), nil, QI, D, D') .
eq solveBubblesSearchR2(M, T, F[T', T''], QI, D, D', VDS)
= if F == '_s.t._. or F == '_such`that_.
then procSearch2(M, T, T', parseCond(T'', VDS), QI, D, D')
else procSearch2(M, T, constsToVars(F[T', T''], VDS), nil, QI, D, D')
fi .
eq solveBubblesSearchR2(M, T, F[T', T'', TL], QI, D, D', VDS)
= procSearch2(M, T, constsToVars(F[T', T'', TL], VDS), nil, QI, D, D') .
ceq procSearch2(M, T, T', CD, QI, D, D')
= if RT :: ResultTriple
then ('search
if D == unbounded and D' == unbounded
then nil
else '\s '`[
if D == unbounded
then nil
else qid(string(D, 10))
fi
if D' == unbounded
then nil
else '`, qid(string(D', 10))
fi
'`] '\s
fi
'in eMetaPrettyPrint(getName(M)) ':
eMetaPrettyPrint(M, T) '\s qid("=>" + string(QI)) '\s
eMetaPrettyPrint(M, T'') '. '\n '\n
'Solution '1 '\n
if gTSubstitution(RT) == none
then 'empty 'substitution '\n '\n
else eMetaPrettyPrint(M, gTSubstitution(RT)) '\n '\n
fi
procSearch3(M, T, T'', CD, QI, D, 1, D'))
else if RT == failure
then ('search
if D == unbounded and D' == unbounded
then nil
else '\s '`[
if D == unbounded
then nil
else qid(string(D, 10))
fi
if D' == unbounded
then nil
else '`, qid(string(D', 10))
fi
'`] '\s
fi
'in eMetaPrettyPrint(getName(M)) ':
eMetaPrettyPrint(M, T)
'\s qid("=>" + string(QI)) '\s
eMetaPrettyPrint(M, T'') '. '\n '\n
'No 'solution. '\n)
else '\r 'Error: '\o 'Incorrect 'use 'of 'the 'search 'command. '\n
fi
fi
if T'' := prepSearchPattern(T')
/\ RT := metaSearch(M, T, T'', CD, QI, D', 0) .
eq procSearch3(M, T, T', CD, QI, D, I, D')
= if D == unbounded or-else (D == 0 or-else I < D)
then if metaSearch(M, T, T', CD, QI, D', I) :: ResultTriple
then ('Solution qid(string(I + 1, 10)) '\n
if gTSubstitution(metaSearch(M, T, T', CD, QI, D', I)) == none
then 'empty 'substitution '\n '\n
else eMetaPrettyPrint(M,
gTSubstitution(
metaSearch(M, T, T', CD, QI, D', I))) '\n '\n
fi
procSearch3(M, T, T', CD, QI, D, I + 1, D'))
else ('No 'more 'solutions. '\n)
fi
else nil
fi .
-------------------
*** Equal to procSearch except replacing metaSearch by metaNarrowSearch
ceq procNarrowSearch(ME, M, T, T', QI, D, D', VDS, DB)
*** D is a bound on the number of solutions, and D' is a bound on the depth of the search
= if solveBubblesRl(T, T', M, B, VDS, DB) :: Term
then procNarrowSearch2(addOps(VDS, M),
lhs(solveBubblesRl(T, T', M, B, VDS, DB)),
rhs(solveBubblesRl(T, T', M, B, VDS, DB)), nil, QI, D, D')
else solveBubblesNarrowSearchL(M, T, T', QI, D, D', B, VDS, DB)
fi
if B := included('META-MODULE, getImports(getTopModule(ME, DB)), DB) .
eq solveBubblesNarrowSearchL(M, 'bubble[QI], T, QI, D, D', B, VDS, DB)
= if solveBubbles('bubble[QI], M, B, VDS, DB) :: Term
then solveBubblesNarrowSearchR(M, solveBubbles('bubble[QI], M, B, VDS, DB), T, QI, D, D', B, VDS, DB)
else ('\r 'Error: '\o 'no 'parsing 'for downQidList(QI) '\n)
fi .
eq solveBubblesNarrowSearchL(M, 'bubble['__[TL]], T, QI, D, D', B, VDS, DB)
= if solveBubbles('bubble['__[TL]], M, B, VDS, DB) :: Term
then solveBubblesNarrowSearchR(M, solveBubbles('bubble['__[TL]], M, B, VDS, DB), T, QI, D, D', B, VDS, DB)
else if metaParse(GRAMMAR-SEARCH, downQidList('__[TL, ''..Qid]), '@SearchNuPart@) :: ResultPair
then solveBubblesNarrowSearchL1(
M,
getTerm(
metaParse(GRAMMAR-SEARCH, downQidList('__[TL, ''..Qid]),
'@SearchNuPart@)),
T, QI, D, D', B, VDS, DB)
else solveBubblesNarrowSearchR(
getModule(solveBubblesRew('bubble['__[TL]], M, B, D, VDS, DB)),
getTerm(solveBubblesRew('bubble['__[TL]], M, B, D, VDS, DB)),
T,
QI,
getBound(solveBubblesRew('bubble['__[TL]], M, B, D, VDS, DB)),
D',
getBool(solveBubblesRew('bubble['__[TL]], M, B, D, VDS, DB)),
getVars(solveBubblesRew('bubble['__[TL]], M, B, D, VDS, DB)),
getDatabase(solveBubblesRew('bubble['__[TL]], M, B, D, VDS, DB)))
fi
fi .
eq solveBubblesNarrowSearchL1(M, '`[`,_`]_.['token[T], T'], T'', QI, D, D', B, VDS, DB)
= if downNat(downMetaNat(T)) :: Nat
and-then solveBubblesRed(T', M, B, VDS, DB) :: Tuple{Term,Module,Bool,OpDeclSet,Database}
then solveBubblesNarrowSearchR(
getModule(solveBubblesRed(T', M, B, VDS, DB)),
getTerm(solveBubblesRed(T', M, B, VDS, DB)),
T'', QI, D,
downNat(downMetaNat(T)),
B,
getVars(solveBubblesRed(T', M, B, VDS, DB)),
DB)
else ('\r 'Error: '\o 'Incorrect 'command. '\n)
fi .
eq solveBubblesNarrowSearchL1(M, '`[_`,_`]_.['token[T], 'token[T'], T''], T''', QI, D, D', B, VDS, DB)
= if downNat(downMetaNat(T)) :: Nat
and-then downNat(downMetaNat(T')) :: Nat
and-then solveBubblesRed(T'', M, B, VDS, DB) :: Tuple{Term,Module,Bool,OpDeclSet,Database}
then solveBubblesNarrowSearchR(
getModule(solveBubblesRed(T'', M, B, VDS, DB)),
getTerm(solveBubblesRed(T'', M, B, VDS, DB)),
T''', QI,
downNat(downMetaNat(T)),
downNat(downMetaNat(T')),
B,
getVars(solveBubblesRed(T'', M, B, VDS, DB)),
DB)
else ('\r 'Error: '\o 'Incorrect 'command. '\n)
fi .
eq solveBubblesNarrowSearchR(M, T, T', QI, D, D', B, VDS, DB)
= solveBubblesNarrowSearchR1(
M,
addOps(
op '_s.t._. : leastSort(M, T) '@Condition@ -> 'PatternCondition [none] .
op '_such`that_. : leastSort(M, T) '@Condition@ -> 'PatternCondition [none] .,
addSorts('PatternCondition, addInfoConds(M))),
T,
T',
QI,
D,
D',
B,
VDS,
DB) .
eq solveBubblesNarrowSearchR(M:[Module], T:[Term], T':[Term], QI:[Qid], D:[Bound], D':[Bound], B:[Bool], VDS:[OpDeclSet], DB:[Database])
= qidError('\r 'Error: '\o 'Incorrect 'use 'of 'the 'search 'command. '\n) .
ceq solveBubblesNarrowSearchR1(M, M', T, 'bubble[QI], QI', D, D', B, VDS, DB)
= if T?:[Term] :: Term
then procNarrowSearch2(M, T, T?:[Term], nil, QI', D, D')
else ('\r 'Error: '\o 'Incorrect 'use 'of 'the 'search 'command. '\n)
fi
if T?:[Term] := solveBubbles('bubble[QI], M, B, VDS, DB) .
ceq solveBubblesNarrowSearchR1(M, M', T, 'bubble['__[TL]], QI, D, D', B, VDS, DB)
= if T?:[Term] :: Term
then procNarrowSearch2(M, T, T?:[Term], nil, QI, D, D')
else if metaParse(M', downQidList('__[TL, ''..Qid]), 'PatternCondition)
:: ResultPair
then solveBubblesNarrowSearchR2(M, T,
getTerm(
metaParse(M', downQidList('__[TL, ''..Qid]),
'PatternCondition)),
QI, D, D', VDS)
else '\r 'Error: '\o 'Incorrect 'use 'of 'the 'search 'command. '\n
fi
fi
if T?:[Term] := solveBubbles('bubble['__[TL]], M, B, VDS, DB) .
eq solveBubblesNarrowSearchR2(M, T, QI, QI', D, I, VDS)
= procNarrowSearch2(M, T, constsToVars(QI, VDS), nil, QI', D, I) .
eq solveBubblesNarrowSearchR2(M, T, F[T], QI, D, I, VDS)
= procNarrowSearch2(M, T, constsToVars(F[T], VDS), nil, QI, D, I) .
eq solveBubblesNarrowSearchR2(M, T, F[T', T''], QI, D, I, VDS)
= if F == '_s.t._. or F == '_such`that_.
then procNarrowSearch2(M, T, T', parseCond(T'', VDS), QI, D, I)
else procNarrowSearch2(M, T, constsToVars(F[T', T''], VDS), nil, QI, D, I)
fi .
eq solveBubblesNarrowSearchR2(M, T, F[T', T'', TL], QI, D, I, VDS)
= procNarrowSearch2(M, T, constsToVars(F[T', T'', TL], VDS), nil, QI, D, I) .
ceq procNarrowSearch2(M, T, T', CD, QI, D, D')
= if RTS:[ResultTripleSet] :: ResultTripleSet
then ('search
if D == unbounded and D' == unbounded
then nil
else '\s '`[
if D == unbounded
then nil
else qid(string(D, 10))
fi
if D' == unbounded
then nil
else '`, qid(string(D', 10))
fi
'`] '\s
fi
'in eMetaPrettyPrint(getName(M)) ':
eMetaPrettyPrint(M, T) '\s qid("~>" + string(QI)) '\s
eMetaPrettyPrint(M, T'') '.
procNarrowSearch3(M, 0, Vars((T,T')), RTS:[ResultTripleSet]))
else if RTS:[ResultTripleSet] == empty
then ('search
if D == unbounded and D' == unbounded
then nil
else '\s '`[
if D == unbounded
then nil
else qid(string(D, 10))
fi
if D' == unbounded
then nil
else '`, qid(string(D', 10))
fi
'`] '\s
fi
'in eMetaPrettyPrint(getName(M)) ':
eMetaPrettyPrint(M, T)
'\s qid("~>" + string(QI)) '\s
eMetaPrettyPrint(M, T'') '. '\n '\n
'No 'solution. '\n)
else '\r 'Error: '\o 'Incorrect 'use 'of 'the 'search 'command. '\n
fi
fi
if T'' := prepSearchPattern(T')
/\ RTS:[ResultTripleSet]
:= upDown(M,
metaNarrowSearchGen(M, T, T'', none, typeOfRelation(QI), D', D,
full AC-unify noStrategy E-normalize-terms)
|> (T,T'')
) .
eq procNarrowSearch3(M, I, TL:TermList, empty)
= ('\n '\n 'No 'more 'solutions.) .
eq procNarrowSearch3(M, I, TL:TermList, {T:Term,TP:Type,S:Substitution} | RTS:ResultTripleSet)
= ('\n '\n 'Solution qid(string(I + 1, 10))
if (S:Substitution |> TL:TermList) == none
then '\n 'empty 'substitution
else '\n eMetaPrettyPrint(M, S:Substitution |> TL:TermList)
fi
procNarrowSearch3(M, I + 1, TL:TermList, RTS:ResultTripleSet)) .
-------------------
sort Tuple{TermList, Nat} .
op <_;_> : Term Nat -> Tuple{TermList, Nat} .
op term : Tuple{TermList, Nat} -> TermList .
op index : Tuple{TermList, Nat} -> Nat .
eq term(< TL:[TermList] ; I:[Nat] >) = TL:[TermList] .
eq index(< TL:[TermList] ; I:[Nat] >) = I:[Nat] .
op prepSearchPattern : Term -> Term .
op prepSearchPattern : TermList Nat -> Tuple{TermList, Nat} .
eq prepSearchPattern(T) = term(prepSearchPattern(T, 0)) .
eq prepSearchPattern('<_:_|_>[O, Ct, T], I)
= < '<_:_|_>[O, qid("V#" + string(I, 10) + ":" + string(getName(Ct))),
'_`,_[term(prepSearchPattern(T, s s I)),
qid("V#" + string(s I, 10) + ":AttributeSet")]] ;
index(prepSearchPattern(T, s s I)) > .
eq prepSearchPattern('<_:_|`>[O, Ct], I)
= < '<_:_|_>[O, qid("V#" + string(I, 10) + ":" + string(getName(Ct))),
qid("V#" + string(s I, 10) + ".AttributeSet")] ;
s I > .
eq prepSearchPattern(F[TL], I)
= < F[term(prepSearchPattern(TL, I))] ;
index(prepSearchPattern(TL, I)) >
[owise] .
eq prepSearchPattern(F, I) = < F ; I > .
eq prepSearchPattern(Ct, I) = < Ct ; I > .
ceq prepSearchPattern((T, TL), I)
= < (term(prepSearchPattern(T, I)),
term(prepSearchPattern(TL, index(prepSearchPattern(T, I))))) ;
index(prepSearchPattern(TL, index(prepSearchPattern(T, I)))) >
if TL =/= empty .
*** MATCH
ceq procMatch(ME, M, T, T', QI, I, VDS, DB)
*** the number I in search is not a bound, but the number of solutions
= if solveBubblesRl(T, T', M, B, VDS, DB) :: Term
then procMatch2(addOps(VDS, M),
lhs(solveBubblesRl(T, T', M, B, VDS, DB)),
rhs(solveBubblesRl(T, T', M, B, VDS, DB)), nil, QI, I)
else if solveBubblesRew(T, M, B, I, VDS, DB)
:: Tuple{Term,Module,Bool,OpDeclSet,Bound,Database}
then solveBubblesMatch(
getModule(solveBubblesRew(T, M, B, I, VDS, DB)),
addOps(
op '_s.t._. :
leastSort(
getModule(solveBubblesRew(T, M, B, I, VDS, DB)),
getTerm(solveBubblesRew(T, M, B, I, VDS, DB)))
'@Condition@ -> 'PatternCondition [none] .
op '_such`that_. :
leastSort(
getModule(solveBubblesRew(T, M, B, I, VDS, DB)),
getTerm(solveBubblesRew(T, M, B, I, VDS, DB)))
'@Condition@ -> 'PatternCondition [none] .,
addSorts('PatternCondition,
addInfoConds(
getModule(solveBubblesRew(T, M, B, I, VDS, DB))))),
getTerm(solveBubblesRew(T, M, B, I, VDS, DB)),
T',
QI,
(if getBound(solveBubblesRew(T, M, B, I, VDS, DB))
== unbounded
then 0
else getBound(solveBubblesRew(T, M, B, I, VDS, DB))
fi),
B,
getVars(solveBubblesRew(T, M, B, I, VDS, DB)),
DB)
else getMsg(getTerm(solveBubblesRew(T, M, B, I, VDS, DB)))
----('\r 'Error: '\o 'Incorrect 'match 'command. '\n)
fi
fi
if B := included('META-MODULE, getImports(getTopModule(ME, DB)), DB) .
ceq solveBubblesMatch(M, M', T, 'bubble[QI], QI', I, B, VDS, DB)
= if T?:[Term] :: Term
then procMatch2(M, T, T?:[Term], nil, QI', I)
else ('\r 'Error: '\o 'Incorrect 'use 'of 'the 'match 'command. '\n)
fi
if T?:[Term] := solveBubbles('bubble[QI], M, B, VDS, DB) .
ceq solveBubblesMatch(M, M', T, 'bubble['__[TL]], QI, I, B, VDS, DB)
= if T?:[Term] :: Term
then procMatch2(M, T, T?:[Term], nil, QI, I)
else if metaParse(M', downQidList('__[TL, ''..Qid]), 'PatternCondition)
:: ResultPair
then solveBubblesMatch2(M, T,
getTerm(
metaParse(M', downQidList('__[TL, ''..Qid]),
'PatternCondition)),
QI, I, VDS)
else '\r 'Error: '\o 'Incorrect 'use 'of 'the 'match 'command. '\n
fi
fi
if T?:[Term] := solveBubbles('bubble['__[TL]], M, B, VDS, DB) .
eq solveBubblesMatch2(M, T, QI, QI', I, VDS)
= procMatch2(M, T, constsToVars(QI, VDS), nil, QI', I) .
eq solveBubblesMatch2(M, T, F[T], QI, I, VDS)
= procMatch2(M, T, constsToVars(F[T], VDS), nil, QI, I) .
eq solveBubblesMatch2(M, T, F[T', T''], QI, I, VDS)
= if F == '_s.t._. or F == '_such`that_.
then procMatch2(M, T, T', parseCond(T'', VDS), QI, I)
else procMatch2(M, T, constsToVars(F[T', T''], VDS), nil, QI, I)
fi .
eq solveBubblesMatch2(M, T, F[T', T'', TL], QI, I, VDS)
= procMatch2(M, T, constsToVars(F[T', T'', TL], VDS), nil, QI, I) .
ceq procMatch2(M, T, T', CD, 'match, I)
= if Sb? :: Substitution
then ('match
if I == 0 then nil else '\s '`[ qid(string(I, 10)) '`] '\s fi
'in eMetaPrettyPrint(getName(M)) ':
eMetaPrettyPrint(M, T) '\s '<=? '\s eMetaPrettyPrint(M, T') '. '\n '\n
'Solution '1 '\n
if Sb? == none
then 'empty 'substitution
else eMetaPrettyPrint(M, Sb?)
fi
procMatch3(M, T, T', CD, 'match, I, 1))
else if Sb? == noMatch
then ('match
if I == 0
then nil
else '\s '`[ qid(string(I, 10)) '`] '\s
fi
'in eMetaPrettyPrint(getName(M)) ':
eMetaPrettyPrint(M, T) '\s '<=? '\s
eMetaPrettyPrint(M, T') '. '\n '\n
'No 'solution. '\n)
else '\r 'Error: '\o 'Incorrect 'use 'of 'the 'match 'command. '\n
fi
fi
if Sb? := metaMatch(M, T, T', CD, 0) .
ceq procMatch2(M, T, T', CD, 'xmatch, I)
= if MP? :: MatchPair
then ('xmatch
if I == 0 then nil else '\s '`[ qid(string(I, 10)) '`] '\s fi
'in eMetaPrettyPrint(getName(M)) ':
eMetaPrettyPrint(M, T) '\s '<=? '\s eMetaPrettyPrint(M, T') '. '\n '\n
'Solution '1 '\n
if gTSubstitution(MP?) == none
then 'empty 'substitution
else eMetaPrettyPrint(M, gTSubstitution(MP?))
fi '\n '\n
procMatch3(M, T, T', CD, 'xmatch, I, 1))
else if MP? == noMatch
then ('xmatch
if I == 0
then nil
else '\s '`[ qid(string(I, 10)) '`] '\s
fi
'in eMetaPrettyPrint(getName(M)) ':
eMetaPrettyPrint(M, T) '\s '<=? '\s
eMetaPrettyPrint(M, T') '. '\n '\n
'No 'solution. '\n)
else '\r 'Error: '\o 'Incorrect 'use 'of 'the 'xmatch 'command. '\n
fi
fi
if MP? := metaXmatch(M, T, T', CD, 0, unbounded, 0) .
eq procMatch3(M, T, T', CD, 'match, I, J)
= if I == 0 or J < I
then if metaMatch(M, T, T', CD, J) :: Substitution
then ('Solution qid(string(J + 1, 10)) '\n
if metaMatch(M, T, T', CD, J) == none
then 'empty 'substitution
else eMetaPrettyPrint(M, metaMatch(M, T, T', CD, J))
fi '\n '\n
procMatch3(M, T, T', CD, 'match, I, J + 1))
else ('No 'more 'solutions. '\n)
fi
else nil
fi .
eq procMatch3(M, T, T', CD, 'xmatch, I, J)
= if I == 0 or J < I
then if metaXmatch(M, T, T', CD, 0, unbounded, J) :: MatchPair
then ('Solution qid(string(J + 1, 10)) '\n
if gTSubstitution(metaXmatch(M, T, T', CD, 0, unbounded, J))
== none
then 'empty 'substitution
else eMetaPrettyPrint(M,
gTSubstitution(
metaXmatch(M, T, T', CD, 0, unbounded, J)))
fi '\n '\n
procMatch3(M, T, T', CD, 'xmatch, I, J + 1))
else ('No 'more 'solutions. '\n)
fi
else nil
fi .
*** UNIFY
ceq procUnify(ME, M, T, D, VDS, DB)
*** D is a bound on the number of solutions
= if solveBubblesRewUnify(T, addInfoUnify(M), B, D, VDS, DB)
:: Tuple{Term,Module,Bool,OpDeclSet,Bound,Database}
then procUnify2(
getModule(solveBubblesRewUnify(T, addInfoUnify(M), B, D, VDS, DB)),
parseUnify(
getTerm(solveBubblesRewUnify(T, addInfoUnify(M), B, D, VDS, DB)),
getVars(solveBubblesRewUnify(T, addInfoUnify(M), B, D, VDS, DB))),
getBound(solveBubblesRewUnify(T, addInfoUnify(M), B, D, VDS, DB)))
else getMsg(getTerm(solveBubblesRewUnify(T, addInfoUnify(M), B, D, VDS, DB)))
----('\r 'Error: '\o 'Incorrect 'match 'command. '\n)
fi
if B := included('META-MODULE, getImports(getTopModule(ME, DB)), DB) .
eq addInfoUnify(M)
= addOps(op '_/\_ : '@UnificationProblem@ '@UnificationProblem@ -> '@UnificationProblem@
[ctor assoc prec(73)] .
op '_=?_ : 'Universal 'Universal -> '@UnificationProblem@
[ctor poly(1 2) prec(71)] .,
addSorts('@UnificationProblem@, M)) .
eq parseUnify('_/\_[T, T'], VDS) = parseUnify(T, VDS) /\ parseUnify(T', VDS) .
eq parseUnify('_=?_[T, T'], VDS) = constsToVars(T, VDS) =? constsToVars(T', VDS) .
ceq procUnify2(M, UP, D)
= if UP? :: UnificationPair?
then ('unify
if D == unbounded then nil else '\s '`[ qid(string(D, 10)) '`] '\s fi
'in eMetaPrettyPrint(getName(M)) ':
eMetaPrettyPrint(M, UP) '\n '\n
if UP? == noUnifier
then 'No 'unifier
else procUnify3Aux(M, UP?, 0) '\n '\n
procUnify3(M, UP, D, 1)
fi)
else '\r 'Error: '\o 'Incorrect 'use 'of 'the 'unify 'command. '\n
fi
if UP? := metaUnify(M, UP, 0, 0) .
eq procUnify2(M?, UP??:[UnificationProblem], D?) = getMsg(M?) [owise] .
eq eMetaPrettyPrint(M, T =? T')
= eMetaPrettyPrint(M, T) '\s '=? '\s eMetaPrettyPrint(M, T') '. .
eq eMetaPrettyPrint(M, T =? T' /\ UP)
= eMetaPrettyPrint(M, T =? T') '\s '/\ '\s eMetaPrettyPrint(M, UP) '. .
eq procUnify3Aux(M, {Sb, N}, I)
= 'Solution qid(string(I + 1, 10)) '\n
if Sb == none
then 'empty 'substitution '\n '\n
else eMetaPrettyPrint(M, Sb) '\n '\n
fi .
eq procUnify3(M, UP, D, I)
= if D == unbounded or-else I < D
then if metaUnify(M, UP, 0, I) :: UnificationPair
then (procUnify3Aux(M, metaUnify(M, UP, 0, I), I)
procUnify3(M, UP, D, I + 1))
else ('No 'more 'solutions. '\n)
fi
else nil
fi .
ceq solveBubblesUnify(M, 'bubble[T], VDS)
= if metaParse(M, QIL, '@UnificationProblem@) :: ResultPair
then parseUnify(getTerm(metaParse(M, QIL, '@UnificationProblem@)), VDS)
else unificationProblemError('\r 'Warning: '\o
printSyntaxError(metaParse(M, QIL, '@UnificationProblem@), QIL) '\n)
fi
if QIL := downQidList(T) .
eq solveBubblesRewUnify('bubble[QI], M, B, D, VDS, DB)
= if solveBubbles('bubble[QI], M, B, VDS, DB) :: Term
then {solveBubbles('bubble[QI], M, B, VDS, DB), M, B, VDS, unbounded, DB}
else tupleTMBOBDerror(
'\r 'Error: '\o 'no 'parsing 'for downQidList(QI) '\n)
fi .
eq solveBubblesRewUnify('bubble['__[TL]], M, B, D, VDS, DB)
= if solveBubbles('bubble['__[TL]], M, B, VDS, DB) :: Term
then {solveBubbles('bubble['__[TL]], M, B, VDS, DB), M, B, VDS, unbounded, DB}
else if metaParse(GRAMMAR-REW, downQidList('__[TL, ''..Qid]), '@RewNuPart@)
:: ResultPair
then solveBubblesRewUnify2(
getTerm(
metaParse(GRAMMAR-REW, downQidList('__[TL, ''..Qid]),
'@RewNuPart@)),
M, B, VDS, DB)
else {getTerm(solveBubblesRedUnify('bubble['__[TL]], M, B, VDS, DB)),
getModule(solveBubblesRedUnify('bubble['__[TL]], M, B, VDS, DB)),
getBool(solveBubblesRedUnify('bubble['__[TL]], M, B, VDS, DB)),
getVars(solveBubblesRedUnify('bubble['__[TL]], M, B, VDS, DB)),
unbounded,
getDatabase(solveBubblesRedUnify('bubble['__[TL]], M, B, VDS, DB))}
fi
fi .
eq solveBubblesRewUnify2('`[_`]_.['token[T], T'], M, B, VDS, DB)
= if downNat(downMetaNat(T)) :: Nat
and-then solveBubblesRedUnify(T', M, B, VDS, DB)
:: Tuple{Term,Module,Bool,OpDeclSet,Database}
then {getTerm(solveBubblesRedUnify(T', M, B, VDS, DB)),
getModule(solveBubblesRedUnify(T', M, B, VDS, DB)),
getBool(solveBubblesRedUnify(T', M, B, VDS, DB)),
getVars(solveBubblesRedUnify(T', M, B, VDS, DB)),
downNat(downMetaNat(T)),
getDatabase(solveBubblesRedUnify(T', M, B, VDS, DB))}
else tupleTMBOBDerror('\r 'Error: '\o 'Incorrect 'command. '\n)
fi .
ceq solveBubblesRedUnify('bubble[QI], M, B, VDS, DB)
= if T? :: Term
then {T?, M, B, VDS, DB}
else tupleTMBODerror('\r 'Error: '\o 'no 'parse 'for downQidList(QI) '\n)
fi
if T? := solveBubbles('bubble[QI], M, B, VDS, DB) .
ceq solveBubblesRedUnify('bubble['__[TL]], M, B, VDS, DB)
= if T? :: Term
then {T?, M, B, VDS, DB}
else if metaParse(GRAMMAR-RED,
downQidList('__[TL, ''..Qid]), '@RedInPart@)
:: ResultPair
then solveBubblesRedUnify2(
getTerm(
metaParse(GRAMMAR-RED, downQidList('__[TL, ''..Qid]), '@RedInPart@)),
DB)
else tupleTMBODerror('\r 'Warning: '\o
printSyntaxError(
metaParse(GRAMMAR-RED, downQidList('__[TL, ''..Qid]),
'@RedInPart@), downQidList('__[TL, ''..Qid])) '\n
'\r 'Error: '\o
'no 'parse 'for downQidList('__[TL, ''..Qid]) '\n)
fi
fi
if T? := solveBubbles('bubble['__[TL]], M, B, VDS, DB) .
*** There is some problem parsing 'in_:_ in solveBubblesRed, but it
*** seems to work with the additional '.
ceq solveBubblesRedUnify2('in_:_.[T, T'], DB)
= if unitInDb(ME, DB')
then solveBubblesRed3(T', addInfoUnify(getFlatModule(ME, DB')), ME, getVars(ME, DB'), DB')
else tupleTMBODerror('\r 'Error: '\o 'The 'module eMetaPrettyPrint(ME) 'is 'not 'in 'the 'database '. '\n)
fi
if < DB' ; ME > := evalModExp(parseModExp(T), DB) .
eq solveBubblesRedUnify2('in_:_.[T, T'], DB)
= tupleTMBODerror('\r 'Error: '\o 'It 'isn't 'possible 'to 'compile eMetaPrettyPrint(parseModExp(T)) '. '\n)
[owise] .
*** ID-UNIFY
ceq procIdUnify(ME, M, T, D, VDS, DB)
*** D is a bound on the number of solutions
= if solveBubblesRewUnify(T, addInfoIdUnify(M), B, D, VDS, DB) :: Tuple{Term,Module,Bool,OpDeclSet,Bound,Database}
then procIdUnify2(
getModule(solveBubblesRewUnify(T, addInfoIdUnify(M), B, D, VDS, DB)),
parseIdUnify(
getTerm(solveBubblesRewUnify(T, addInfoIdUnify(M), B, D, VDS, DB)),
getVars(solveBubblesRewUnify(T, addInfoIdUnify(M), B, D, VDS, DB))),
getBound(solveBubblesRewUnify(T, addInfoIdUnify(M), B, D, VDS, DB)))
else getMsg(getTerm(solveBubblesRewUnify(T, addInfoIdUnify(M), B, D, VDS, DB)))
----('\r 'Error: '\o 'Incorrect 'match 'command. '\n)
fi
if B := included('META-MODULE, getImports(getTopModule(ME, DB)), DB) .
eq addInfoIdUnify(M)
= addOps(---op '_/\_ : '@UnificationProblem@ '@UnificationProblem@ -> '@UnificationProblem@
--- [ctor assoc prec(73)] .
op '_=?_ : 'Universal 'Universal -> '@UnificationProblem@
[ctor poly(1 2) prec(71)] .,
addSorts('@UnificationProblem@, M)) .
--- eq parseIdUnify('_/\_[T, T'], VDS) = parseUnify(T, VDS) /\ parseUnify(T', VDS) .
eq parseIdUnify('_=?_[T, T'], VDS) = constsToVars(T, VDS) =? constsToVars(T', VDS) .
ceq procIdUnify2(M, T =? T', D)
= if X:[SubstitutionSet] :: SubstitutionSet
then ('id-unify
if D == unbounded then nil else '\s '`[ qid(string(D, 10)) '`] '\s fi
'in eMetaPrettyPrint(getName(M)) ':
eMetaPrettyPrint(M, T =? T')
if X:[SubstitutionSet] == empty
then '\n 'No 'unifier
else procIdUnify3(M, T =? T', 0, X:[SubstitutionSet])
fi)
else '\r 'Error: '\o 'Incorrect 'use 'of 'the 'id-unify 'command. '\n
fi
if X:[SubstitutionSet] := metaACUUnify(M, T, T') .
eq procIdUnify2(M?, UP??:[UnificationProblem], D?) = getMsg(M?) [owise] .
eq procIdUnify3(M, UP, I, empty)
= ('\n '\n 'No 'more 'solutions.) .
eq procIdUnify3(M, UP, I, S:Substitution | SS:SubstitutionSet)
= '\n '\n 'Solution qid(string(I + 1, 10))
if S:Substitution == none
then '\n 'empty 'substitution
else '\n eMetaPrettyPrint(M, S:Substitution)
fi
procIdUnify3(M, UP, I + 1, SS:SubstitutionSet) .
endfm
----load check-input-module.maude
---- Input modules are assumed not to have:
---- - idem
---- - assoc without comm
---- - variable alone in lhs
---- - owise
---- - iter
---- - built-ins
---- - something else?
fmod CHECK-INPUT-MODULE is
inc EXT-TERM .
inc MODULE-HANDLING * (op addOps to addOpsSE, op addEqs to addEqsSE, op addSorts to addSortsSE) .
op checkModule : Module -> Bool .
op attr : OpDeclSet Attr -> Bool .
ops assocWithoutComm specialAttr : OpDeclSet -> Bool .
op nonValidAttrs : OpDeclSet AttrSet -> Bool .
op singleVbleInLHSs : RuleSet -> Bool .
op singleVbleInLHSs : EquationSet -> Bool .
var M : Module .
var F : Qid .
var TpL : TypeList .
vars Tp Tp' Tp'' Tp''' : Type .
var TpS : TypeSet .
var At : Attr .
vars AtS AtS' : AttrSet .
vars ODS ODS' : OpDeclSet .
var V : Variable .
var VS : QidSet .
var RlS : RuleSet .
var EqS : EquationSet .
vars T LHS RHS : Term .
var Cond : Condition .
eq attr(op F : TpL -> Tp [owise AtS] . ODS, At AtS) = true .
eq attr(op F : TpL -> Tp [idem AtS] . ODS, idem) = true .
eq attr(op F : TpL -> Tp [iter AtS] . ODS, iter) = true .
eq attr(ODS, At) = false [owise] .
eq nonValidAttrs(op F : TpL -> Tp [At AtS] . ODS, At AtS') = true .
eq nonValidAttrs(ODS, AtS) = false [owise] .
---- special attributes only allowed for constants
eq specialAttr(op F : TpL -> Tp [special(NEHL:NeHookList) AtS] . ODS) = TpL =/= nil .
eq specialAttr(ODS) = false [owise] .
eq assocWithoutComm(op F : TpL -> Tp [assoc AtS] . ODS)
= (not comm in AtS) or-else assocWithoutComm(ODS) .
eq assocWithoutComm(ODS) = false [owise] .
eq singleVbleInLHSs(rl V => RHS [AtS] . RlS) = true .
eq singleVbleInLHSs(crl V => RHS if Cond [AtS] . RlS) = true .
eq singleVbleInLHSs(RlS) = false [owise] .
eq singleVbleInLHSs(eq V = RHS [AtS] . EqS) = true .
eq singleVbleInLHSs(ceq V = RHS if Cond [AtS] . EqS) = true .
eq singleVbleInLHSs(EqS) = false [owise] .
op isRegular : EquationSet -> Bool .
op isRegular : RuleSet -> Bool .
eq isRegular(eq LHS = RHS [AtS] . EqS) = (vars(LHS) == vars(RHS)) and isRegular(EqS) .
eq isRegular(ceq LHS = RHS if Cond [AtS] . EqS) = (vars(LHS) == vars(RHS)) and isRegular(EqS) .
eq isRegular(rl LHS => RHS [AtS] . RlS) = (vars(LHS) == vars(RHS)) and isRegular(RlS) .
eq isRegular(crl LHS => RHS if Cond [AtS] . RlS) = (vars(LHS) == vars(RHS)) and isRegular(RlS) .
---- We say that a term l is linear iff all its variables appear only once in it.
op linear : Term -> Bool .
eq linear(T) = | vars(T) | == size(varlist(T)) .
---- We say that a term l is C-nonlinear iff all its variables are c-nonlinear.
---- A variable x : s in vars(l) is c-nonlinear if it is nonlinear in l and
---- there is a \Sigma-subterm t with ls[t]_B <= s with a position p such that
---- t|_p = f(u,v) with B_f = {C_f}.
op c-nonlinear : Qid Term Module -> Bool . ---- the variable (1st arg.) is c-linear in the term (2nd arg.)
op c-nonlinear : Term Module -> Bool . ---- no repeated variables and all such varaibles are c-linear
op c-nonlinearAux : QidSet Module -> Bool .
op c-nonlinearAux : Type Module -> Bool .
op c-nonlinearAux : Type TypeSet OpDeclSet OpDeclSet Module -> Bool .
op c-nonlinearAux2 : TypeList TypeSet OpDeclSet Module -> Bool .
eq c-nonlinear(V, T, M) = occurrences(V, T) > 1 and-then c-nonlinearAux(V, M) .
eq c-nonlinear(T, M) = not linear(T) and-then c-nonlinearAux(vars(T), M) .
eq c-nonlinearAux(V ; VS, M) = c-nonlinearAux(getType(V), M) or-else c-nonlinearAux(VS, M) .
eq c-nonlinearAux(none, M) = false .
eq c-nonlinearAux(Tp, M) = c-nonlinearAux(Tp, Tp, getOps(M), getOps(M), M) .
ceq c-nonlinearAux(Tp, TpS, op F : Tp' Tp'' -> Tp''' [comm AtS] . ODS, ODS', M)
= true
if sortLeq(M, Tp''', Tp) .
eq c-nonlinearAux(Tp, TpS, op F : TpL -> Tp' [AtS] . ODS, ODS', M)
= if not comm in AtS and-then (not Tp in TpS and-then sortLeq(M, Tp', Tp))
then c-nonlinearAux2(TpL, TpS, ODS', M) ---- all the sorts in that declarations have already been checked
else c-nonlinearAux(Tp, TpS, ODS, ODS', M)
fi
[owise] .
eq c-nonlinearAux(Tp, TpS, none, ODS, M)
= false .
eq c-nonlinearAux2(Tp TpL, TpS, ODS, M)
= if Tp in TpS
then false
else c-nonlinearAux(Tp, Tp ; TpS, ODS, ODS, M)
fi
or-else c-nonlinearAux2(TpL, TpS, ODS, M) .
eq c-nonlinearAux2(nil, TpS, ODS, M) = false .
---(
eq c-permute(C, M) = C .
eq c-permute(V, M) = V .
ceq c-permute(F[T, T'], M)
= c-combine(F, c-permute((T, T'), M)) # c-combine(F, c-permute((T', T), M))
if isCommutative(M, F, getTypes(M, (T, T'))) .
eq c-permute(F[TL], M)
= c-combine(F, c-permute(TL, M))
[owise] .
eq c-permute((T, T'), M)
= c-permute(T, M) .
---)
endfm
--------------------------------------------------------------------------------
view SubstitutionSet from TRIV to SUBSTITUTIONSET is
sort Elt to SubstitutionSet .
endv
fmod MODULE-VARIANTS is
inc CHECK-INPUT-MODULE .
inc META-NARROWING-SEARCH * (op addOps to addOpsSE, op addEqs to addEqsSE, op addSorts to addSortsSE) .
inc UNIT .
pr 2TUPLE{SubstitutionSet, Nat}
* (op `(_`,_`) : SubstitutionSet Nat -> Tuple{SubstitutionSet, Nat} to <_;_>,
op p1_ : Tuple{SubstitutionSet, Nat} -> SubstitutionSet to getSubst,
op p2_ : Tuple{SubstitutionSet, Nat} -> Nat to getIndex) .
pr CONVERSION .
pr EXT-TERM .
pr EXT-DECL .
pr 2TUPLE{Module,Module}
* (op `(_`,_`) : Module Module -> Tuple{Module, Module} to <_;_>) .
vars V W : Variable .
var C : Constant .
vars M M' M'' : Module .
var N : Nat .
vars T T' T'' LHS RHS : Term .
var F : Qid .
var TL : TermList .
var AtS : AttrSet .
var VFS : VariantFourSet .
vars Tp Tp' Tp'' : Type .
var TpL : TypeList .
var Rl : Rule .
var RlS : RuleSet .
var Eq : Equation .
var EqS : EquationSet .
var ODS : OpDeclSet .
var Cond : Condition .
var S : Sort .
var VS : QidSet .
vars Subst Subst' : Substitution .
vars SubstS SubstS' : SubstitutionSet .
var H : Header .
var SS : SortSet .
var SSDS : SubsortDeclSet .
vars OPDS OPDS' : OpDeclSet .
var MAS : MembAxSet .
var IL : ImportList .
------------------------------------------------------------------------------
---- Given a module \mathcal{R} = (\Sigma, E, R)
---- removeIds(\mathcal{R}) = removeIds((\widehat{\Sigma}, B, \widetilde{U}), R)
---- where
---- - \widehat{\Sigma} is obtained by
---- - adding to $\Sigma$ a fresh new sort [Tuple] and
---- - a tupling operator <_,...,_> : [s] [s_1] ... [s_n] -> [Tuple]
---- for each rule l -> r if u_1 -> v_1 /\ ... /\ u_n -> v_n in R,
---- where l has sort s and v_i has sort s_i, 1 <= i <= n,
---- - B_f = E_f \cap {A_f, C_f}
---- - U_f = E_f \cap {LU_f, RU_f},
---- with LU_f and RU_f rewrite rules f(e,x) -> x and f(x,e) -> x, and
---- where \widetilde{U} is the B-coherence completion of U,
---- which is described as \widetilde{U} = \bigcup_{f:[s_1]...[s_n] -> [s] \in \Sigma} \widetilde{U}_f.
---- If A_f \not \in B_f, or A_f, C_f \in B_f, then \widetilde{U}_f = U_f.
---- Otherwise, if A_f \in B_f, but C_f \not \in B_f, then,
---- if LU_f \in U_f, then we add the rule f(x,f(e,y)) -> f(x,y) and
---- if RU_f \in U_f, then we add the rule f(f(x,e'),y) -> f(x,y).
---- makeIdsModule computes (\widehat{\Sigma}, B, \widetilde{U})
------------------------------------------------------------------------------
sort VariantProcedure .
ops narrowing ad-hoc : -> VariantProcedure .
var VP : VariantProcedure .
op removeIds : Module ~> Module .
---- given a module returns an equivalent module without ids but with variants of eqs and rls
op removeIds : Module VariantProcedure ~> Module .
---- given a module returns an equivalent module without ids but with variants
---- of eqs and rls using using the specified procedure for calculating variants
op getVariants : Module Module RuleSet VariantProcedure -> RuleSet .
---- given a (\widehat{\Sigma}, B, \widetilde{U}) returns the variants of the given set of rules
---- It takes the modules without and with ids. The module with id attributes is used to normalize.
op getVariants : Module Module EquationSet VariantProcedure -> EquationSet .
---- given a (\widehat{\Sigma}, B, \widetilde{U}) returns the variants of the given set of equations
---- It takes the modules without and with ids. The module with id attributes is used to normalize.
op getVariants : Module Module Term VariantProcedure -> VariantFourSet .
---- given a (\widehat{\Sigma}, B, \widetilde{U}) returns the variants of a term (a tuple)
op getRlVariants : Module VariantFourSet Term Condition AttrSet -> RuleSet .
---- given the variants of a tuple < LHS, target terms in condition >, a RHS, a condition, and an attribute set,
---- it constructs the corresponding variant rules
op getEqVariants : Module VariantFourSet Term Condition AttrSet -> EquationSet .
---- given the variants of a tuple < LHS, target terms in condition >, a RHS, a condition, and an attribute set,
---- it constructs the corresponding variant equations
eq removeIds(M)
= if nonValidAttrs(getOps(M), owise idem iter)
then unitError('The 'module 'uses 'non-supported 'attributes '`(owise`, 'idem`, 'or 'iter '`). '\n)
else if singleVbleInLHSs(getRls(M))
then unitError('The 'module 'contains 'rules 'with 'single 'variables 'in 'their 'left-hand 'sides. '\n)
else if singleVbleInLHSs(getEqs(M))
then unitError('The 'module 'contains 'equations 'with 'single 'variables 'in 'their 'left-hand 'sides. '\n)
else if assocWithoutComm(getOps(M))
then removeIds(M, ad-hoc)
else removeIds(M, narrowing)
fi
fi
fi
fi .
eq removeIds(M, VP)
---- the narrowing based getVariant function requires a module with id attributes turned into eqs
---- and sort Tuple and tuple operators in; the ad-hoc getVariant (FroCos th 2) only needs the
---- tuple declarations.
= setRls(
addEqs(
getVariants(makeIdsTuplingModule(M), addTupling(M, M), getEqs(M), VP),
makeIdsModule(M)),
getVariants(makeIdsTuplingModule(M), addTupling(M, M), getRls(M), VP)) .
eq getVariants(M, M', Rl RlS, VP)
= getRlVariants(M', getVariants(M, M', makeTuple(lhs(Rl), cond(Rl)), VP), rhs(Rl), cond(Rl), atts(Rl))
getVariants(M, M', RlS, VP) .
eq getVariants(M, M', (none).RuleSet, VP) = none .
eq getVariants(M, M', Eq EqS, VP)
= getEqVariants(M', getVariants(M, M', makeTuple(lhs(Eq), cond(Eq)), VP), rhs(Eq), cond(Eq), atts(Eq))
getVariants(M, M', EqS, VP) .
eq getVariants(M, M', (none).EquationSet, VP) = none .
eq getVariants(M, M', T, narrowing) = getVariants(M, T, 1, irreducible ACUnify) .
eq getRlVariants(M, {'<_>[T], Subst, Subst', N} | VFS, T', nil, AtS)
= (rl T => getTerm(metaNormalize(M, _<<_(T', Subst))) [AtS] .)
getRlVariants(M, VFS, T', nil, AtS) .
eq getRlVariants(M, {F[T, TL], Subst, Subst', N} | VFS, T', Cond, AtS)
= (crl T => getTerm(metaNormalize(M, _<<_(T', Subst))) if makeCond(TL, Cond, Subst) [AtS] .)
getRlVariants(M, VFS, T', Cond, AtS) .
eq getRlVariants(M, empty, T', Cond, AtS) = none .
eq getEqVariants(M, {'<_>[T], Subst, Subst', N} | VFS, T', nil, AtS)
= (eq T = getTerm(metaNormalize(M, _<<_(T', Subst))) [AtS] .)
getEqVariants(M, VFS, T', nil, AtS) .
eq getEqVariants(M, {F[T, TL], Subst, Subst', N} | VFS, T', Cond, AtS)
= (ceq T = getTerm(metaNormalize(M, _<<_(T', Subst))) if makeCond(TL, Cond, Subst) [AtS] .)
getEqVariants(M, VFS, T', Cond, AtS) .
eq getEqVariants(M, empty, T', Cond, AtS) = none .
------------------------------------------------------------------------------
op makeTuple : Term Condition -> Term .
op tupleTermList : Condition -> TermList .
eq makeTuple(T, Cond)
= if Cond == nil
then qid("<_>")[T]
else qid("<_" + tupleId(Cond) + ">")[T, tupleTermList(Cond)]
fi .
eq tupleTermList(T' => T'' /\ Cond) = (T'', tupleTermList(Cond)) .
eq tupleTermList(T' = T'' /\ Cond) = tupleTermList(Cond) .
eq tupleTermList(T' : S /\ Cond) = tupleTermList(Cond) .
eq tupleTermList(T' := T'' /\ Cond) = (T', tupleTermList(Cond)) .
eq tupleTermList(nil) = empty .
op makeCond : TermList Condition Substitution -> Condition .
eq makeCond((T, TL), T' => T'' /\ Cond, Subst)
= (T' << Subst) => T /\ makeCond(TL, Cond, Subst) .
eq makeCond((T, TL), T' := T'' /\ Cond, Subst)
= T := (T'' << Subst) /\ makeCond(TL, Cond, Subst) .
eq makeCond(TL, T' = T'' /\ Cond, Subst)
= (T' << Subst) = (T'' << Subst) /\ makeCond(TL, Cond, Subst) .
eq makeCond(TL, T' : S /\ Cond, Subst)
= (T' << Subst) : S /\ makeCond(TL, Cond, Subst) .
eq makeCond(empty, nil, Subst) = nil .
------------------------------------------------------------------------------
---- makeIdsTuplingModule((\Sigma, E, R)) computes (\widehat{\Sigma}, B, \widetilde{U})
------------------------------------------------------------------------------
op makeIdsTuplingModule : Module -> Module .
op makeIdsModule : Module -> Module .
op addTupling : Module Module -> Module .
---- addTupling is called after makeIdsModule, which removes the eqs in it
---- the first module is the oiginal one, with the original eqs and rls
eq makeIdsTuplingModule(M) = addTupling(M, makeIdsModule(M)) .
eq makeIdsModule(M)
= setEqs(
setOps(
setRls(M, none),
removeIds(getOps(M))),
idEqs(M, getOps(M))) .
eq addTupling(M, M')
= addOps(
tuplingOps(M, getEqs(M), getRls(M)),
addSorts('Tuple, M')) .
op idEqs : Module OpDeclSet -> EquationSet .
eq idEqs(M, op F : Tp Tp' -> Tp'' [left-id(T) AtS] . ODS)
= (eq F[T, qid("X:" + string(type2qid(getKind(M, Tp))))] = qid("X:" + string(type2qid(getKind(M, Tp)))) [label('lIdEq1)] .)
---- = (eq F[T, qid("X:" + string(type2qid(Tp)))] = qid("X:" + string(type2qid(Tp))) [label('lIdEq1)] .)
if assoc in AtS and not comm in AtS
then (eq F[qid("X:" + string(type2qid(getKind(M, Tp)))), F[T, qid("Y:" + string(type2qid(getKind(M, Tp))))]]
= F[qid("X:" + string(type2qid(getKind(M, Tp)))), qid("Y:" + string(type2qid(getKind(M, Tp))))]
---- then (eq F[qid("X:" + string(type2qid(Tp))), F[T, qid("Y:" + string(type2qid(Tp)))]]
---- = F[qid("X:" + string(type2qid(Tp))), qid("Y:" + string(type2qid(Tp)))]
[label('lIdEq2)] .)
else none
fi
idEqs(M, ODS) .
eq idEqs(M, op F : Tp Tp' -> Tp'' [right-id(T) AtS] . ODS)
= (eq F[qid("X:" + string(type2qid(getKind(M, Tp)))), T] = qid("X:" + string(type2qid(getKind(M, Tp)))) [label('rIdEq1)] .)
---- = (eq F[qid("X:" + string(type2qid(Tp))), T] = qid("X:" + string(type2qid(Tp))) [label('rIdEq1)] .)
if assoc in AtS and not comm in AtS
then (eq F[F[qid("X:" + string(type2qid(getKind(M, Tp)))), T], qid("Y:" + string(type2qid(getKind(M, Tp))))]
= F[qid("X:" + string(type2qid(getKind(M, Tp)))), qid("Y:" + string(type2qid(getKind(M, Tp))))]
---- then (eq F[F[qid("X:" + string(type2qid(Tp))), T], qid("Y:" + string(type2qid(Tp)))]
---- = F[qid("X:" + string(type2qid(Tp))), qid("Y:" + string(type2qid(Tp)))]
[label('rIdEq2)] .)
else none
fi
idEqs(M, ODS) .
eq idEqs(M, op F : Tp Tp' -> Tp'' [id(T) AtS] . ODS)
---- modified on Jan 13th, 2011
---- The ACU case is now handled, the id attributes are left if also AC
= if assoc in AtS and comm in AtS
then none
else if comm in AtS
then (eq F[T, qid("X:" + string(type2qid(getKind(M, Tp))))] = qid("X:" + string(type2qid(getKind(M, Tp)))) [label('idEq1)] .)
---- then (eq F[T, qid("X:" + string(type2qid(Tp)))] = qid("X:" + string(type2qid(Tp))) [label('idEq1)] .)
else (eq F[qid("X:" + string(type2qid(getKind(M, Tp)))), T] = qid("X:" + string(type2qid(getKind(M, Tp)))) [label('idEq2)] .)
---- else (eq F[qid("X:" + string(type2qid(Tp))), T] = qid("X:" + string(type2qid(Tp))) [label('idEq2)] .)
(eq F[T, qid("X:" + string(type2qid(getKind(M, Tp))))] = qid("X:" + string(type2qid(getKind(M, Tp)))) [label('idEq3)] .)
---- (eq F[T, qid("X:" + string(type2qid(Tp)))] = qid("X:" + string(type2qid(Tp))) [label('idEq3)] .)
fi
if assoc in AtS and not comm in AtS
then (eq F[qid("X:" + string(type2qid(getKind(M, Tp)))), F[T, qid("Y:" + string(type2qid(getKind(M, Tp))))]]
= F[qid("X:" + string(type2qid(getKind(M, Tp)))), qid("Y:" + string(type2qid(getKind(M, Tp))))]
---- then (eq F[qid("X:" + string(type2qid(Tp))), F[T, qid("Y:" + string(type2qid(Tp)))]]
---- = F[qid("X:" + string(type2qid(Tp))), qid("Y:" + string(type2qid(Tp)))]
[none] .)
(eq F[F[qid("X:" + string(type2qid(getKind(M, Tp)))), T], qid("Y:" + string(type2qid(getKind(M, Tp))))]
= F[qid("X:" + string(type2qid(getKind(M, Tp)))), qid("Y:" + string(type2qid(getKind(M, Tp))))]
---- (eq F[F[qid("X:" + string(type2qid(Tp))), T], qid("Y:" + string(type2qid(Tp)))]
---- = F[qid("X:" + string(type2qid(Tp))), qid("Y:" + string(type2qid(Tp)))]
[none] .)
else none
fi
fi
idEqs(M, ODS) .
eq idEqs(M, ODS) = none [owise] .
op removeIds : OpDeclSet -> OpDeclSet .
ceq removeIds(op F : TpL -> Tp [id(T) AtS] . ODS)
= removeIds(op F : TpL -> Tp [AtS] . ODS)
if not (assoc in AtS and comm in AtS) .
eq removeIds(op F : TpL -> Tp [left-id(T) AtS] . ODS)
= removeIds(op F : TpL -> Tp [AtS] . ODS) .
eq removeIds(op F : TpL -> Tp [right-id(T) AtS] . ODS)
= removeIds(op F : TpL -> Tp [AtS] . ODS) .
eq removeIds(ODS) = ODS [owise] .
op tuplingOps : Module EquationSet RuleSet -> OpDeclSet .
op tuplingOps : Module EquationSet -> OpDeclSet .
op tuplingOps : Module RuleSet -> OpDeclSet .
eq tuplingOps(M, EqS, RlS) = tuplingOps(M, EqS) tuplingOps(M, RlS) .
eq tuplingOps(M, eq LHS = RHS [AtS] . EqS)
= (op qid("<_>") : getKind(M, leastSort(M, LHS)) -> '`[Tuple`] [none] .)
tuplingOps(M, EqS) .
eq tuplingOps(M, ceq LHS = RHS if Cond [AtS] . EqS)
= (op qid("<_" + tupleId(Cond) + ">") : getKind(M, leastSort(M, LHS)) arityCond(M, Cond) -> '`[Tuple`] [none] .)
tuplingOps(M, EqS) .
eq tuplingOps(M, (none).EquationSet) = none .
eq tuplingOps(M, rl LHS => RHS [AtS] . RlS)
= (op qid("<_>") : getKind(M, leastSort(M, LHS)) -> '`[Tuple`] [none] .)
tuplingOps(M, RlS) .
eq tuplingOps(M, crl LHS => RHS if Cond [AtS] . RlS)
= (op qid("<_" + tupleId(Cond) + ">") : getKind(M, leastSort(M, LHS)) arityCond(M, Cond) -> '`[Tuple`] [none] .)
tuplingOps(M, RlS) .
eq tuplingOps(M, (none).RuleSet) = none .
op arityCond : Module Condition -> TypeList .
eq arityCond(M, T => T' /\ Cond) = getKind(M, leastSort(M, T')) arityCond(M, Cond) .
eq arityCond(M, T := T' /\ Cond) = getKind(M, leastSort(M, T)) arityCond(M, Cond) .
eq arityCond(M, T = T' /\ Cond) = arityCond(M, Cond) .
eq arityCond(M, T : S /\ Cond) = arityCond(M, Cond) .
eq arityCond(M, nil) = nil .
op tupleId : Condition -> String .
eq tupleId(T => T' /\ Cond) = ",_" + tupleId(Cond) .
eq tupleId(T := T' /\ Cond) = ",_" + tupleId(Cond) .
eq tupleId(T = T' /\ Cond) = tupleId(Cond) .
eq tupleId(T : S /\ Cond) = tupleId(Cond) .
eq tupleId(Cond) = "" .
------------------------------------------------------------------------------
---- See Th. 2, FroCos'09
---- TO DO: it doesn't give the minimal set of variants
op getVariants : Module Term SubstitutionSet -> VariantFourSet .
op getSubstitutions : Module QidSet OpDeclSet Nat -> Tuple{SubstitutionSet,Nat} .
op getSubstitutions1 : Module Variable OpDeclSet Nat -> Tuple{SubstitutionSet,Nat} .
op combineSubsts : SubstitutionSet SubstitutionSet -> SubstitutionSet .
eq getVariants(M, M', T, ad-hoc)
= getVariants(M', T, getSubst(getSubstitutions(M', vars(T), getOps(M'), 0))) .
eq getVariants(M, T, Subst | SubstS)
= {getTerm(metaNormalize(M, T << Subst)), Subst, none, 0} | getVariants(M, T, SubstS) .
eq getVariants(M, T, empty) = {T, none, none, 0} .
eq getSubstitutions(M, V ; VS, ODS, N)
= < combineSubsts(
getSubst(getSubstitutions1(M, V, ODS, N)),
getSubst(getSubstitutions(M, VS, ODS, getIndex(getSubstitutions1(M, V, ODS, N))))) ;
getIndex(getSubstitutions(M, VS, ODS, getIndex(getSubstitutions1(M, V, ODS, N)))) > .
eq getSubstitutions(M, none, ODS, N) = < empty ; N > .
eq combineSubsts(Subst | SubstS, Subst' | SubstS')
= (Subst ; Subst') | combineSubsts(SubstS, Subst' | SubstS') | combineSubsts(Subst, SubstS') .
eq combineSubsts(SubstS, empty) = SubstS .
eq combineSubsts(empty, SubstS) = SubstS .
ceq getSubstitutions1(M, V, op F : TpL -> Tp [id(T) AtS] . ODS, N)
= < (V <- T) |
if (assoc in AtS and-then not comm in AtS)
and-then sortLeq(M, leastSort(M, F[qid("X@" + string(N, 10) + ":" + string(Tp)), T]), getType(V))
then (V <- (F[qid("X@" + string(N, 10) + ":" + string(Tp)), T]))
| (V <- (F[T, qid("X@" + string(s N, 10) + ":" + string(Tp))]))
else empty
fi |
getSubst(getSubstitutions1(M, V, ODS, s s N)) ;
getIndex(getSubstitutions1(M, V, ODS, s s N)) >
if sortLeq(M, leastSort(M, T), getType(V)) . ---- ls[e] <= s ls[f(y,e)] <= s
ceq getSubstitutions1(M, V, op F : TpL -> Tp [right-id(T) AtS] . ODS, N)
= < (V <- T) |
if (assoc in AtS and-then not comm in AtS)
and-then sortLeq(M, leastSort(M, F[qid("X@" + string(N, 10) + ":" + string(Tp)), T]), getType(V))
then (V <- F[T, qid("X@" + string(N, 10) + ":" + string(Tp))])
else empty
fi |
getSubst(getSubstitutions1(M, V, ODS, s s N)) ;
getIndex(getSubstitutions1(M, V, ODS, s s N)) >
if sortLeq(M, leastSort(M, T), getType(V)) . ---- ls[e] <= s ls[f(y,e)] <= s
ceq getSubstitutions1(M, V, op F : TpL -> Tp [left-id(T) AtS] . ODS, N)
= < (V <- T) |
if (assoc in AtS and-then not comm in AtS)
and-then sortLeq(M, leastSort(M, F[qid("X@" + string(N, 10) + ":" + string(Tp)), T]), getType(V))
then (V <- F[qid("X@" + string(s N, 10) + ":" + string(Tp)), T])
else empty
fi |
getSubst(getSubstitutions1(M, V, ODS, s s N)) ;
getIndex(getSubstitutions1(M, V, ODS, s s N)) >
if sortLeq(M, leastSort(M, T), getType(V)) . ---- ls[e] <= s ls[f(y,e)] <= s
eq getSubstitutions1(M, V, ODS, N) = < empty ; N > [owise] .
------------------------------------------------------------------------------
---- Given a module with axioms B where for each f we have B_f \in {A_f,C_f},
---- we now define a rewrite theory (\Sigma, B�, A), where for each f we have
---- B�_f = B_f if B_f =/= {A_f}, and B�_f = \emptyset if B_f == {A_f}, and
---- where A consists of rules of either the form
---- f(f(x, y), z) -> f(x, f(y, z))
---- or the form
---- f(x, f(y, z)) -> f(f(x, y), z)
---- for each f such that B_f == {A_f}. That is, for any such f we "choose" a
---- rule asociating f to the right or to the left (but only "one" of these possibilities).
---- TO DO: I cannot set a timeout. If the first one doesn't work it hangs up!
---- TO DO: All terms are in their flatten form, when removing the assoc atributes I get error messages.
op removeLonelyAssocs : Module -> Module .
---- removes all assoc with no comm, returning an equivalent module
op $removeLonelyAssocs : OpDeclSet -> OpDeclSet .
---- removes those assoc attributes that are not with the comm one
op $removeLonelyAssocs : Module OpDeclSet OpDeclSet EquationSet ~> Module .
---- arg. 1 (Module): the module with assoc attribute removed
---- arg. 2 (OpDeclSet): initially all op. decls.; they are evaluated one by one,
---- adding the corresponding equation to the 4th arg. in the recursive call
---- arg. 3 (OpDeclSet): initially empty; evaluated op. decls. are added to this set
---- arg. 4 (EquationSet): assoc. eq. to be added to the module
op $checkAEq : Module Equation -> Bool .
---- checks whether the assoc. eq. given as argument unifies with any lhs in the module
---- arg. 1 (Module): the module with assoc attribute removed
---- arg. 2 (Equation): tentative assoc. eq. to evaluate
op $checkAEqAux : Module EquationSet -> Bool .
---- tries to narrow with the assoc. eq. (as a rule) on each lhs in the module.
---- arg. 1 (Module): module with assoc attribute removed, with the assoc. eq.
---- turned into a rule as single rule (no eqs.)
---- arg. 2 (EquationSet): eqs. in the original module
op $anyLonelyAssoc : OpDeclSet -> Bool .
---- checks whether the module contains an operator with assoc and no comm
eq removeLonelyAssocs(M)
= if $anyLonelyAssoc(getOps(M))
then if nonValidAttrs(getOps(M), owise idem iter)
then unitError('The 'module 'uses 'non-supported 'attributes '`(owise`, 'idem`, 'or 'iter '`). '`))
else if singleVbleInLHSs(getRls(M))
then unitError('The 'module 'contains 'rules 'with 'single 'variables 'in 'their 'left-hand 'sides. '`))
else if singleVbleInLHSs(getEqs(M))
then unitError('The 'module 'contains 'equations 'with 'single 'variables 'in 'their 'left-hand 'sides. '`))
else $removeLonelyAssocs(setOps(M, $removeLonelyAssocs(getOps(M))), getOps(M), none, none)
fi
fi
fi
else M
fi .
ceq $removeLonelyAssocs(op F : Tp Tp -> Tp [assoc AtS] . OPDS)
= op F : Tp Tp -> Tp [AtS] . $removeLonelyAssocs(OPDS)
if not comm in AtS .
eq $removeLonelyAssocs(OPDS) = OPDS [owise] .
ceq $removeLonelyAssocs(M, op F : TpL -> Tp [AtS] . OPDS, OPDS', EqS)
= $removeLonelyAssocs(M, OPDS, op F : TpL -> Tp [AtS] . OPDS', EqS)
if size(TpL) =/= 2 or not assoc in AtS or comm in AtS .
ceq $removeLonelyAssocs(M, op F : Tp Tp -> Tp [assoc AtS] . OPDS, OPDS', EqS)
= $removeLonelyAssocs(M, OPDS, op F : Tp Tp -> Tp [AtS] . OPDS', Eq EqS)
if not comm in AtS
/\ Str:String := string(type2qid(getKind(M, Tp)))
/\ Eq := (eq F[F[qid("X:" + Str:String), qid("Y:" + Str:String)], qid("Z:" + Str:String)]
= F[qid("X:" + Str:String), F[qid("Y:" + Str:String), qid("Z:" + Str:String)]] [label('assocEq)] .)
/\ $checkAEq(M, Eq) .
ceq $removeLonelyAssocs(M, op F : Tp Tp -> Tp [assoc AtS] . OPDS, OPDS', EqS)
= $removeLonelyAssocs(M, OPDS, op F : Tp Tp -> Tp [AtS] . OPDS', Eq EqS)
if not comm in AtS
/\ Str:String := string(type2qid(getKind(M, Tp)))
/\ Eq := (eq F[qid("X:" + Str:String), F[qid("Y:" + Str:String), qid("Z:" + Str:String)]]
= F[F[qid("X:" + Str:String), qid("Y:" + Str:String)], qid("Z:" + Str:String)] [label('assocEq)] .)
/\ $checkAEq(M, Eq) .
eq $removeLonelyAssocs(M, none, OPDS', EqS) = addEqs(EqS, M) .
eq $removeLonelyAssocs(M, op F : TpL -> Tp [AtS] . OPDS, OPDS', EqS) = unitError('assoc 'attributes 'cannot 'be 'removed 'for F) .
eq $checkAEq(M, Eq) = $checkAEqAux(setRls(setEqs(M, none), rulify(Eq)), getEqs(M)) .
ceq $checkAEqAux(M, Eq EqS)
= T:Term == lhs(Eq) ---- the assoc eq doesn't unify with the equation's lhs
and
Subst:Substitution == none
and-then
$checkAEqAux(M, EqS)
if {T:Term, Tp:Type, Subst:Substitution} := metaNarrow(M, lhs(Eq), 1) .
eq $checkAEqAux(M, none) = true .
ceq $anyLonelyAssoc(op F : Tp Tp -> Tp [assoc AtS] . OPDS)
= true
if not comm in AtS .
eq $anyLonelyAssoc(OPDS) = false [owise] .
endfm
-------------------------------------------------------------------------------
fmod ACU-COHERENCE-COMPLETION is
inc UNIT .
inc MODULE-HANDLING * (op addOps to addOpsSE, op addEqs to addEqsSE, op addSorts to addSortsSE) .
vars V W : Variable .
var C : Constant .
var FM : FModule .
var SM : SModule .
var M : Module .
var N : Nat .
vars T T' T'' LHS RHS : Term .
vars Subst Subst' : Substitution .
var F : Qid .
var TL : TermList .
vars AtS AtS' : AttrSet .
---- var VFS : VariantFourSet .
vars Tp Tp' Tp'' : Type .
var TpL : TypeList .
var Rl : Rule .
var RlS : RuleSet .
var Eq : Equation .
var EqS : EquationSet .
var ODS : OpDeclSet .
var Cond : Condition .
var QIL : QidList .
------------------------------------------------------------------------------
---- coherence completion
------------------------------------------------------------------------------
op acuCohComplete : SModule -> SModule .
op acuCohComplete : SModule OpDeclSet RuleSet -> RuleSet .
op acuCohComplete : SModule Type AttrSet Rule -> RuleSet .
op acuCohComplete : SModule OpDeclSet EquationSet -> EquationSet .
op acuCohComplete : SModule Type AttrSet Equation -> EquationSet .
eq acuCohComplete(FM)
= moreGeneralEqs(setEqs(FM, acuCohComplete(FM, getOps(FM), getEqs(FM)))) .
eq acuCohComplete(SM)
= moreGeneralEqs(
moreGeneralRls(
setRls(
setEqs(SM,
acuCohComplete(SM, getOps(SM), getEqs(SM))),
acuCohComplete(SM, getOps(SM), getRls(SM)))))
[owise] .
eq acuCohComplete(unitError(QIL)) = unitError(QIL) .
ceq acuCohComplete(M, op F : Tp Tp' -> Tp'' [assoc AtS] . ODS, rl F[TL] => RHS [AtS'] . RlS)
= acuCohComplete(M, Tp, assoc AtS, rl F[TL] => RHS [AtS'] .)
acuCohComplete(M, op F : Tp Tp' -> Tp'' [assoc AtS] . ODS, RlS)
if sameKind(M, Tp, Tp')
/\ sameKind(M, Tp', Tp'')
/\ sameKindAll(M, Tp, eLeastSort(M, TL)) .
ceq acuCohComplete(M, op F : Tp Tp' -> Tp'' [assoc AtS] . ODS, crl F[TL] => RHS if Cond [AtS'] . RlS)
= acuCohComplete(M, Tp, assoc AtS, crl F[TL] => RHS if Cond [AtS'] .)
acuCohComplete(M, op F : Tp Tp' -> Tp'' [assoc AtS] . ODS, RlS)
if sameKind(M, Tp, Tp')
/\ sameKind(M, Tp', Tp'')
/\ sameKindAll(M, Tp, eLeastSort(M, TL)) .
eq acuCohComplete(M, ODS, rl LHS => RHS [AtS] . RlS)
= rl LHS => RHS [AtS] . acuCohComplete(M, ODS, RlS)
[owise] .
eq acuCohComplete(M, ODS, crl LHS => RHS if Cond [AtS] . RlS)
= crl LHS => RHS if Cond [AtS] . acuCohComplete(M, ODS, RlS)
[owise] .
eq acuCohComplete(M, ODS, (none).RuleSet) = none .
ceq acuCohComplete(M, op F : Tp Tp' -> Tp'' [assoc AtS] . ODS, eq F[TL] = RHS [AtS'] . EqS)
= acuCohComplete(M, Tp, assoc AtS, eq F[TL] = RHS [AtS'] .)
acuCohComplete(M, op F : Tp Tp' -> Tp'' [assoc AtS] . ODS, EqS)
if sameKind(M, Tp, Tp')
/\ sameKind(M, Tp', Tp'')
/\ sameKindAll(M, Tp, eLeastSort(M, TL)) .
ceq acuCohComplete(M, op F : Tp Tp' -> Tp'' [assoc AtS] . ODS, ceq F[TL] = RHS if Cond [AtS'] . EqS)
= acuCohComplete(M, Tp, assoc AtS, ceq F[TL] = RHS if Cond [AtS'] .)
acuCohComplete(M, op F : Tp Tp' -> Tp'' [assoc AtS] . ODS, EqS)
if sameKind(M, Tp, Tp')
/\ sameKind(M, Tp', Tp'')
/\ sameKindAll(M, Tp, eLeastSort(M, TL)) .
eq acuCohComplete(M, ODS, eq LHS = RHS [AtS] . EqS)
= eq LHS = RHS [AtS] . acuCohComplete(M, ODS, EqS)
[owise] .
eq acuCohComplete(M, ODS, ceq LHS = RHS if Cond [AtS] . EqS)
= ceq LHS = RHS if Cond [AtS] . acuCohComplete(M, ODS, EqS)
[owise] .
eq acuCohComplete(M, ODS, (none).EquationSet) = none .
op sameKindAll : Module Type TypeList -> Bool .
eq sameKindAll(M, Tp, Tp' TpL) = sameKind(M, Tp, Tp') and-then sameKindAll(M, Tp, TpL) .
eq sameKindAll(M, Tp, nil) = true .
---- Given f(t1,...,tn) -> r if C
---- if f AC add f(t1,...,tn,x:[s]) -> f(r,x:[s]) if C
eq acuCohComplete(M, Tp, assoc comm AtS, rl F[TL] => RHS [AtS'] .)
= (rl F[TL] => RHS [AtS'] .)
(rl F[TL, qid("X@@@:[" + string(Tp) + "]")] => F[RHS, qid("X@@@:[" + string(Tp) + "]")] [AtS'] .)
[owise] .
eq acuCohComplete(M, Tp, assoc comm AtS, crl F[TL] => RHS if Cond [AtS'] .)
= (crl F[TL] => RHS if Cond [AtS'] .)
(crl F[TL, qid("X@@@:[" + string(Tp) + "]")] => F[RHS, qid("X@@@:[" + string(Tp) + "]")] if Cond [AtS'] .)
[owise] .
---- if f ACU replace by f(t1,...,tn,x:[s]) -> f(r,x:[s]) if C
eq acuCohComplete(M, Tp, assoc comm id(T) AtS, rl F[TL] => RHS [AtS'] .)
= (rl F[TL, qid("X@@@:[" + string(Tp) + "]")] => F[RHS, qid("X@@@:[" + string(Tp) + "]")] [AtS'] .) .
eq acuCohComplete(M, Tp, assoc comm id(T) AtS, crl F[TL] => RHS if Cond [AtS'] .)
= (crl F[TL, qid("X@@@:[" + string(Tp) + "]")] => F[RHS, qid("X@@@:[" + string(Tp) + "]")] if Cond [AtS'] .) .
---- if f AU replace by f(x:[s],t1,...,tn,y:[s]) -> f(x:[s],r,y:[s]) if C
ceq acuCohComplete(M, Tp, assoc id(T) AtS, rl F[TL] => RHS [AtS'] .)
= (rl F[qid("X@@@:[" + string(Tp) + "]"), TL, qid("Y@@@:[" + string(Tp) + "]")]
=> F[qid("X@@@:[" + string(Tp) + "]"), RHS, qid("Y@@@:[" + string(Tp) + "]")] [AtS'] .)
if not comm in AtS .
ceq acuCohComplete(M, Tp, assoc id(T) AtS, crl F[TL] => RHS if Cond [AtS'] .)
= (crl F[qid("X@@@:[" + string(Tp) + "]"), TL, qid("Y@@@:[" + string(Tp) + "]")]
=> F[qid("X@@@:[" + string(Tp) + "]"), RHS, qid("Y@@@:[" + string(Tp) + "]")] if Cond [AtS'] .)
if not comm in AtS .
---- if f ALU replace by f(x:[s],t1,...,tn,y:[s]) -> f(x:[s],r,y:[s]) if C
---- and add f(x:[s],t1,...,tn) -> f(x:[s],r) if C
eq acuCohComplete(M, Tp, assoc left-id(T) AtS, rl F[TL] => RHS [AtS'] .)
= (rl F[qid("X@@@:[" + string(Tp) + "]"), TL, qid("Y@@@:[" + string(Tp) + "]")]
=> F[qid("X@@@:[" + string(Tp) + "]"), RHS, qid("Y@@@:[" + string(Tp) + "]")] [AtS'] .)
(rl F[qid("X@@@:[" + string(Tp) + "]"), TL]
=> F[qid("X@@@:[" + string(Tp) + "]"), RHS] [AtS'] .) .
eq acuCohComplete(M, Tp, assoc left-id(T) AtS, crl F[TL] => RHS if Cond [AtS'] .)
= (crl F[qid("X@@@:[" + string(Tp) + "]"), TL, qid("Y@@@:[" + string(Tp) + "]")]
=> F[qid("X@@@:[" + string(Tp) + "]"), RHS, qid("Y@@@:[" + string(Tp) + "]")] if Cond [AtS'] .)
(crl F[qid("X@@@:[" + string(Tp) + "]"), TL]
=> F[qid("X@@@:[" + string(Tp) + "]"), RHS] if Cond [AtS'] .) .
---- if f ARU replace by f(x:[s],t1,...,tn,y:[s]) -> f(x:[s],r,y:[s]) if C
---- and add f(t1,...,tn,y:[s]) -> f(r,y:[s]) if C
eq acuCohComplete(M, Tp, assoc right-id(T) AtS, rl F[TL] => RHS [AtS'] .)
= (rl F[qid("X@@@:[" + string(Tp) + "]"), TL, qid("Y@@@:[" + string(Tp) + "]")]
=> F[qid("X@@@:[" + string(Tp) + "]"), RHS, qid("Y@@@:[" + string(Tp) + "]")] [AtS'] .)
(rl F[TL, qid("Y@@@:[" + string(Tp) + "]")]
=> F[RHS, qid("Y@@@:[" + string(Tp) + "]")] [AtS'] .) .
eq acuCohComplete(M, Tp, assoc right-id(T) AtS, crl F[TL] => RHS if Cond [AtS'] .)
= (crl F[qid("X@@@:[" + string(Tp) + "]"), TL, qid("Y@@@:[" + string(Tp) + "]")]
=> F[qid("X@@@:[" + string(Tp) + "]"), RHS, qid("Y@@@:[" + string(Tp) + "]")] if Cond [AtS'] .)
(crl F[TL, qid("Y@@@:[" + string(Tp) + "]")]
=> F[RHS, qid("Y@@@:[" + string(Tp) + "]")] if Cond [AtS'] .) .
---- if f A add f(x:[s],t1,...,tn,y:[s]) -> f(x:[s],r,y:[s]) if C
---- f(x:[s],t1,...,tn) -> f(x:[s],r) if C
---- f(t1,...,tn,y:[s]) -> f(r,y:[s]) if C
ceq acuCohComplete(M, Tp, assoc AtS, rl F[TL] => RHS [AtS'] .)
= (rl F[TL] => RHS [AtS'] .)
(rl F[qid("X@@@:[" + string(Tp) + "]"), TL, qid("Y@@@:[" + string(Tp) + "]")]
=> F[qid("X@@@:[" + string(Tp) + "]"), RHS, qid("Y@@@:[" + string(Tp) + "]")] [AtS'] .)
(rl F[qid("X@@@:[" + string(Tp) + "]"), TL]
=> F[qid("X@@@:[" + string(Tp) + "]"), RHS] [AtS'] .)
(rl F[TL, qid("Y@@@:[" + string(Tp) + "]")]
=> F[RHS, qid("Y@@@:[" + string(Tp) + "]")] [AtS'] .)
if not comm in AtS
[owise] .
ceq acuCohComplete(M, Tp, assoc AtS, crl F[TL] => RHS if Cond [AtS'] .)
= (crl F[TL] => RHS if Cond [AtS'] .)
(crl F[qid("X@@@:[" + string(Tp) + "]"), TL, qid("Y@@@:[" + string(Tp) + "]")]
=> F[qid("X@@@:[" + string(Tp) + "]"), RHS, qid("Y@@@:[" + string(Tp) + "]")] if Cond [AtS'] .)
(crl F[qid("X@@@:[" + string(Tp) + "]"), TL]
=> F[qid("X@@@:[" + string(Tp) + "]"), RHS] if Cond [AtS'] .)
(crl F[TL, qid("Y@@@:[" + string(Tp) + "]")]
=> F[RHS, qid("Y@@@:[" + string(Tp) + "]")] if Cond [AtS'] .)
if not comm in AtS
[owise] .
---- Given f(t1,...,tn) -> r if C
---- if f AC add f(t1,...,tn,x:[s]) -> f(r,x:[s]) if C
eq acuCohComplete(M, Tp, assoc comm AtS, eq F[TL] = RHS [AtS'] .)
= (eq F[TL] = RHS [AtS'] .)
(eq F[TL, qid("X@@@:[" + string(Tp) + "]")] = F[RHS, qid("X@@@:[" + string(Tp) + "]")] [AtS'] .)
[owise] .
eq acuCohComplete(M, Tp, assoc comm AtS, ceq F[TL] = RHS if Cond [AtS'] .)
= (ceq F[TL] = RHS if Cond [AtS'] .)
(ceq F[TL, qid("X@@@:[" + string(Tp) + "]")] = F[RHS, qid("X@@@:[" + string(Tp) + "]")] if Cond [AtS'] .)
[owise] .
---- if f ACU replace by f(t1,...,tn,x:[s]) -> f(r,x:[s]) if C
eq acuCohComplete(M, Tp, assoc comm id(T) AtS, eq F[TL] = RHS [AtS'] .)
= (eq F[TL, qid("X@@@:[" + string(Tp) + "]")] = F[RHS, qid("X@@@:[" + string(Tp) + "]")] [AtS'] .) .
eq acuCohComplete(M, Tp, assoc comm id(T) AtS, ceq F[TL] = RHS if Cond [AtS'] .)
= (ceq F[TL, qid("X@@@:[" + string(Tp) + "]")] = F[RHS, qid("X@@@:[" + string(Tp) + "]")] if Cond [AtS'] .) .
---- if f AU replace by f(x:[s],t1,...,tn,y:[s]) -> f(x:[s],r,y:[s]) if C
ceq acuCohComplete(M, Tp, assoc id(T) AtS, eq F[TL] = RHS [AtS'] .)
= (eq F[qid("X@@@:[" + string(Tp) + "]"), TL, qid("Y@@@:[" + string(Tp) + "]")]
= F[qid("X@@@:[" + string(Tp) + "]"), RHS, qid("Y@@@:[" + string(Tp) + "]")] [AtS'] .)
if not comm in AtS .
ceq acuCohComplete(M, Tp, assoc id(T) AtS, ceq F[TL] = RHS if Cond [AtS'] .)
= (ceq F[qid("X@@@:[" + string(Tp) + "]"), TL, qid("Y@@@:[" + string(Tp) + "]")]
= F[qid("X@@@:[" + string(Tp) + "]"), RHS, qid("Y@@@:[" + string(Tp) + "]")] if Cond [AtS'] .)
if not comm in AtS .
---- if f ALU replace by f(x:[s],t1,...,tn,y:[s]) -> f(x:[s],r,y:[s]) if C
---- and add f(x:[s],t1,...,tn) -> f(x:[s],r) if C
eq acuCohComplete(M, Tp, assoc left-id(T) AtS, eq F[TL] = RHS [AtS'] .)
= (eq F[qid("X@@@:[" + string(Tp) + "]"), TL, qid("Y@@@:[" + string(Tp) + "]")]
= F[qid("X@@@:[" + string(Tp) + "]"), RHS, qid("Y@@@:[" + string(Tp) + "]")] [AtS'] .)
(eq F[qid("X@@@:[" + string(Tp) + "]"), TL]
= F[qid("X@@@:[" + string(Tp) + "]"), RHS] [AtS'] .) .
eq acuCohComplete(M, Tp, assoc left-id(T) AtS, ceq F[TL] = RHS if Cond [AtS'] .)
= (ceq F[qid("X@@@:[" + string(Tp) + "]"), TL, qid("Y@@@:[" + string(Tp) + "]")]
= F[qid("X@@@:[" + string(Tp) + "]"), RHS, qid("Y@@@:[" + string(Tp) + "]")] if Cond [AtS'] .)
(ceq F[qid("X@@@:[" + string(Tp) + "]"), TL]
= F[qid("X@@@:[" + string(Tp) + "]"), RHS] if Cond [AtS'] .) .
---- if f ARU replace by f(x:[s],t1,...,tn,y:[s]) -> f(x:[s],r,y:[s]) if C
---- and add f(t1,...,tn,y:[s]) -> f(r,y:[s]) if C
eq acuCohComplete(M, Tp, assoc right-id(T) AtS, eq F[TL] = RHS [AtS'] .)
= (eq F[qid("X@@@:[" + string(Tp) + "]"), TL, qid("Y@@@:[" + string(Tp) + "]")]
= F[qid("X@@@:[" + string(Tp) + "]"), RHS, qid("Y@@@:[" + string(Tp) + "]")] [AtS'] .)
(eq F[TL, qid("Y@@@:[" + string(Tp) + "]")]
= F[RHS, qid("Y@@@:[" + string(Tp) + "]")] [AtS'] .) .
eq acuCohComplete(M, Tp, assoc right-id(T) AtS, ceq F[TL] = RHS if Cond [AtS'] .)
= (ceq F[qid("X@@@:[" + string(Tp) + "]"), TL, qid("Y@@@:[" + string(Tp) + "]")]
= F[qid("X@@@:[" + string(Tp) + "]"), RHS, qid("Y@@@:[" + string(Tp) + "]")] if Cond [AtS'] .)
(ceq F[TL, qid("Y@@@:[" + string(Tp) + "]")]
= F[RHS, qid("Y@@@:[" + string(Tp) + "]")] if Cond [AtS'] .) .
---- if f A add f(x:[s],t1,...,tn,y:[s]) -> f(x:[s],r,y:[s]) if C
---- f(x:[s],t1,...,tn) -> f(x:[s],r) if C
---- f(t1,...,tn,y:[s]) -> f(r,y:[s]) if C
ceq acuCohComplete(M, Tp, assoc AtS, eq F[TL] = RHS [AtS'] .)
= (eq F[TL] = RHS [AtS'] .)
(eq F[qid("X@@@:[" + string(Tp) + "]"), TL, qid("Y@@@:[" + string(Tp) + "]")]
= F[qid("X@@@:[" + string(Tp) + "]"), RHS, qid("Y@@@:[" + string(Tp) + "]")] [AtS'] .)
(eq F[qid("X@@@:[" + string(Tp) + "]"), TL]
= F[qid("X@@@:[" + string(Tp) + "]"), RHS] [AtS'] .)
(eq F[TL, qid("Y@@@:[" + string(Tp) + "]")]
= F[RHS, qid("Y@@@:[" + string(Tp) + "]")] [AtS'] .)
if not comm in AtS
[owise] .
ceq acuCohComplete(M, Tp, assoc AtS, ceq F[TL] = RHS if Cond [AtS'] .)
= (ceq F[TL] = RHS if Cond [AtS'] .)
(ceq F[qid("X@@@:[" + string(Tp) + "]"), TL, qid("Y@@@:[" + string(Tp) + "]")]
= F[qid("X@@@:[" + string(Tp) + "]"), RHS, qid("Y@@@:[" + string(Tp) + "]")] if Cond [AtS'] .)
(ceq F[qid("X@@@:[" + string(Tp) + "]"), TL]
= F[qid("X@@@:[" + string(Tp) + "]"), RHS] if Cond [AtS'] .)
(ceq F[TL, qid("Y@@@:[" + string(Tp) + "]")]
= F[RHS, qid("Y@@@:[" + string(Tp) + "]")] if Cond [AtS'] .)
if not comm in AtS
[owise] .
endfm
*******************************************************************************
***
*** Interaction with the Persistent Database
***
*** In the case of Full Maude, the persistent state of the system is given by
*** a single object which maintains the database of the system. This object
*** has an attribute \texttt{db}, to keep the actual database in which all the
*** modules being entered are stored, an attribute \texttt{default}, to keep
*** the identifier of the current module by default, and attributes
*** \texttt{input} and \texttt{output} to simplify the communication of the
*** read-eval-print loop given by the \texttt{LOOP-MODE} module with the
*** database. Using the notation for classes in object-oriented modules (see
*** Section~\ref{object-oriented-modules}) we can declare the class
*** \texttt{database} as follows:
***
*** class database | db : Database, input : TermList,
*** output : QidList, default : ModId .
***
*** Since we assume that \texttt{database} is the only object class that has
*** been defined---so that the only objects of sort \texttt{Object} will
*** belong to the \texttt{database} class---to specify the admissible states
*** in the persistent state of \texttt{LOOP-MODE} for Full Maude, it is enough
*** to give the subsort declaration
***
*** subsort Object < State .
***
*** \subsection{The \texttt{CONFIGURATION+} Module}
***
*** change (2/20/2002): CONFIGURATION is now part of the prelude
***
*** fmod CONFIGURATION is
*** sort Oid Cid Attribute AttributeSet Configuration Object Msg .
***
*** subsort Attribute < AttributeSet .
*** subsorts Object Msg < Configuration .
***
*** op none : -> AttributeSet .
*** op _,_ : AttributeSet AttributeSet -> AttributeSet
*** [assoc comm id: none] .
*** op none : -> Configuration .
*** op __ : Configuration Configuration -> Configuration
*** [assoc comm id: none] .
*** op <_:_|_> : Oid Cid AttributeSet -> Object .
*** op <_:_| > : Oid Cid -> Object .
***
*** var O : Oid .
*** var C : Cid .
***
*** eq < O : C | > = < O : C | none > .
*** endfm
*******************************************************************************
***
*** Top Level Handling of the Persistent Database
***
*** Note that, since the Full Maude specification is given as a system module
***Core Maude, object-oriented declarations cannot be given directly.
*** Instead, the equivalent declarations desugaring the desired
*** object-oriented declarations have to be specified. We use also the same
*** conventions discussed in Section~\ref{omod2mod} regarding the use of
*** variables instead of class names in the objects and in the addition of
*** variables of sort \texttt{AttributeSet} to range over the additional
*** attributes. As we shall see in Chapter~\ref{crc}, this convention will
*** allow us to extend the Full Maude system in a very simple and clean way.
*** To allow the use of the object-oriented notation the predefined module
*** \texttt{CONFIGURATION}, presented in Section~\ref{omod2mod}, is included
*** in the following module \texttt{DATABASE-HANDLING}.
mod DATABASE-HANDLING is
inc META-LEVEL .
inc CONFIGURATION .
pr VIEW-META-PRETTY-PRINT .
pr VIEW-PROCESSING .
pr COMMAND-PROCESSING .
pr PREDEF-UNITS .
pr MODULE-VARIANTS .
pr ACU-COHERENCE-COMPLETION .
pr HELP .
var F : Qid .
var QIL : QidList .
var NQIL NQIL' NQIL'' : NeQidList .
vars T T' T'' T3 : Term .
var TL : TermList .
var DB DB' : Database .
vars ME ME' ME'' : ModuleExpression .
vars QIL' QIL'' : QidList .
vars MNS MNS' MNS'' MNS3 MNS4 : Set{ModuleName} .
var VE : ViewExp .
var VES : Set{ViewExp} .
vars MIS MIS' : Set{ModuleInfo} .
var VIS : Set{ViewInfo} .
vars PDS PDS' : Set{ParameterDecl} .
var B : Bool .
var I : Import .
var IL : ImportList .
var MN : ModuleName .
op initialDatabase : -> Database .
eq initialDatabase
= insTermModule('META-MODULE,
addOps(getOps(#UP#),
addSorts(getSorts(#UP#),
addImports(getImports(#UP#), upModule('META-MODULE, false)))),
insertTermView('TRIV,
''Elt.Qid]]]),
insertTermView('Bool,
insertTermView('Nat,
insertTermView('Int,
insertTermView('Rat,
insertTermView('Float,
''Float.Qid]]]),
insertTermView('String,
('view_from_to_is_endv['token[''String.Qid],'token[''TRIV.Qid],'token[
''STRING.Qid],'sort_to_.['sortToken[''Elt.Qid],'sortToken[
''String.Qid]]]),
insertTermView('Qid,
insertTermView('STRICT-WEAK-ORDER,
('view_from_to_is_endv['token[''STRICT-WEAK-ORDER.Qid],'token[''TRIV.Qid],
'token[''STRICT-WEAK-ORDER.Qid],'sort_to_.['sortToken[''Elt.Qid],
'sortToken[''Elt.Qid]]]),
insertTermView('STRICT-TOTAL-ORDER,
('view_from_to_is_endv['token[''STRICT-TOTAL-ORDER.Qid],
'token[''STRICT-WEAK-ORDER.Qid],'token[''STRICT-TOTAL-ORDER.Qid],
insertTermView('Nat<,
('view_from_to_is_endv['token[''Nat<.Qid],'token[''STRICT-TOTAL-ORDER.Qid],
insertTermView('Int<,
('view_from_to_is_endv['token[''Int<.Qid],'token[''STRICT-TOTAL-ORDER.Qid],
insertTermView('Rat<,
('view_from_to_is_endv['token[''Rat<.Qid],'token[''STRICT-TOTAL-ORDER.Qid],'token[
insertTermView('Float<,
('view_from_to_is_endv['token[''Float<.Qid],'token[''STRICT-TOTAL-ORDER.Qid],
''Float.Qid]]]),
insertTermView('String<,
('view_from_to_is_endv['token[''String<.Qid],'token[''STRICT-TOTAL-ORDER.Qid],
'token[''STRING.Qid],'sort_to_.['sortToken[''Elt.Qid],'sortToken[
''String.Qid]]]),
insertTermView('TOTAL-PREORDER,
('view_from_to_is_endv['token[''TOTAL-PREORDER.Qid],'token[''TRIV.Qid],'token[
''TOTAL-PREORDER.Qid],'sort_to_.['sortToken[''Elt.Qid],'sortToken[
''Elt.Qid]]]),
insertTermView('TOTAL-ORDER,
('view_from_to_is_endv['token[''TOTAL-ORDER.Qid],'token[''TOTAL-PREORDER.Qid],
'token[''TOTAL-ORDER.Qid],'sort_to_.['sortToken[''Elt.Qid],'sortToken[
''Elt.Qid]]]),
insertTermView('Nat<=,
('view_from_to_is_endv['token[''Nat<=.Qid],'token[''TOTAL-ORDER.Qid],
insertTermView('Int<=,
('view_from_to_is_endv['token[''Int<=.Qid],'token[''TOTAL-ORDER.Qid],
insertTermView('Rat<=,
('view_from_to_is_endv['token[''Rat<=.Qid],'token[''TOTAL-ORDER.Qid],'token[
insertTermView('Float<=,
('view_from_to_is_endv['token[''Float<=.Qid],'token[''TOTAL-ORDER.Qid],
''Float.Qid]]]),
insertTermView('String<=,
('view_from_to_is_endv['token[''String<=.Qid],'token[''TOTAL-ORDER.Qid],
'token[''STRING.Qid],'sort_to_.['sortToken[''Elt.Qid],'sortToken[
''String.Qid]]]),
insertTermView('DEFAULT,
('view_from_to_is_endv['token[''DEFAULT.Qid],'token[''TRIV.Qid],'token[
''DEFAULT.Qid],'sort_to_.['sortToken[''Elt.Qid],'sortToken[
''Elt.Qid]]]),
insertTermView('Nat0,
('view_from_to_is_endv['token[''Nat0.Qid],'token[''DEFAULT.Qid],'token[
insertTermView('Int0,
('view_from_to_is_endv['token[''Int0.Qid],'token[''DEFAULT.Qid],'token[
insertTermView('Rat0,
('view_from_to_is_endv['token[''Rat0.Qid],'token[''DEFAULT.Qid],'token[
insertTermView('Float0,
('view_from_to_is_endv['token[''Float0.Qid],'token[''DEFAULT.Qid],
insertTermView('String0,
('view_from_to_is_endv['token[''String0.Qid],'token[''DEFAULT.Qid],
'token[''STRING.Qid],'__['sort_to_.['sortToken[''Elt.Qid],'sortToken[
''String.Qid]],'op_to`term_.['bubble[''0.Qid],'bubble[''"".Qid]]]]),
insertTermView('Qid0,
('view_from_to_is_endv['token[''Qid0.Qid],'token[''DEFAULT.Qid],'token[
'op_to`term_.['bubble[''0.Qid],'bubble['''.Qid]]]]),
emptyDatabase)))))))))))))))))))))))))))))) .
*** We start by introducing a subsort \texttt{DatabaseClass} of sort
*** \texttt{Cid}, the operator declarations necessary for representing objects
*** in class \texttt{DatabaseClass} as defined above, and variables to range
*** over subclasses of class \texttt{DatabaseClass} and over attributes.
sort DatabaseClass .
subsort DatabaseClass < Cid .
op Database : -> DatabaseClass .
op db :_ : Database -> Attribute .
op input :_ : TermList -> Attribute .
op output :_ : QidList -> Attribute .
op default :_ : Header -> Attribute .
var Atts : AttributeSet .
var X@DatabaseClass : DatabaseClass .
var O : Oid .
*** Next, we introduce an auxiliary function \texttt{parseHeader} to parse
*** names of user-defined modules, and a constant \texttt{nilTermList} of sort
*** \texttt{TermList}. Note that the name of a user-defined module must be a
*** single identifier (a token) or, for parameterized modules, its name---a
*** single identifier---and its interface.
op parseHeader : Term -> Qid .
eq parseHeader('token[T]) = downQid(T) .
----eq parseHeader('_`(_`)['token[T], T']) = downQid(T) .
eq parseHeader('_`{_`}['token[T], T']) = downQid(T) .
op nilTermList : -> TermList .
*** Finally, we present the rules processing the inputs of the database. These
*** rules define the behavior of the system for the different commands,
*** modules, theories, and views entered into the system. For example, the
*** first rule processes the different types of modules entered to the system.
*** Note that the operators declared as constructors of sort \texttt{PreModule}
*** in the signature of Full Maude, given in
*** Appendix~\ref{signature-full-maude}, are declared with two arguments,
*** namely the name of the unit, or its name + its interface, and the list
*** of declarations of such a unit.
crl [module] :
< O : X@DatabaseClass | db : DB, input : (F[T, T']), output : nil, default : ME, Atts >
=> < O : X@DatabaseClass |
db : procModule(F[T, T'], DB), input : nilTermList,
output : ('Introduced 'module header2Qid(parseHeader(T)) '\n),
default : parseHeader(T), Atts >
if (F == 'fmod_is_endfm) or-else
((F == 'obj_is_endo) or-else
((F == 'obj_is_jbo) or-else
((F == 'mod_is_endm) or-else
(F == 'omod_is_endom)))) .
*** Notice the message placed in the output channel, and the change in the
*** current module by default, which is now the new module just processed.
*** Since the name of the module \texttt{T} can be complex---a parameterized
*** module---some extra parsing has to be performed by the auxiliary function
*** \texttt{parseHeader}. Similar rules are given for the processing of
*** theories and views.
crl [theory] :
< O : X@DatabaseClass | db : DB, input : (F[T, T']), output : nil, default : ME, Atts >
=> < O : X@DatabaseClass |
db : procModule(F[T, T'], DB), input : nilTermList,
output : ('Introduced 'theory header2Qid(parseHeader(T)) '\n),
default : parseHeader(T), Atts >
if (F == 'fth_is_endfth) or-else
((F == 'th_is_endth) or-else
(F == 'oth_is_endoth)) .
rl [view] :
< O : X@DatabaseClass | db : DB,
input : ('view_from_to_is`endv[T, T', T'']),
output : nil, default : ME, Atts >
=> < O : X@DatabaseClass |
db : procView('view_from_to_is_endv[T, T', T'', 'none.ViewDeclSet], DB),
input : nilTermList,
output : ('Introduced 'view header2Qid(parseHeader(T)) '\n),
default : ME, Atts > .
rl [view] :
< O : X@DatabaseClass | db : DB,
input : ('view_from_to_is_endv[T, T', T'', T3]),
output : nil, default : ME, Atts >
=> < O : X@DatabaseClass |
db : procView('view_from_to_is_endv[T, T', T'', T3], DB),
input : nilTermList,
output : ('Introduced 'view header2Qid(parseHeader(T)) '\n),
default : ME, Atts > .
*** Commands are handled by rules as well. For example, the \texttt{down},
*** \texttt{reduce}, and \texttt{rewrite} commands are handled by the
*** following rules.
rl [down] :
< O : X@DatabaseClass | db : DB, input : ('down_:_[T, T']), output : nil, default : ME, Atts >
=> < O : X@DatabaseClass |
db : getDatabase(procDownCommand('down_:_[T, T'], ME, DB)),
input : nilTermList,
output : getQidList(procDownCommand('down_:_[T, T'], ME, DB)),
default : ME, Atts > .
crl [red/rew/frew] :
< O : X@DatabaseClass | db : DB, input : (F[T]), output : QIL, default : ME, Atts >
=> < O : X@DatabaseClass |
db : getDatabase(procCommand(F[T], ME, DB)),
input : nilTermList,
output : getQidList(procCommand(F[T], ME, DB)),
default : ME, Atts >
if (F == 'parse_.) or-else
((F == 'red_.) or-else
((F == 'reduce_.) or-else
((F == 'rew_.) or-else
((F == 'rewrite_.) or-else
((F == 'frew_.) or-else
((F == 'frewrite_.) or-else
((F == 'unify_.) or-else
(F == 'id-unify_.)))))))) .
crl [search] :
< O : X@DatabaseClass | db : DB, input : (F[T, T']), output : QIL, default : ME, Atts >
=> < O : X@DatabaseClass |
db : getDatabase(procCommand(F[T, T'], ME, DB)),
input : nilTermList,
output : getQidList(procCommand(F[T, T'], ME, DB)),
default : ME, Atts >
if (F == 'search_=>_.) or-else
((F == 'search_=>1_.) or-else
((F == 'search_=>*_.) or-else
((F == 'search_=>+_.) or-else
((F == 'search_=>!_.) or-else
((F == 'search_~>_.) or-else
((F == 'search_~>1_.) or-else
((F == 'search_~>*_.) or-else
((F == 'search_~>+_.) or-else
((F == 'search_~>!_.) or-else
((F == 'match_<=?_.) or-else
(F == 'xmatch_<=?_.))))))))))) .
rl [select] :
< O : X@DatabaseClass | db : DB, input : ('select_.[T]), output : nil, default : ME, Atts >
=> < O : X@DatabaseClass | db : DB, input : nilTermList, output : nil, default : parseModExp(T), Atts > .
rl [show-modules] :
< O : X@DatabaseClass | db : DB,
input : ('show`modules`..@Command@),
output : nil, default : ME, Atts >
=> < O : X@DatabaseClass | db : DB, input : nilTermList,
output : showModules(DB), default : ME, Atts > .
rl [show-views] :
< O : X@DatabaseClass | db : DB,
input : ('show`views`..@Command@),
output : nil, default : ME, Atts >
=> < O : X@DatabaseClass | db : DB, input : nilTermList,
output : showViews(DB), default : ME, Atts > .
*** The \texttt{show module} command, which prints the specified module, or
*** the current one if no module name is specified, is handled by the
*** following rules.
crl [show-module] :
< O : X@DatabaseClass | db : DB,
input : ('show`module`..@Command@),
output : nil, default : ME, Atts >
=> < O : X@DatabaseClass | db : DB', input : nilTermList,
output : eMetaPrettyPrint(getFlatModule(ME', DB'), getTopModule(ME', DB')),
default : ME', Atts >
if < DB' ; ME' > := evalModExp(ME, DB) .
crl [show-module] :
< O : X@DatabaseClass | db : DB, input : ('show`module_.[T]), output : nil, default : ME, Atts >
=> < O : X@DatabaseClass |
db : DB', input : nilTermList,
output : eMetaPrettyPrint(getFlatModule(ME'', DB'), getTopModule(ME'', DB')),
default : ME, Atts >
if < DB' ; ME'' > := evalModExp(parseModExp(T), DB) .
crl [show-all] :
< O : X@DatabaseClass | db : DB, input : ('show`all`..@Command@),
output : nil, default : ME, Atts >
=> < O : X@DatabaseClass | db : DB', input : nilTermList,
output : eMetaPrettyPrint(getFlatModule(ME', DB'), getFlatModule(ME', DB')),
default : ME', Atts >
if < DB' ; ME' > := evalModExp(ME, DB) .
crl [show-all] :
< O : X@DatabaseClass | db : DB, input : ('show`all_.[T]), output : nil, default : ME, Atts >
=> < O : X@DatabaseClass | db : DB', input : nilTermList,
output : eMetaPrettyPrint(getFlatModule(ME', DB'), getFlatModule(ME', DB')),
default : ME, Atts >
if ME'' := parseModExp(T)
/\ < DB' ; ME' > := evalModExp(ME'', DB) .
crl [show-vars] :
< O : X@DatabaseClass | db : DB, input : ('show`vars`..@Command@),
output : nil, default : ME, Atts >
=> < O : X@DatabaseClass | db : DB', input : nilTermList,
output : eMetaPrettyPrintVars(getVars(ME', DB')),
default : ME', Atts >
if DB' := database(evalModExp(ME, DB))
/\ ME' := modExp(evalModExp(ME, DB)) .
crl [show-vars] :
< O : X@DatabaseClass | db : DB, input : ('show`vars_.[T]),
output : nil, default : ME, Atts >
=> < O : X@DatabaseClass | db : DB', input : nilTermList,
output : eMetaPrettyPrintVars(getVars(ME', DB')),
default : ME, Atts >
if ME'' := parseModExp(T)
/\ DB' := database(evalModExp(ME'', DB))
/\ ME' := modExp(evalModExp(ME'', DB)) .
crl [show-sorts] :
< O : X@DatabaseClass | db : DB, input : ('show`sorts`..@Command@), output : nil, default : ME, Atts >
=> < O : X@DatabaseClass | db : DB', input : nilTermList,
output : eMetaPrettyPrint(getSorts(getFlatModule(ME', DB'))),
default : ME', Atts >
if DB' := database(evalModExp(ME, DB))
/\ ME' := modExp(evalModExp(ME, DB)) .
crl [show-sorts] :
< O : X@DatabaseClass | db : DB, input : ('show`sorts_.[T]), output : nil, default : ME, Atts >
=> < O : X@DatabaseClass | db : DB', input : nilTermList,
output : eMetaPrettyPrint(getSorts(getFlatModule(ME', DB'))),
default : ME, Atts >
if ME'' := parseModExp(T)
/\ DB' := database(evalModExp(ME'', DB))
/\ ME' := modExp(evalModExp(ME'', DB)) .
crl [show-ops] :
< O : X@DatabaseClass | db : DB, input : ('show`ops`..@Command@), output : nil, default : ME, Atts >
=> < O : X@DatabaseClass | db : DB', input : nilTermList,
output : eMetaPrettyPrint(getFlatModule(ME', DB'), getOps(getFlatModule(ME', DB'))),
default : ME', Atts >
if DB' := database(evalModExp(ME, DB))
/\ ME' := modExp(evalModExp(ME, DB)) .
crl [show-ops] :
< O : X@DatabaseClass | db : DB, input : ('show`ops_.[T]), output : nil, default : ME, Atts >
=> < O : X@DatabaseClass | db : DB', input : nilTermList,
output : eMetaPrettyPrint(getFlatModule(ME', DB'), getOps(getFlatModule(ME', DB'))),
default : ME, Atts >
if ME'' := parseModExp(T)
/\ DB' := database(evalModExp(ME'', DB))
/\ ME' := modExp(evalModExp(ME'', DB)) .
crl [show-mbs] :
< O : X@DatabaseClass | db : DB, input : ('show`mbs`..@Command@), output : nil, default : ME, Atts >
=> < O : X@DatabaseClass | db : DB', input : nilTermList,
output : eMetaPrettyPrint(getFlatModule(ME', DB'), getMbs(getFlatModule(ME', DB'))),
default : ME', Atts >
if DB' := database(evalModExp(ME, DB))
/\ ME' := modExp(evalModExp(ME, DB)) .
crl [show-mbs] :
< O : X@DatabaseClass | db : DB, input : ('show`mbs_.[T]), output : nil, default : ME, Atts >
=> < O : X@DatabaseClass | db : DB', input : nilTermList,
output : eMetaPrettyPrint(getFlatModule(ME', DB'), getMbs(getFlatModule(ME', DB'))),
default : ME, Atts >
if ME := parseModExp(T)
/\ DB' := database(evalModExp(ME, DB))
/\ ME' := modExp(evalModExp(ME, DB)) .
crl [show-eqns] :
< O : X@DatabaseClass | db : DB, input : ('show`eqs`..@Command@), output : nil, default : ME, Atts >
=> < O : X@DatabaseClass |
db : DB', input : nilTermList,
output : eMetaPrettyPrint(getFlatModule(ME', DB'), getEqs(getFlatModule(ME', DB'))),
default : ME', Atts >
if DB' := database(evalModExp(ME, DB))
/\ ME' := modExp(evalModExp(ME, DB)) .
crl [show-eqns] :
< O : X@DatabaseClass | db : DB, input : ('show`eqs_.[T]), output : nil, default : ME, Atts >
=> < O : X@DatabaseClass |
db : DB', input : nilTermList,
output : eMetaPrettyPrint(getFlatModule(ME', DB'), getEqs(getFlatModule(ME', DB'))),
default : ME, Atts >
if ME'' := parseModExp(T)
/\ DB' := database(evalModExp(ME'', DB))
/\ ME' := modExp(evalModExp(ME'', DB)) .
crl [show-rls] :
< O : X@DatabaseClass | db : DB, input : ('show`rls`..@Command@), output : nil, default : ME, Atts >
=> < O : X@DatabaseClass | db : DB', input : nilTermList,
output : eMetaPrettyPrint(getFlatModule(ME', DB'), getRls(getFlatModule(ME', DB'))),
default : ME', Atts >
if DB' := database(evalModExp(ME, DB))
/\ ME' := modExp(evalModExp(ME, DB)) .
crl [show-rls] :
< O : X@DatabaseClass | db : DB, input : ('show`rls_.[T]), output : nil, default : ME, Atts >
=> < O : X@DatabaseClass | db : DB', input : nilTermList,
output : eMetaPrettyPrint(getFlatModule(ME', DB'), getRls(getFlatModule(ME', DB'))),
default : ME, Atts >
if ME'' := parseModExp(T)
/\ DB' := database(evalModExp(ME'', DB))
/\ ME' := modExp(evalModExp(ME'', DB)) .
crl [show-view] :
< O : X@DatabaseClass | db : DB, input : ('show`view_.[T]), output : nil, default : ME, Atts >
=> < O : X@DatabaseClass | db : DB', input : nilTermList,
output : eMetaPrettyPrint(DB', getView(parseViewExp(T), DB')),
default : ME, Atts >
if DB' := evalViewExp(parseViewExp(T), nil, DB) .
crl [set`protect_on] :
< O : X@DatabaseClass |
db : DB,
input : ('set`protect_on`.[T]),
output : QIL',
default : ME, Atts >
=> < O : X@DatabaseClass |
db : db(MIS, MNS, VIS, VES,
MNS' ME', MNS'', MNS3, QIL),
input : nilTermList,
output : (QIL' 'set 'protect header2QidList(ME') 'on '\n),
default : ME, Atts >
if ME' := parseModExp(T)
/\ unitInDb(ME', DB)
/\ db(MIS, MNS, VIS, VES, MNS', MNS'', MNS3, QIL) := DB .
crl [set`protect_off] :
< O : X@DatabaseClass |
db : db(MIS, MNS, VIS, VES, MNS', MNS'', MNS3, QIL),
input : ('set`protect_off`.[T]),
output : QIL',
default : ME, Atts >
=> < O : X@DatabaseClass |
db : db(MIS, MNS, VIS, VES, remove(MNS', ME'), MNS'', MNS3, QIL),
input : nilTermList,
output : (QIL' 'set 'protect header2QidList(ME') 'off '\n),
default : ME, Atts >
if ME' := parseModExp(T) .
crl [set`extend_on] :
< O : X@DatabaseClass |
db : DB,
input : ('set`extend_on`.[T]),
output : QIL',
default : ME, Atts >
=> < O : X@DatabaseClass |
db : db(MIS, MNS, VIS, VES,
MNS', MNS'' ME', MNS3, QIL),
input : nilTermList,
output : (QIL' 'set 'extend header2QidList(ME') 'on '\n),
default : ME, Atts >
if ME' := parseModExp(T)
/\ unitInDb(ME', DB)
/\ db(MIS, MNS, VIS, VES, MNS', MNS'', MNS3, QIL) := DB .
crl [set`extend_off] :
< O : X@DatabaseClass |
db : db(MIS, MNS, VIS, VES, MNS', MNS'', MNS3, QIL),
input : ('set`extend_off`.[T]),
output : QIL',
default : ME, Atts >
=> < O : X@DatabaseClass |
db : db(MIS, MNS, VIS, VES, MNS', remove(MNS'', ME'), MNS3, QIL),
input : nilTermList,
output : (QIL' 'set 'extend header2QidList(ME') 'off '\n),
default : ME, Atts >
if ME' := parseModExp(T) .
crl [set`include_on] :
< O : X@DatabaseClass |
db : DB,
input : ('set`include_on`.[T]),
output : QIL',
default : ME, Atts >
=> < O : X@DatabaseClass |
db : db(MIS, MNS, VIS, VES,
MNS', MNS'', MNS3 . ME', QIL),
input : nilTermList,
output : (QIL' 'set 'include header2QidList(ME') 'on '\n),
default : ME, Atts >
if ME' := parseModExp(T)
----/\ unitInDb(ME', DB)
/\ db(MIS, MNS, VIS, VES, MNS', MNS'', MNS3, QIL) := DB .
crl [set`include_off] :
< O : X@DatabaseClass |
db : db(MIS, MNS, VIS, VES, MNS', MNS'', MNS3, QIL),
input : ('set`include_off`.[T]),
output : QIL',
default : ME, Atts >
=> < O : X@DatabaseClass |
db : db(MIS, MNS, VIS, VES, MNS', MNS'', remove(MNS3, ME'), QIL),
input : nilTermList,
output : (QIL' 'set 'include header2QidList(ME') 'off '\n),
default : ME, Atts >
if ME' := parseModExp(T) .
crl [load] :
< O : X@DatabaseClass |
db : DB,
input : ('load_.[T]),
output : QIL',
default : ME, Atts >
=> < O : X@DatabaseClass |
db : getDatabase(procLoad(T, ME, DB)),
input : nilTermList,
output : getQidList(procLoad(T, ME, DB)),
default : ME, Atts >
if ME' := parseModExp(T) .
eq 'rm`ids`..@Command@ = 'remove`identity`attributes`..@Command@ .
eq 'rm`ids_.[T] = 'remove`identity`attributes_.[T] .
crl [remove-id-attributes] :
< O : X@DatabaseClass | db : DB,
input : ('remove`identity`attributes`..@Command@),
output : nil, default : ME, Atts >
=> < O : X@DatabaseClass | db : DB', input : nilTermList,
output : (eMetaPrettyPrint(getFlatModule(ME', DB'), removeIds(getFlatModule(ME', DB')))),
default : ME', Atts >
if < DB' ; ME' > := evalModExp(ME, DB) .
crl [remove-id-attributes] :
< O : X@DatabaseClass | db : DB, input : ('remove`identity`attributes_.[T]), output : nil, default : ME, Atts >
=> < O : X@DatabaseClass |
db : DB', input : nilTermList,
output : (eMetaPrettyPrint(getFlatModule(ME'', DB'), removeIds(getFlatModule(ME'', DB')))),
default : ME, Atts >
if < DB' ; ME'' > := evalModExp(parseModExp(T), DB) .
crl [remove-assoc-attributes] :
< O : X@DatabaseClass | db : DB,
input : ('remove`assoc`attributes`..@Command@),
output : nil, default : ME, Atts >
=> < O : X@DatabaseClass | db : DB', input : nilTermList,
output : (eMetaPrettyPrint(getFlatModule(ME', DB'), removeLonelyAssocs(getFlatModule(ME', DB')))),
default : ME', Atts >
if < DB' ; ME' > := evalModExp(ME, DB) .
crl [remove-assoc-attributes] :
< O : X@DatabaseClass | db : DB, input : ('remove`assoc`attributes_.[T]), output : nil, default : ME, Atts >
=> < O : X@DatabaseClass |
db : DB', input : nilTermList,
output : (eMetaPrettyPrint(getFlatModule(ME'', DB'), removeLonelyAssocs(getFlatModule(ME'', DB')))),
default : ME, Atts >
if < DB' ; ME'' > := evalModExp(parseModExp(T), DB) .
crl [acu-coherence-completion] :
< O : X@DatabaseClass | db : DB,
input : ('acu`coherence`completion`..@Command@),
output : nil, default : ME, Atts >
=> < O : X@DatabaseClass | db : DB', input : nilTermList,
output : (eMetaPrettyPrint(getFlatModule(ME', DB'), acuCohComplete(getFlatModule(ME', DB')))),
default : ME', Atts >
if < DB' ; ME' > := evalModExp(ME, DB) .
crl [acu-coherence-completion] :
< O : X@DatabaseClass | db : DB, input : ('acu`coherence`completion_.[T]), output : nil, default : ME, Atts >
=> < O : X@DatabaseClass |
db : DB', input : nilTermList,
output : (eMetaPrettyPrint(getFlatModule(ME'', DB'), acuCohComplete(getFlatModule(ME'', DB')))),
default : ME, Atts >
if < DB' ; ME'' > := evalModExp(parseModExp(T), DB) .
rl [error] :
< O : X@DatabaseClass |
db : db(MIS, MNS, VIS, VES, MNS', MNS'', MNS3, NQIL),
input : TL, output : nil, default : ME, Atts >
=> < O : X@DatabaseClass |
db : db(MIS, MNS, VIS, VES, MNS', MNS'', MNS3, nil),
input : TL, output : NQIL, default : ME, Atts > .
*** Auxiliary Functions
op showViews : Database -> QidList .
op showModules : Database -> QidList .
eq showViews(db(MIS, MNS, VIS, (VE # VES), MNS', MNS'', MNS3, QIL))
= (eMetaPrettyPrint(VE) '\n
showViews(db(MIS, MNS, VIS, VES, MNS', MNS'', MNS3, QIL))) .
eq showViews(
db(MIS, MNS, VIS, emptyViewExpSet, MNS', MNS'', MNS3, QIL))
= nil .
eq showModules(
db(MIS, (MN . MNS), VIS, VES, MNS', MNS'', MNS3, QIL))
= (eMetaPrettyPrint(MN) '\n
showModules(db(MIS, MNS, VIS, VES, MNS', MNS'', MNS3, QIL))) .
eq showModules(
db(MIS, emptyModuleNameSet, VIS, VES, MNS', MNS'', MNS3, QIL))
= nil .
rl [help] :
< O : X@DatabaseClass | input : ('help`..@Command@), output : QIL, Atts >
=> < O : X@DatabaseClass | input : nilTermList, output : fm-help, Atts > .
endm
*******************************************************************************
fmod TEXT-STYLE is
pr META-LEVEL .
var QL : QidList .
op green : QidList -> QidList .
eq green(QL) = '\g QL '\o .
op yellow : QidList -> QidList .
eq yellow(QL) = '\y QL '\o .
op red : QidList -> QidList .
eq red(QL) = '\r QL '\o .
op bold : QidList -> QidList .
eq bold(QL) = '\! QL '\o .
endfm
*******************************************************************************
***
*** The Full Maude Module
***
*** We now give the rules to initialize the loop, and to specify the
*** communication between the loop---the input/output of the system---and the
*** database. Depending on the kind of input that the database receives, its
*** state will be changed, or some output will be generated.
mod FULL-MAUDE is
pr META-FULL-MAUDE-SIGN .
pr DATABASE-HANDLING .
inc LOOP-MODE .
pr BANNER .
*** The state of the persistent system, which is supported by the built-in
*** module \texttt{LOOP-MODE}, described in Section~\ref{loop}, is represented
*** as a single object.
subsort Object < State .
op o : -> Oid .
op init : -> System .
var Atts : AttributeSet .
var X@DatabaseClass : DatabaseClass .
var O : Oid .
var DB : Database .
var ME : Header .
var QI : Qid .
vars QIL QIL' QIL'' : QidList .
var TL : TermList .
var N : Nat .
vars RP RP' : ResultPair .
rl [init] :
init
=> [nil,
< o : Database |
db : initialDatabase,
input : nilTermList, output : nil,
default : 'CONVERSION >,
('\n '\t '\s '\s '\s '\s string2qidList(banner) '\n)] .
*** When some text has been introduced in the loop, the first argument of the
*** operator \verb~[_,_,_,]~ is different from \texttt{nil}, and we can use
*** this fact to activate the following rule, that enters an input such as a
*** module or a command from the user into the database. The constant
*** \texttt{GRAMMAR} names the module containing the signature defining the
*** top level syntax of Full Maude (see Section~\ref{sec:signature} and
*** Appendix~\ref{signature-full-maude}). This signature is used by the
*** \texttt{metaParse} function to parse the input. PD the input is
*** syntactically valid\footnote{Of course, the input may be syntactically
*** valid, but not semantically valid, since further processing---for example,
*** of bubbles---may reveal a semantic inconsistency.}, the parsed input is
*** placed in the \texttt{input} attribute of the database object; otherwise,
*** an error message is placed in the output channel of the loop.
rl [in] :
[QI QIL,
< O : X@DatabaseClass |
db : DB, input : nilTermList, output : nil, default : ME, Atts >,
QIL']
=> if metaParse(GRAMMAR, QI QIL, '@Input@) :: ResultPair
then [nil,
< O : X@DatabaseClass | db : DB,
input : getTerm(metaParse(GRAMMAR, QI QIL, '@Input@)),
output : nil, default : ME, Atts >,
QIL']
else [nil,
< O : X@DatabaseClass | db : DB, input : nilTermList,
output : ('\r 'Warning:
printSyntaxError(metaParse(GRAMMAR, QI QIL, '@Input@),
QI QIL)
'\n
'\r 'Error: '\o 'No 'parse 'for 'input. '\n),
default : ME, Atts >,
QIL']
fi .
*** When the \texttt{output} attribute of the persistent object contains a
*** nonempty list of quoted identifiers, the \texttt{out} rule moves it to the
*** third argument of the loop. Then the Core Maude system displays it in the
*** terminal.
rl [out] :
[QIL,
< O : X@DatabaseClass |
db : DB, input : TL, output : (QI QIL'), default : ME, Atts >,
QIL'']
=> [QIL,
< O : X@DatabaseClass |
db : DB, input : TL, output : nil, default : ME, Atts >,
(QI QIL' QIL'')] .
endm
*******************************************************************************
loop init .
---- trace exclude FULL-MAUDE .
---- set show loop stats on .
---- set show loop timing on .
---- set show advisories on .