| 1 | | % (c) 2009-2026 Lehrstuhl fuer Softwaretechnik und Programmiersprachen, |
| 2 | | % Heinrich Heine Universitaet Duesseldorf |
| 3 | | % This software is licenced under EPL 1.0 (http://www.eclipse.org/org/documents/epl-v10.html) |
| 4 | | |
| 5 | | :- module(bmachine_construction,[reset_bmachine_construction/0, |
| 6 | | check_machine/4, |
| 7 | | type_in_machine_l/7, |
| 8 | | type_open_predicate_with_quantifier/6, |
| 9 | | get_constructed_machine_name/2, get_constructed_machine_name_and_filenumber/3, |
| 10 | | type_open_formula/8, |
| 11 | | create_scope/6, % create type-checking scope |
| 12 | | filter_linking_invariant/3, |
| 13 | | machine_promotes_operations/2, |
| 14 | | machine_hides_unpromoted_operation/4, |
| 15 | | used_machine_not_included_anywhere/3, |
| 16 | | external_procedure_used/1, |
| 17 | | abstract_variable_removed_in/3, |
| 18 | | dummy_machine_name/2, |
| 19 | | extract_only_definitions/4]). |
| 20 | | |
| 21 | | :- use_module(module_information,[module_info/2]). |
| 22 | | :- module_info(group,typechecker). |
| 23 | | :- module_info(description,'This module contains the rules for loading, including, seeing, etc. B machines, scope of constants, variables, parameters, etc.'). |
| 24 | | |
| 25 | | :- use_module(library(lists)). |
| 26 | | :- use_module(library(avl)). |
| 27 | | |
| 28 | | :- use_module(self_check). |
| 29 | | :- use_module(tools). |
| 30 | | :- use_module(error_manager). |
| 31 | | :- use_module(debug). |
| 32 | | :- use_module(preferences). |
| 33 | | |
| 34 | | :- use_module(btypechecker). |
| 35 | | :- use_module(b_ast_cleanup). |
| 36 | | :- use_module(bsyntaxtree). |
| 37 | | :- use_module(bmachine_structure). |
| 38 | | :- use_module(pragmas). |
| 39 | | :- use_module(b_global_sets,[register_enumerated_sets/2]). |
| 40 | | |
| 41 | | :- use_module(bmachine_static_checks). |
| 42 | | :- use_module(tools_lists,[ord_member_nonvar_chk/2, remove_dups_keep_order/2]). |
| 43 | | |
| 44 | | :- use_module(translate,[print_machine/1]). |
| 45 | | |
| 46 | | |
| 47 | | :- set_prolog_flag(double_quotes, codes). |
| 48 | | |
| 49 | | %maximum_type_errors(100). |
| 50 | | |
| 51 | | :- dynamic debug_machine/0. |
| 52 | | :- dynamic abstract_variable_removed_in/3. |
| 53 | | |
| 54 | | :- use_module(pref_definitions,[b_get_important_preferences_from_raw_machine/2]). |
| 55 | | set_important_prefs_from_machine(Main,Machines) :- |
| 56 | | find_machine(Main,Machines,_MType,_Header,RawMachine), |
| 57 | ? | get_raw_model_type(Main,Machines,RawModelType),!, |
| 58 | | b_get_important_preferences_from_raw_machine(RawMachine,RawModelType), |
| 59 | | check_important_annotions_from_machine(RawMachine). |
| 60 | | |
| 61 | | check_important_annotions_from_machine(RawMachine) :- |
| 62 | ? | member(definitions(_Pos,Defs),RawMachine), |
| 63 | | member(expression_definition(DPOS,'PROB_REQUIRED_VERSION',[],RawValue),Defs),!, |
| 64 | | (RawValue = string(VPos,Version) |
| 65 | | -> add_message(bmachine_construction,'Checking PROB_REQUIRED_VERSION: ',Version,VPos), |
| 66 | | (check_version(Version,VPos) -> true ; true) |
| 67 | | ; add_warning(bmachine_construction,'PROB_REQUIRED_VERSION must provide a version number string.','',DPOS) |
| 68 | | ). |
| 69 | | check_important_annotions_from_machine(_). |
| 70 | | |
| 71 | | :- use_module(version,[compare_against_current_version/2,full_version_str/1]). |
| 72 | | check_version(VersAtom,DPOS) :- atom_codes(VersAtom,Codes), |
| 73 | | split_chars(Codes,".",VCNrs), |
| 74 | | maplist(codes_to_number(DPOS),VCNrs,VNrs), |
| 75 | | compare_against_current_version(VNrs,Result), |
| 76 | | (Result = current_older |
| 77 | | -> full_version_str(Cur), |
| 78 | | ajoin(['This model requires at newer version of ProB than ',Cur,'. Download at least version: '],Msg), |
| 79 | | add_warning(prob_too_old,Msg,VersAtom,DPOS) |
| 80 | | ; true). |
| 81 | | |
| 82 | | codes_to_number(DPOS,C,A) :- |
| 83 | | catch(number_codes(A,C), error(syntax_error(_N),_), |
| 84 | | (atom_codes(AA,C), |
| 85 | | add_warning(bmachine_construction,'Illegal part of version number (use only numbers separated by dots): ',AA,DPOS),fail)). |
| 86 | | |
| 87 | | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% |
| 88 | | |
| 89 | | :- use_module(preferences,[temporary_set_preference/3,reset_temporary_preference/2]). |
| 90 | | |
| 91 | | % typecheck complete machines (incl. includes) |
| 92 | | check_machine(MainName,MachinesMayContainGenerated,Result,FinalErrors) :- |
| 93 | | clear_warnings, |
| 94 | | debug_println(9,checking_machine(MainName)), |
| 95 | | temporary_set_preference(perform_stricter_static_checks,true,CHNG), |
| 96 | | strip_global_pragmas(MachinesMayContainGenerated,Machines,_WasGenerated), % TODO: is generated still used? |
| 97 | | set_important_prefs_from_machine(MainName,Machines), % set important prefs before type-checking,... |
| 98 | | check_main_machine_file_origin(MainName,Machines), |
| 99 | | % we need to find all SEES/USES declarations, because all references |
| 100 | | % refer to the same machine and that has to be included exactly once. |
| 101 | | find_uses(Machines,GlobalUses,NotIncluded,Errors,E1), |
| 102 | | % if a seen/used machine was not included, we include it by constructing |
| 103 | | % a dummy machine that extends the seen/used machine and the origional main machine |
| 104 | | extend_not_included_uses(NotIncluded,MainName,NewMainName,Machines,IMachines), |
| 105 | | % figure out the right order of machines, so that each machine is |
| 106 | | % type-checked before a dependend machine is loaded |
| 107 | | machine_order(IMachines,Order), |
| 108 | | assert_machine_order(Order), |
| 109 | | % expand (= type-check + includes) machines in the given order |
| 110 | | expand_machines(Order,IMachines,GlobalUses,[],Results1,E1,E2), |
| 111 | | % until now, the initialisation section consists of a list of init_stmt(MachineName,Desc,Substitution) |
| 112 | | % fold_initialisation merges those to one substitution, respecting the dependencies |
| 113 | | % between the machines |
| 114 | | maplist(fold_initialisation(Order),Results1,Results), |
| 115 | | % find main machine |
| 116 | | memberchk(machine(NewMainName,MainMachine),Results), %nl,print('MAIN:'),nl,print_machine(MainMachine), |
| 117 | | % if the main machine has parameters, we convert them to global sets resp. constants |
| 118 | | convert_parameters_to_global_sets(E2,[],MainMachine,Result1), |
| 119 | | % add some additional informations about the machine |
| 120 | | add_machine_infos(MainName,Machines,Results,Result1,Result), |
| 121 | | ( debug_machine -> print_machine(Result); true), |
| 122 | | %% comment in to pretty print all machines: |
| 123 | | %( member(machine(Name,Mchx),Results), format('~n*** Machine ~w~n',[Name]), print_machine(Mchx),nl,fail ; true), |
| 124 | | % finalize the list of errors, remove duplicates |
| 125 | | sort(Errors,FinalErrors), |
| 126 | | % output warnings |
| 127 | | show_warnings, |
| 128 | | % run static checks on the resulting machine |
| 129 | | static_check_main_machine(Result), |
| 130 | | reset_temporary_preference(perform_stricter_static_checks,CHNG). |
| 131 | | check_machine(Main,_,Result,FinalErrors) :- |
| 132 | | add_internal_error('Internal error: Checking the machine failed: ', |
| 133 | | check_machine(Main,_,Result,FinalErrors)), |
| 134 | | fail. |
| 135 | | |
| 136 | | % remove global pragrams at top-level and assert them |
| 137 | | strip_global_pragmas([],[],false). |
| 138 | | strip_global_pragmas([generated(POS,M)|Ms],MachinesOut,true) :- !, % @generated pragma used at top of file |
| 139 | | assertz(pragmas:global_pragma(generated,POS)), |
| 140 | | strip_global_pragmas([M|Ms],MachinesOut,_). |
| 141 | | strip_global_pragmas([unit_alias(_,Alias,Content,M)|Ms],MachinesOut,true) :- !, |
| 142 | | assertz(pragmas:global_pragma(unit_alias,[Alias|Content])), |
| 143 | | strip_global_pragmas([M|Ms],MachinesOut,_). |
| 144 | | strip_global_pragmas([M|Ms],[M|SMs],WasGenerated) :- |
| 145 | | strip_global_pragmas(Ms,SMs,WasGenerated). |
| 146 | | |
| 147 | | |
| 148 | | fold_initialisation(Order,machine(Name,Sections),machine(Name,NewSections)) :- |
| 149 | | select_section(initialisation,List,Subst,Sections,NewSections), |
| 150 | | maplist(extract_init_substitutions(List),Order,LSubstitutions), |
| 151 | | append(LSubstitutions,Substitutions), |
| 152 | | create_init_sequence(Substitutions,Subst). |
| 153 | | extract_init_substitutions(Unsorted,Name,Substitutions) :- |
| 154 | | convlist(unzip_init(Name),Unsorted,Substitutions). % keep inits for Name |
| 155 | | unzip_init(Name,init_stmt(Name,Subst),Subst). |
| 156 | | create_init_sequence([],Subst) :- !, create_texpr(skip,subst,[generated],Subst). |
| 157 | | create_init_sequence([I],I) :- !. |
| 158 | | create_init_sequence(L,Sequence) :- |
| 159 | | (L = [First|_], get_texpr_info(First,AllInfos), extract_pos_infos(AllInfos,Pos) -> true ; Pos=[]), |
| 160 | | % TODO: try and merge first and last position info |
| 161 | | (get_preference(allow_overriding_initialisation,true), |
| 162 | | override_initialisation_sequence(L,NL) |
| 163 | | -> NewList=NL ; NewList=L), |
| 164 | | create_texpr(sequence(NewList),subst,[initial_sequence|Pos],Sequence). |
| 165 | | |
| 166 | | :- use_module(b_read_write_info,[get_accessed_vars/4]). |
| 167 | | % override initialisation sequence, remove unnecessary earlier assignments (which may time-out, ...) |
| 168 | | % in future we may inline equalities into becomes_such that, e.g., x :: S ; x := 1 --> x :: X /\ {1} |
| 169 | | % currently x :: S ; x := 1 gets simplified to skip ; x := 1 |
| 170 | | override_initialisation_sequence(List,NewList) :- |
| 171 | | append(Prefix,[Last],List), |
| 172 | | Prefix = [_|_], % there are some earlier initialisation statements to simplify |
| 173 | | get_accessed_vars(Last,[],LIds,Read), |
| 174 | | ord_intersection(LIds,Read,RWIds), |
| 175 | | (RWIds = [] |
| 176 | | -> true |
| 177 | | ; add_warning(b_machine_construction,'Initialisation (override) statement reads written variables:',RWIds,Last) |
| 178 | | ), |
| 179 | | process_override(Last,Prefix, NewLast, SPrefix), |
| 180 | | append(SPrefix,[NewLast],NewList). |
| 181 | | |
| 182 | | |
| 183 | | process_override(b(parallel(List),subst,Info), Prefix, |
| 184 | | b(parallel(NewList),subst,Info), NewPrefix) :- !, |
| 185 | | l_process_override(List,Prefix,NewList,NewPrefix). |
| 186 | | process_override(Subst, Prefix, NewSubst, NewPrefix) :- |
| 187 | | create_after_pred(Subst,AfterPred), |
| 188 | | get_accessed_vars(Subst,[],Ids,Read), |
| 189 | | % write(after_pred(Ids, read(Read))),nl, translate:print_bexpr(AfterPred),nl, |
| 190 | | ord_intersection(Read,Ids,RWIds), |
| 191 | | (RWIds=[] |
| 192 | | -> maplist(try_simplify_init_stmt(Ids,AfterPred,Keep),Prefix,NewPrefix), |
| 193 | | !, |
| 194 | | (Keep==merged_override_stmt |
| 195 | | -> NewSubst = b(skip,subst,[was(Subst)]) |
| 196 | | ; NewSubst = Subst |
| 197 | | ) |
| 198 | | ; add_warning(b_machine_construction,'Initialisation statement reads written variables:',RWIds,Subst), |
| 199 | | fail % we actually have a before after predicate which may modify RWIds |
| 200 | | ). |
| 201 | | process_override(Subst, Prefix , Subst, Prefix) :- add_message(b_machine_construction,'Keeping: ',Subst,Subst). |
| 202 | | |
| 203 | | l_process_override([],Prefix,[],Prefix). |
| 204 | | l_process_override([H|List],Prefix,[H1|NewList],NewPrefix) :- |
| 205 | | process_override(H,Prefix,H1,Prefix1), |
| 206 | | l_process_override(List,Prefix1,NewList,NewPrefix). |
| 207 | | |
| 208 | | :- use_module(library(ordsets)). |
| 209 | | simplify_init_stmt(b(parallel(List),subst,I),OverrideIds,AfterPred,Keep,b(parallel(SList),subst,I)) :- !, |
| 210 | | maplist(try_simplify_init_stmt(OverrideIds,AfterPred,Keep),List,SList). |
| 211 | | simplify_init_stmt(Assign,OverrideIds,AfterPred,Keep,NewSubst) :- |
| 212 | | get_accessed_vars(Assign,[],AssignIds,_Read), |
| 213 | | (ord_subset(OverrideIds,AssignIds), |
| 214 | | merge_statement(Assign,AssignIds,AfterPred,NewSubst), |
| 215 | | Keep = merged_override_stmt |
| 216 | | -> % we need to remove the override assign, if it is non-det. |
| 217 | | add_message(b_machine_construction,'Adapting initialisation due to override: ',NewSubst,Assign) |
| 218 | | ; ord_subset(AssignIds,OverrideIds) |
| 219 | | % The assignment is useless, will be completely overriden |
| 220 | | -> NewSubst = b(skip,subst,[was(Assign)]), |
| 221 | | add_message(b_machine_construction,'Removing initialisation due to override: ',Assign,Assign), |
| 222 | | Keep = keep_override_stmt |
| 223 | | ). |
| 224 | | % TODO: we could simplify IF-THEN-ELSE, ... and other constructs |
| 225 | | |
| 226 | | % Note: the merging assumes the initialisation before the override assigns each overriden variable only once |
| 227 | | try_simplify_init_stmt(OverrideIds,AfterPred,Keep,Stmt,NewStmt) :- |
| 228 | | (simplify_init_stmt(Stmt,OverrideIds,AfterPred,Keep,N) |
| 229 | | -> NewStmt=N ; NewStmt=Stmt). |
| 230 | | |
| 231 | | merge_statement(b(Subst,subst,Info),AssignIds,AfterPred,b(NewSubst,subst,Info)) :- |
| 232 | | merge_stmt_aux(Subst,AssignIds,AfterPred,NewSubst). |
| 233 | | |
| 234 | | merge_stmt_aux(becomes_such(Ids,Pred),_AssignIds,AfterPred,becomes_such(Ids,NewPred)) :- |
| 235 | | conjunct_predicates([AfterPred,Pred],NewPred). |
| 236 | | merge_stmt_aux(becomes_element_of(Ids,Set),_,AfterPred2,becomes_such(Ids,NewPred)) :- |
| 237 | | create_couple(Ids,Couple), |
| 238 | | safe_create_texpr(member(Couple,Set),pred,AfterPred1), |
| 239 | | conjunct_predicates([AfterPred1,AfterPred2],NewPred). |
| 240 | | |
| 241 | | create_after_pred(b(Subst,subst,Info),Pred) :- create_after_pred_aux(Subst,Info,Pred). |
| 242 | | |
| 243 | | create_after_pred_aux(assign_single_id(Id,RHS),Info,b(equal(Id,RHS),pred,Info)). |
| 244 | | create_after_pred_aux(assign(LHS,RHS),_Info,Conj) :- % TODO: split assignments so that we can individually apply preds |
| 245 | | maplist(create_equality,LHS,RHS,Eqs), |
| 246 | | conjunct_predicates(Eqs,Conj). |
| 247 | | % the following two are non-deterministic; hence we need to remove the substitutions |
| 248 | | % in case we have managed to merge them into an earlier becomes_such,... (otherwise we may do a second non-det incompatible choice) |
| 249 | | create_after_pred_aux(becomes_element_of(Id,Set),Info,b(member(Couple,Set),pred,Info)) :- |
| 250 | | create_couple(Id,Couple). |
| 251 | | create_after_pred_aux(becomes_such(_,Pred),_Info,Pred). |
| 252 | | |
| 253 | | |
| 254 | | % ------------------------- |
| 255 | | |
| 256 | | add_machine_infos(MainName,Machines,CheckedMachines,Old,New) :- |
| 257 | ? | get_raw_model_type(MainName,Machines,RawModelType), functor(RawModelType,ModelType,_), % argument is position |
| 258 | | % model type could be machine or system (or model ?) |
| 259 | | !, |
| 260 | | append_to_section(meta,[model_type/ModelType,hierarchy/Hierarchy,header_pos/HeaderPosList],Old,NewT), |
| 261 | | get_refinement_hierarchy(MainName,Machines,Hierarchy), |
| 262 | | find_machine_header_positions(Machines,HeaderPosList), |
| 263 | | add_refined_machine(Hierarchy,CheckedMachines,NewT,New). |
| 264 | | get_refinement_hierarchy(Main,Machines,[Main|Abstractions]) :- |
| 265 | | ( find_refinement(Machines,Main,Abstract) -> |
| 266 | | get_refinement_hierarchy(Abstract,Machines,Abstractions) |
| 267 | | ; |
| 268 | | Abstractions = []). |
| 269 | | find_refinement([M|Rest],Name,Abstract) :- |
| 270 | | ( get_constructed_machine_name(M,Name) -> |
| 271 | | refines(M,Abstract) |
| 272 | | ; |
| 273 | | find_refinement(Rest,Name,Abstract)). |
| 274 | | |
| 275 | | find_machine_header_positions(Machines,SRes) :- |
| 276 | | Header = machine_header(Pos,_Nm,_Paras), |
| 277 | | findall(Name/Pos,find_machine(Name,Machines,_Type,Header,_Sections),Res), |
| 278 | | sort(Res,SRes). |
| 279 | | |
| 280 | | :- use_module(specfile,[animation_minor_mode/1]). |
| 281 | | % check whether the main machine has filenumber 1; if not something strange is going on. |
| 282 | | % an example can be found in prob_examples/public_examples/B/ErrorMachines/IllegalSeesIncludes/WrongNameM1.mch |
| 283 | | check_main_machine_file_origin(MainName,Machines) :- |
| 284 | ? | member(M,Machines), get_machine_parameters(M,MainName,_,Position), |
| 285 | | !, |
| 286 | | (Position = none -> true |
| 287 | | ; get_nr_name(Position,Number,Name) |
| 288 | | -> (Number=1 -> true |
| 289 | | ; ajoin(['Main machine name ',MainName,' overriden by machine in file ',Number,' :'],Msg), |
| 290 | | add_error(bmachine_construction,Msg,Name,Position)) |
| 291 | | ; add_error(bmachine_construction,'Could not extract file number and name:',Position) |
| 292 | | ). |
| 293 | | check_main_machine_file_origin(MainName,_) :- |
| 294 | | add_error(bmachine_construction,'Could not extract file number and name for main machine:',MainName). |
| 295 | | get_nr_name(none,Nr,Name) :- !, Nr=1,Name=none. |
| 296 | | get_nr_name(1,Nr,Name) :- !, Nr=1,Name=none. % TLA mode, animation_minor_mode(tla) not yet set and positions are numbers |
| 297 | | get_nr_name(Position,Number,Name) :- extract_file_number_and_name(Position,Number,Name). |
| 298 | | |
| 299 | | add_refined_machine([_Main,Refined|_],Machines,Old,New) :- |
| 300 | | member(machine(Refined,Body),Machines),!, |
| 301 | | append_to_section(meta,[refined_machine/Body],Old,New). |
| 302 | | add_refined_machine(_,_,M,M). % not refining |
| 303 | | |
| 304 | | convert_parameters_to_global_sets(Ein,Eout) --> |
| 305 | | % extract and remove parameters and constraints |
| 306 | | select_section(parameters,PP,[]), |
| 307 | | select_section(internal_parameters,IP,[]), |
| 308 | | {create_texpr(truth,pred,[],Truth)}, |
| 309 | | select_section(constraints,C,Truth), |
| 310 | | % split parameters into sets and scalars |
| 311 | | { split_list(is_set_parameter,PP,Sets,Scalars), |
| 312 | | foldl(type_set_parameter,Sets,Ein,Eout) }, |
| 313 | | % put the sets to the deferred sets |
| 314 | | append_to_section(deferred_sets,Sets), |
| 315 | | % and the scalars to the constants |
| 316 | | append_to_section(concrete_constants,Scalars), |
| 317 | | append_to_section(concrete_constants,IP), |
| 318 | | % the scalars should be typed by constraints, |
| 319 | | % so move the constraints to the properties |
| 320 | | select_section(properties,OldProps,NewProps), |
| 321 | | {conjunct_predicates([C,OldProps],NewProps)}. |
| 322 | | is_set_parameter(TExpr) :- |
| 323 | | % upper case identifiers denote set parameters, otherwise scalars |
| 324 | | get_texpr_id(TExpr,Name),is_upper_case(Name). |
| 325 | | type_set_parameter(TExpr,Ein,Eout) :- |
| 326 | | get_texpr_id(TExpr,Name), |
| 327 | | get_texpr_type(TExpr,Type), |
| 328 | | get_texpr_pos(TExpr,Pos), |
| 329 | | % we directly type the deferred set |
| 330 | | unify_types_werrors(set(global(Name)),Type,Pos,'PARAMETER',Ein,Eout). |
| 331 | | |
| 332 | | |
| 333 | | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% |
| 334 | | % included machines |
| 335 | | |
| 336 | | expand_machines([],_,_,M,M,Errors,Errors). |
| 337 | | expand_machines([M|Rest],Machines,GlobalUses,Typed,Result,Ein,Eout) :- |
| 338 | ? | ( expand_machine(M,Machines,GlobalUses,Typed,New,Ein,E1) -> true |
| 339 | | ; add_error(bmachine_construction,'Expansion of machine failed:',M),fail), |
| 340 | | expand_machines(Rest,Machines,GlobalUses,[machine(M,New)|Typed],Result,E1,Eout). |
| 341 | | |
| 342 | | % resolve all includes and typecheck the machine |
| 343 | | % expand_machine(Name,Machines,TypeChecked,Expanded) : |
| 344 | | % Name of the Machine to expand |
| 345 | | % Machines contains the list of all loaded machines |
| 346 | | % TypeChecked contains the list of all expanded machines so far |
| 347 | | % Expanded is the resulting machine |
| 348 | | expand_machine(Name,Machines,GlobalUses,TypeChecked,Expanded,Ein,Eout) :- |
| 349 | | debug_format(9,'~nExpanding machine ~w~n',[Name]), |
| 350 | | % find the machine in the list |
| 351 | | find_machine(Name,Machines,MType,Header,RawMachineWithPragmas), |
| 352 | | % remove pragmas for later reattachment |
| 353 | | strip_machine_section_pragmas(RawMachineWithPragmas,RawMachine,_Pragmas), |
| 354 | | % look for abstract machine |
| 355 | | get_abstractions(Name,Machines,TypeChecked,Abstractions), |
| 356 | | % merge all used and seen machines |
| 357 | | use_and_see_machines(RawMachine,TypeChecked,SeenRefs), |
| 358 | | % merge all included machines into one machine |
| 359 | | include_machines(RawMachine, TypeChecked, GlobalUses, Includes, Parameters, Included, Promotes), |
| 360 | | % Parameters contains now a list of parameters for each included machine |
| 361 | | % Included contains now a machine that represents all included machines |
| 362 | | % their parameters are renamed to internal_parameters |
| 363 | | append([Abstractions,Included,SeenRefs],RefMachines), |
| 364 | | % typecheck this machine |
| 365 | | debug_stats(type_machine(Name)), |
| 366 | ? | type_machine(Header,Name,MType,RawMachine,RefMachines,TypedLocal,RefMachines2,Ein,Err1), |
| 367 | | % merge included and including machine |
| 368 | | debug_stats(merge_included_machines(Name)), |
| 369 | | merge_included_machines(Name,TypedLocal,Included,Promotes,Expanded2,Err1,Err2), |
| 370 | | % add some predicates that state the equivalence between arguments |
| 371 | | % in the include statement and the parameters of the included machine |
| 372 | | add_link_constraints(Includes,MType,Parameters,RefMachines2,Expanded2,Expanded3,Err2,Err3), |
| 373 | | % put together refinement and abstraction. |
| 374 | | merge_refinement_and_abstraction(Name,Expanded3,[ref(local,TypedLocal)|RefMachines2],Expanded4,Err3,Eout), |
| 375 | | % merge used machines, will also prefix |
| 376 | | debug_stats(merge_used_machines(Name)), |
| 377 | | merge_used_machines(Included,Expanded4,Expanded5), |
| 378 | | % clean up the syntax tree |
| 379 | | debug_stats(clean_up_machine(Name)), |
| 380 | | clean_up_machine(Expanded5,RefMachines2,Expanded), |
| 381 | | debug_stats(finished_clean_up_and_expand_machine(Name)). |
| 382 | | |
| 383 | | strip_machine_section_pragmas(RawMachineWithPragmas,RawMachine,Pragmas) :- |
| 384 | | selectchk(units(_Pos,RealVariables,Pragmas),RawMachineWithPragmas,TRawMachine), !, |
| 385 | | RawMachine = [RealVariables|TRawMachine]. |
| 386 | | strip_machine_section_pragmas(Machine,Machine,[]). |
| 387 | | |
| 388 | | merge_included_machines(Name, TypedLocal, RefMachines, Promotes, Merged, Ein, Eout) :- |
| 389 | | (Promotes=[] -> true ; assertz(machine_promotes_operations(Name,Promotes))), |
| 390 | | include(is_included_ref,RefMachines,Included), |
| 391 | | create_machine(Name,Empty), |
| 392 | | % move the included operations into the promoted or unpromoted section |
| 393 | | move_operations(Included,Promotes,Included2,Ein,Eout), |
| 394 | | LocalAndIncluded = [ref(local,TypedLocal)|Included2], |
| 395 | | % TODO: make sure that the constants of two instances of the same machine do not repeat (check what should be done for distinct machines with same identifiers) |
| 396 | | concat_sections_of_refs([identifiers,initialisation,operation_bodies, |
| 397 | | assertions,used,values],LocalAndIncluded,Empty,Merged1), |
| 398 | | conjunct_sections_of_refs([constraints,properties,invariant],LocalAndIncluded,Merged1,Merged2), |
| 399 | | concat_section_of_simple_lists(freetypes,LocalAndIncluded,Merged2,Merged3), |
| 400 | | get_section(definitions,TypedLocal,Defs), |
| 401 | | write_section(definitions,Defs,Merged3,Merged). |
| 402 | | is_included_ref(ref(included,_)). |
| 403 | | |
| 404 | | concat_section_of_simple_lists(Sec,References,In,Out) :- |
| 405 | | maplist(extract_machine_from_ref,References,Machines), |
| 406 | | sort_machines_by_global_order(Machines,OMachines), |
| 407 | | foldl(concat_section_of_simple_lists2(Sec),OMachines,In,Out). |
| 408 | | concat_section_of_simple_lists2(Sec,Machine,In,Out) :- |
| 409 | | get_section(Sec,In,Orig), |
| 410 | | get_section(Sec,Machine,List), |
| 411 | | append(Orig,List,NewList), |
| 412 | | write_section(Sec,NewList,In,Out). |
| 413 | | |
| 414 | | merge_used_machines(RefMachines,Old,New) :- |
| 415 | | % get all included machines from the references |
| 416 | | convlist(ref_to_included_machine,RefMachines,Included), |
| 417 | | foldl(merge_used_machines2,Included,Old,New). |
| 418 | | merge_used_machines2(Included,Old,New) :- |
| 419 | | get_section(used,Included,IncludedUse), |
| 420 | | map_split_list(useful_renaming,IncludedUse,RenamingList,_), |
| 421 | | (RenamingList = [] -> New = Old ; rename_used(RenamingList,Old,New)). |
| 422 | | ref_to_included_machine(ref(included,Inc),Inc). |
| 423 | | |
| 424 | | % the renaming does not add a prefix; happens for constants in used/seen machines |
| 425 | | %useless_renaming(includeduse(_Mach,ID,TID)) :- get_texpr_id(TID,ID). |
| 426 | | useful_renaming(includeduse(_Mach,ID,TID),rename(ID,NewID)) :- get_texpr_id(TID,NewID), NewID \= ID. |
| 427 | | |
| 428 | | |
| 429 | | % will add prefixes to identifiers |
| 430 | | % TODO: unclear to me why this cannot be done by rename_bt? Is it for treating SEEN machines not included? |
| 431 | | rename_used(RenamingList,Old,New) :- |
| 432 | | expand_shortcuts([properties,invariant, assertions, |
| 433 | | initialisation,operation_bodies],Sections), % TO DO: also traverse GOAL ? should we later apply this at the REPL level as well ? should we apply it to other DEFINITIONS ? |
| 434 | | foldl(rename_used_sec(RenamingList),Sections,Old,New). |
| 435 | | rename_used_sec(RenamingList,Sec,Old,New) :- |
| 436 | | select_section_texprs(Sec,TExprs,NewTExprs,Old,New), |
| 437 | | rename_used2_l(TExprs,RenamingList,NewTExprs). |
| 438 | | |
| 439 | | rename_used2(TExpr,RenamingList,NewTExpr) :- |
| 440 | | get_texpr_expr(TExpr,operation(Id,Params,Results,Subst)),!, |
| 441 | | get_texpr_exprs(Params,Ps), |
| 442 | | remove_renamings(Ps,RenamingList,NRenamings0), |
| 443 | | get_texpr_exprs(Results,Rs), |
| 444 | | remove_renamings(Rs,NRenamings0,NRenamings), |
| 445 | | rename_used2_l(Params,NRenamings,NParams), % should normally do nothing; unless variable capture occurs |
| 446 | | rename_used2_l(Results,NRenamings,NResults), % ditto |
| 447 | | rename_used2(Subst,NRenamings,NSubst), |
| 448 | | get_texpr_type(TExpr,Type), |
| 449 | | get_texpr_info(TExpr,Info), |
| 450 | | l_rename_info(Info,NRenamings,NewInfo), |
| 451 | | create_texpr(operation(Id,NParams,NResults,NSubst),Type,NewInfo,NewTExpr). |
| 452 | | rename_used2(TExpr,RenamingList,NewTExpr) :- |
| 453 | | % rename identifier by adding machine prefix M.id |
| 454 | | get_texpr_id(TExpr,_), % result is also Id (always ??) |
| 455 | | TExpr = b(_,Type,Info), |
| 456 | | member(usesee(_MachName,Id,_UseOrSeeMode),Info), % TODO: do we need to check MachName matches includeduse/3 above? |
| 457 | | member(rename(Id,NewId),RenamingList), |
| 458 | | % we now rename Id to Name.Id |
| 459 | | !, NewTExpr = b(identifier(NewId),Type,Info). |
| 460 | | %add_message(rename,'Rename ID: ',TExpr,Info),add_message(rename,'Rename ID: ',NewTExpr,NewTExpr). |
| 461 | | rename_used2(TExpr,RenamingList,NTExpr1) :- |
| 462 | | remove_bt(TExpr,Expr,NExpr,NTExpr), |
| 463 | | syntaxtransformation_for_renaming(Expr,Subs,TNames,NSubs,NExpr),!, |
| 464 | | get_texpr_exprs(TNames,Names), |
| 465 | | remove_renamings(Names,RenamingList,NRenamings), |
| 466 | | rename_used2_l(Subs,NRenamings,NSubs), |
| 467 | | rename_infos(NTExpr,NRenamings,NTExpr1). |
| 468 | | rename_used2(TExpr,RenamingList,NTExpr) :- |
| 469 | | add_internal_error('Rename failed: ',rename_used2(TExpr,RenamingList,NTExpr)), |
| 470 | | NTExpr = TExpr. |
| 471 | | |
| 472 | | % update infos, e.g., read/modifies for while loops |
| 473 | | rename_infos(b(E,T,I),RenamingList,b(E,T,NI)) :- |
| 474 | | l_rename_info(I,RenamingList,NI). |
| 475 | | |
| 476 | | l_rename_info([],_,[]). |
| 477 | | l_rename_info([Info|T],RenamingList,[NewInfo|NT]) :- |
| 478 | | rename_info(RenamingList,Info,NewInfo), |
| 479 | | l_rename_info(T,RenamingList,NT). |
| 480 | | |
| 481 | | rename_info(RenamingList,Info,NewInfo) :- info_field_contains_ids(Info,I,NewInfo,SNI),!, |
| 482 | | maplist(rename_usage_info(RenamingList),I,NI), sort(NI,SNI). |
| 483 | | rename_info(_,I,I). |
| 484 | | |
| 485 | | info_field_contains_ids(reads(I),I,reads(SNI),SNI). |
| 486 | | info_field_contains_ids(modifies(I),I,modifies(SNI),SNI). |
| 487 | | info_field_contains_ids(non_det_modifies(I),I,non_det_modifies(SNI),SNI). |
| 488 | | info_field_contains_ids(modifies_locals(I),I,modifies_locals(SNI),SNI). |
| 489 | | info_field_contains_ids(reads_locals(I),I,reads_locals(SNI),SNI). |
| 490 | | info_field_contains_ids(used_ids(I),I,used_ids(SNI),SNI). |
| 491 | | |
| 492 | | rename_usage_info(RenamingList,ID,NewID) :- |
| 493 | | (member(rename(ID,NewID),RenamingList) -> true ; NewID = ID). |
| 494 | | |
| 495 | | |
| 496 | | rename_used2_l([],_,R) :- !, R=[]. |
| 497 | | rename_used2_l([T|Rest],RenamingList,[NT|NRest]) :- |
| 498 | | rename_used2(T,RenamingList,NT), !, |
| 499 | | rename_used2_l(Rest,RenamingList,NRest). |
| 500 | | rename_used2_l(X,Y,Z) :- add_internal_error('Rename failed: ', rename_used2_l(X,Y,Z)),Z=X. |
| 501 | | |
| 502 | | %rename_used_ids(InIds,RenamingList,OutIds) :- |
| 503 | | % maplist(rename_used_ids2(RenamingList),InIds,OutIds). |
| 504 | | %rename_used_ids2(RenamingList,InId,OutId) :- |
| 505 | | % memberchk(rename(InId,I2),RenamingList),!, OutId=I2. |
| 506 | | %rename_used_ids2(_RenamingList,Id,Id). |
| 507 | | |
| 508 | | get_abstractions(CName,Machines,TypedMachines,[ref(abstraction,Abstraction)]) :- |
| 509 | ? | refines(M,AName), |
| 510 | | get_constructed_machine_name(M,CName), |
| 511 | | memberchk(M,Machines),!, |
| 512 | | memberchk(machine(AName,Abstraction),TypedMachines). |
| 513 | | get_abstractions(_,_,_,[]). |
| 514 | | |
| 515 | | get_includes_and_promotes(Sections,M,Includes,Promotes) :- |
| 516 | | optional_rawmachine_section(includes,Sections,[],Includes1), |
| 517 | | optional_rawmachine_section(imports,Sections,[],Imports), |
| 518 | | optional_rawmachine_section(extends,Sections,[],Extends), |
| 519 | | optional_rawmachine_section(promotes,Sections,[],Promotes1), |
| 520 | | append([Includes1,Extends,Imports],Includes), |
| 521 | | maplist(expand_extends(M),Extends,Promotes2), |
| 522 | | append([Promotes1|Promotes2],Promotes). |
| 523 | | expand_extends(Machines,machine_reference(_,Ref,_),Promotes) :- |
| 524 | | split_prefix(Ref,Prefix,Name), |
| 525 | | memberchk(machine(Name,Body),Machines), |
| 526 | | get_section(promoted,Body,Promoted), |
| 527 | | prefix_identifiers(Promoted,Prefix,Renamings), |
| 528 | | rename_bt_l(Promoted,Renamings,TPromotes), |
| 529 | | maplist(add_nonpos,TPromotes,Promotes). |
| 530 | | add_nonpos(TId,identifier(none,Id)) :- |
| 531 | | get_texpr_id(TId,op(Id)). |
| 532 | | |
| 533 | | move_operations([],Promotes,[],Ein,Eout) :- |
| 534 | | foldl(add_promotes_not_found_error,Promotes,Ein,Eout). |
| 535 | | move_operations([ref(_,IncMachine)|IncRest],Promotes,[ref(included,NewIncMachine)|RefRest],Ein,Eout) :- |
| 536 | | move_operations2(IncMachine,Promotes,NewIncMachine,RestPromotes), |
| 537 | | move_operations(IncRest,RestPromotes,RefRest,Ein,Eout). |
| 538 | | move_operations2(Included,Promotes,Result,RestPromotes) :- |
| 539 | | select_section(promoted,IncOperations,Promoted,Included,Included1), |
| 540 | | select_section(unpromoted,OldUnpromoted,Unpromoted,Included1,Result), |
| 541 | | filter_promoted(IncOperations,Promotes,Promoted,NewUnpromoted,RestPromotes), |
| 542 | | append(OldUnpromoted,NewUnpromoted,Unpromoted). |
| 543 | | filter_promoted([],Promotes,[],[],Promotes). |
| 544 | | filter_promoted([TExpr|OpsRest],Promotes,Promoted,Unpromoted,RestPromotes) :- |
| 545 | | get_texpr_id(TExpr,op(P)), |
| 546 | | ( select(identifier(_,P),Promotes,RestPromotes1) -> |
| 547 | | !,Promoted = [TExpr|RestPromoted], |
| 548 | | Unpromoted = RestUnpromoted |
| 549 | | ; |
| 550 | | RestPromotes1 = Promotes, |
| 551 | | Promoted = RestPromoted, |
| 552 | | Unpromoted = [TExpr|RestUnpromoted]), |
| 553 | | filter_promoted(OpsRest,RestPromotes1,RestPromoted,RestUnpromoted,RestPromotes). |
| 554 | | add_promotes_not_found_error(identifier(Pos,Id),[error(Msg,Pos)|E],E) :- |
| 555 | | ajoin(['Promoted operation ',Id,' not found'],Msg). |
| 556 | | |
| 557 | | find_machine(Name,Machines,Type,Header,Sections) :- |
| 558 | | Header = machine_header(_,Name,_), |
| 559 | ? | ( (member(abstract_machine(_,_ModelType,Header,Sections),Machines), |
| 560 | | Type=machine) |
| 561 | | ; (member(refinement_machine(_,Header,_Abstract,Sections),Machines), |
| 562 | | Type=refinement) |
| 563 | | ; (member(implementation_machine(_,Header,_Abstract,Sections),Machines), |
| 564 | | Type=implementation)), |
| 565 | | !. |
| 566 | | |
| 567 | | include_machines(RawMachine, TypeChecked, GlobalUses, Includes, Parameters, Included, Promotes) :- |
| 568 | | get_includes_and_promotes(RawMachine,TypeChecked,Includes,Promotes), |
| 569 | | maplist(include_machine(TypeChecked, GlobalUses), Includes, Parameters, Singles), |
| 570 | | remove_duplicate_set_inclusions(Singles,Singles1), |
| 571 | | % duplicate constants inclusion is handled currently in concat_section_contents via section_can_have_duplicates |
| 572 | | % create refs |
| 573 | | maplist(create_ref,Singles1,Included). |
| 574 | | create_ref(IncMachine,ref(included,IncMachine)). |
| 575 | | |
| 576 | | % it is possible that a deferred or enumerated set is declared in an included machine |
| 577 | | % that is included more than once. We remove all but one occurrences. |
| 578 | | remove_duplicate_set_inclusions([],[]). |
| 579 | | remove_duplicate_set_inclusions([M],[M]) :- !. |
| 580 | | remove_duplicate_set_inclusions([M|Rest],[M|CleanedRest]) :- |
| 581 | | get_section(deferred_sets,M,DSets), |
| 582 | | get_section(enumerated_sets,M,ESets), |
| 583 | | get_section(enumerated_elements,M,EElements), |
| 584 | | append([DSets,ESets,EElements],Identifiers), |
| 585 | | sort(Identifiers,SortedIds), |
| 586 | | maplist(remove_duplicate_sets2(SortedIds),Rest,Rest2), |
| 587 | | remove_duplicate_set_inclusions(Rest2,CleanedRest). |
| 588 | | remove_duplicate_sets2(Identifiers,M,Cleaned) :- |
| 589 | | remove_duplicate_sets_section(deferred_sets,Identifiers,M,M1), |
| 590 | | remove_duplicate_sets_section(enumerated_sets,Identifiers,M1,M2), |
| 591 | | remove_duplicate_sets_section(enumerated_elements,Identifiers,M2,Cleaned). |
| 592 | | remove_duplicate_sets_section(Section,Identifiers,In,Out) :- |
| 593 | | select_section(Section,Old,New,In,Out), |
| 594 | | %get_texpr_ids(Identifiers,II),format('Removing duplicates ~w = ~w~n',[Section,II]), |
| 595 | | exclude(element_is_duplicate(Identifiers),Old,New). |
| 596 | | |
| 597 | | element_is_duplicate(Identifiers,TId) :- |
| 598 | | get_texpr_id(TId,Name), |
| 599 | | get_texpr_type(TId,Type), |
| 600 | | get_texpr_id(ToRemove,Name), |
| 601 | | get_texpr_type(ToRemove,Type), |
| 602 | | ord_member_nonvar_chk(ToRemove,Identifiers), |
| 603 | | get_texpr_info(TId,InfosA), |
| 604 | | get_texpr_info(ToRemove,InfosB), |
| 605 | | member(def(Sec,File),InfosA), |
| 606 | | member(def(Sec,File),InfosB), |
| 607 | | debug_format(5,'Removed duplicate included identifier: ~w~n',[Name]), |
| 608 | | !. |
| 609 | | |
| 610 | | include_machine(TypeChecked,GlobalUses,machine_reference(_Pos,FullRef,_Args), |
| 611 | | parameters(FullRef,Parameters), TM) :- |
| 612 | | split_prefix(FullRef,Prefix,Name), |
| 613 | | % TM1 is the already typechecked included machine: |
| 614 | ? | member(machine(Name,TM1),TypeChecked),!, |
| 615 | | debug_println(9,including_machine(Name)), |
| 616 | | % TM2 is a fresh copy, so we prevent unification of the parameter types: |
| 617 | | (get_section(parameters,TM1,[]) -> TM2=TM1 |
| 618 | | ; copy_term(TM1,TM2) % this can be expensive; only copy if there are parameters |
| 619 | | ), |
| 620 | | % If the included machine is used somewhere, we store the identifiers |
| 621 | | % to enable joining the different references later: |
| 622 | | include_usings(Name,GlobalUses,TM2,TM3), |
| 623 | | % TM3 is typechecked and all internal variables are renamed with a prefix |
| 624 | | hide_private_information(Name,FullRef,TM3,TM4), |
| 625 | | % TM4 is typechecked, and if it was referenced with a prefix (e.g. INCLUDES p.M2) |
| 626 | | % all variables are prefixed |
| 627 | | %print(prefixing(Prefix)),nl, |
| 628 | | prefix_machine(Prefix,TM4,TM5), |
| 629 | | % We need the parameters later to state their equivalence to the arguments |
| 630 | | get_section(parameters,TM5,Parameters), |
| 631 | | % We move the parameters to the internal parameters, because the resulting |
| 632 | | % machine has only the parameters of the including machine. |
| 633 | | parameters_to_internal(TM5,TM). |
| 634 | | |
| 635 | | include_usings(Name,GlobalUses,Old,New) :- |
| 636 | ? | ( member(usemch(Name,Prefix,_Kind,_FromMch,_Pos),GlobalUses) -> |
| 637 | | add_machine_prefix(Name,Prefix,FullName), |
| 638 | | store_usage_info(Old,FullName,UsedInfo), |
| 639 | | append_to_section(used,UsedInfo,Old,New) |
| 640 | | ; |
| 641 | | Old = New). |
| 642 | | % returns a list of which identifiers are used in the machine |
| 643 | | % for each identifier, we have a trible includeuse(Name,Id,TExpr) |
| 644 | | % where Name is the name of the used machine, Id is the |
| 645 | | % original ID and TExpr is the currently used reference to this |
| 646 | | % identifier |
| 647 | | store_usage_info(Machine,Name,UsedInfo) :- |
| 648 | | expand_shortcuts([identifiers],IdSections), |
| 649 | | foldl(store_usage_info2(Machine,Name),IdSections,UsedInfo,[]). |
| 650 | | store_usage_info2(Machine,Name,Sec,I,O) :- |
| 651 | | get_section(Sec,Machine,Content), |
| 652 | | foldl(store_usage_info3(Name),Content,I,O). |
| 653 | | store_usage_info3(Name,TId,[includeduse(Name,Id,TId)|L],L) :- |
| 654 | | get_texpr_id(TId,Id). |
| 655 | | |
| 656 | | % conjunct sections that contain predicates (CONSTRAINTS, PROPERTIES, INVARIANT) |
| 657 | | conjunct_sections_of_refs(Sections1,References,Old,New) :- |
| 658 | | expand_shortcuts(Sections1,Sections), |
| 659 | | maplist(extract_machine_from_ref,References,Machines), |
| 660 | | sort_machines_by_global_order(Machines,OMachines), |
| 661 | | foldl(conjunct_sections2(OMachines),Sections,Old,New). |
| 662 | | conjunct_sections2(Machines,Section,Old,New) :- |
| 663 | | % Section is constraints,properties,invariant, ... |
| 664 | | write_section(Section,NewContent,Old,New), % prepare new section |
| 665 | | get_section_of_machines(Machines,Section,Preds), |
| 666 | | %maplist(get_machine_name,Machines,Ns),print(got_sections(Section,Ns)),nl, |
| 667 | | %translate:l_print_bexpr_or_subst(Preds),nl, |
| 668 | | conjunct_predicates(Preds,NewContent). |
| 669 | | |
| 670 | | |
| 671 | | % merge sections that contain a list of expressions/formulas like identifiers, assertions, ... |
| 672 | | concat_sections_of_refs(Sections1,References,Old,New) :- |
| 673 | | maplist(extract_machine_from_ref,References,Machines), |
| 674 | | maplist(create_tag_by_reference,References,Tags), |
| 675 | | sort_machines_by_global_order(Machines,Tags,OMachines,STags), |
| 676 | | % should we only sort for some sections, e.g., assertions |
| 677 | | % for each machine, create a tag where the expression comes from |
| 678 | | concat_sections(Sections1,OMachines,STags,Old,New). |
| 679 | | |
| 680 | | extract_machine_from_ref(ref(_,M),M). |
| 681 | | |
| 682 | | create_tag_by_reference(ref(local,_Machine),[]) :- !. |
| 683 | | create_tag_by_reference(ref(RefType,Machine),[RefType/Name]) :- |
| 684 | | get_machine_name(Machine,Name). |
| 685 | | |
| 686 | | concat_sections(Sections1,Machines,Tags,Old,New) :- |
| 687 | | expand_shortcuts(Sections1,Sections), |
| 688 | | foldl(concat_section2(Machines,Tags),Sections,Old,New). |
| 689 | | concat_section2(Machines,Tags,Section,Old,New) :- |
| 690 | | write_section(Section,NewContent,Old,New), |
| 691 | | maplist(get_tagged_lsection_of_machine(Section),Machines,Tags,Contents), |
| 692 | | concat_section_contents(Section,Contents,NewContent). |
| 693 | | |
| 694 | | concat_section_contents(_,[SingleContent],Res) :- !, Res=SingleContent. % no need to remove_dups |
| 695 | | concat_section_contents(Section,Contents,NewContent) :- |
| 696 | | append(Contents,ConcContents), |
| 697 | | (section_can_have_duplicates(Section) |
| 698 | | -> remove_dup_tids_keep_order(ConcContents,NewContent) |
| 699 | | ; NewContent=ConcContents). |
| 700 | | |
| 701 | | % remove_dups version which keeps order of original elements |
| 702 | | % and works with typed identifiers |
| 703 | | % used if a machine is seen multiple times with different prefixes for e.g. constants |
| 704 | | % see Section 7.26 of Atelier-B handbook: |
| 705 | | % nom des éléments énumérés et des constantes de MSees, sans le préfixe de |
| 706 | | % renommage, si plusieurs instances de machines sont vues, les noms des |
| 707 | | % données ne doivent pas être répétés, |
| 708 | | remove_dup_tids_keep_order([],[]). |
| 709 | | remove_dup_tids_keep_order([H|T],[H|Res]) :- empty_avl(E), |
| 710 | | get_texpr_id(H,ID),avl_store(ID,E,true,A1), |
| 711 | | rem_dups3(T,A1,Res). |
| 712 | | |
| 713 | | rem_dups3([],_,[]). |
| 714 | | rem_dups3([H|T],AVL,Res) :- |
| 715 | | get_texpr_id(H,ID), |
| 716 | | (avl_fetch(ID,AVL) -> rem_dups3(T,AVL,Res) |
| 717 | | ; Res=[H|TRes], |
| 718 | | avl_store(ID,AVL,true,AVL1), |
| 719 | | rem_dups3(T,AVL1,TRes)). |
| 720 | | |
| 721 | | % see issue PROB-403 |
| 722 | | section_can_have_duplicates(X) :- section_can_be_included_multiple_times_nonprefixed(X). |
| 723 | | % should we also remove duplicates in PROPERTIES section ? cf. machines used in test 1857 |
| 724 | | |
| 725 | | |
| 726 | | get_tagged_lsection_of_machine(Section,Machine,Tags,TaggedContent) :- |
| 727 | | get_section(Section,Machine,Content), |
| 728 | | (Tags=[] -> TaggedContent=Content ; maplist(tag_with_origin(Tags),Content,TaggedContent)). |
| 729 | | |
| 730 | | tag_with_origin(Origins,TExpr,TaggedExpr) :- |
| 731 | | change_info_of_expression_or_init(TExpr,Info,TaggedInfo,TaggedExpr), |
| 732 | | % add a new origin to the old tag or if not existent, add a new info field |
| 733 | | ( Origins = [] -> TaggedInfo = Info |
| 734 | | ; selectchk(origin(Orest),Info,origin(Onew),TaggedInfo) -> append(Origins,Orest,Onew) |
| 735 | | ; TaggedInfo = [origin(Origins)|Info]). |
| 736 | | % the substitutions in the initialisation are additionally wrapped by an init_stmt/2 term |
| 737 | | % a small hack to work with those too. |
| 738 | | % TODO: this became a very ugly hack -- redo! |
| 739 | | change_info_of_expression_or_init(init_stmt(A,OExpr),Old,New,init_stmt(A,NExpr)) :- % ... |
| 740 | | !,change_info_of_expression_or_init(OExpr,Old,New,NExpr). |
| 741 | | % ignore the info for includeduse/3 completely |
| 742 | | change_info_of_expression_or_init(includeduse(A,B,C),[],_,includeduse(A,B,C)) :- !. |
| 743 | | change_info_of_expression_or_init(freetype(FTypeId,Cases),[],_,freetype(FTypeId,Cases)) :- !. |
| 744 | | change_info_of_expression_or_init(OExpr,Old,New,NExpr) :- |
| 745 | | create_texpr(Expr,Type,Old,OExpr),!, |
| 746 | | create_texpr(Expr,Type,New,NExpr). |
| 747 | | change_info_of_expression_or_init(OExpr,Old,New,NExpr) :- |
| 748 | | add_internal_error('Illegal typed expression:',change_info_of_expression_or_init(OExpr,Old,New,NExpr)), |
| 749 | | Old=[], NExpr=OExpr. |
| 750 | | |
| 751 | | % adds a prefix to all variables and promoted operations |
| 752 | | prefix_machine('',TM,TM) :- !. |
| 753 | | prefix_machine(Prefix,Old,New) :- |
| 754 | | debug_println(5,prefixing_machine(Prefix)), |
| 755 | | expand_shortcuts([variables,promoted], RenamedIdentiferSections), |
| 756 | | get_all_identifiers(RenamedIdentiferSections,Old,Identifiers), |
| 757 | | prefix_identifiers(Identifiers,Prefix,Renamings), |
| 758 | | find_relevant_sections(RenamedIdentiferSections,[machine],Sections1), |
| 759 | | append(RenamedIdentiferSections,Sections1,Sections), |
| 760 | | rename_in_sections(Sections,Renamings,Old,M), |
| 761 | | rename_includeduse(M,Renamings,New). |
| 762 | | rename_includeduse(Old,Renamings,New) :- |
| 763 | | select_section(used,OldContent,NewContent,Old,New), |
| 764 | | maplist(rename_includeduse2(Renamings),OldContent,NewContent). |
| 765 | | rename_includeduse2(Renamings,includeduse(M,N,TExpr),includeduse(M,N,NExpr)) :- |
| 766 | | rename_bt(TExpr,Renamings,NExpr). |
| 767 | | |
| 768 | | get_all_identifiers(Sections1,M,Identifiers) :- |
| 769 | | expand_shortcuts(Sections1,Sections), |
| 770 | | maplist(get_all_identifiers2(M),Sections,LIdentifiers), |
| 771 | | append(LIdentifiers,Identifiers). |
| 772 | | get_all_identifiers2(M,Sec,Identifiers) :- |
| 773 | | get_section(Sec,M,Identifiers). |
| 774 | | |
| 775 | | % hide all parameters and unpromoted operations |
| 776 | | hide_private_information(MachName,Prefix,Machine,NewMachine) :- |
| 777 | | get_section(parameters,Machine,Params), |
| 778 | | get_section(unpromoted,Machine,UnPromoted), |
| 779 | | append(Params,UnPromoted,ToHide), |
| 780 | | %debug_println(9,hide_private(Prefix,ToHide)), |
| 781 | | ( ToHide = [] -> NewMachine=Machine |
| 782 | | ; |
| 783 | | debug_format(9,'Hiding private parameters ~w and unpromoted operations ~w of machine ~w~n', |
| 784 | | [Params,UnPromoted,MachName]), |
| 785 | | maplist(assert_hides_operation_info(MachName,Prefix),UnPromoted), |
| 786 | | prefix_identifiers(ToHide,Prefix,Renamings), |
| 787 | | % we have to do the renaming in promoted operations, too, because |
| 788 | | % those operations might use the renamed parameters and their reads/modifies |
| 789 | | % info must be updated |
| 790 | | rename_in_sections([parameters,promoted,unpromoted],Renamings,Machine,Machine1), |
| 791 | | rename_includeduse(Machine1,Renamings,Machine2), |
| 792 | | % now find sections that can see parameters,operations: |
| 793 | | rename_relevant_sections([parameters,operations],Renamings,Machine2,NewMachine) |
| 794 | | ). |
| 795 | | |
| 796 | | % store information about which operations got renamed: |
| 797 | | assert_hides_operation_info(MachName,Prefix,TExpr) :- Prefix \= '', |
| 798 | | prefix_identifier(Prefix,TExpr,rename(op(Old),op(New))), |
| 799 | | get_texpr_pos(TExpr,Pos), |
| 800 | | !, |
| 801 | | debug_format(19,'Hiding unpromoted operation ~w in machine ~w, new name: ~w~n',[Old,MachName,New]), |
| 802 | | assertz(machine_hides_unpromoted_operation(Old,MachName,New,Pos)). |
| 803 | | assert_hides_operation_info(_,_,_). |
| 804 | | |
| 805 | | prefix_identifiers(Identifiers,'',Identifiers) :- !. |
| 806 | | prefix_identifiers(Old,Prefix,New) :- |
| 807 | | maplist(prefix_identifier(Prefix),Old,New). |
| 808 | | prefix_identifier(Prefix,TExpr,rename(Old,New)) :- |
| 809 | | get_texpr_expr(TExpr,identifier(Old)), |
| 810 | | (Old=op(OI) -> New=op(NI) ; OI=Old,NI=New), |
| 811 | | ajoin([Prefix,'.',OI],NI). % , print(rename(Old,New)),nl. |
| 812 | | |
| 813 | | parameters_to_internal(M1,M2) :- |
| 814 | | select_section(internal_parameters,OldParams,Params,M1,M3), |
| 815 | | select_section(parameters,NewParams,[],M3,M2), |
| 816 | | append(OldParams,NewParams,Params). |
| 817 | | |
| 818 | | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% |
| 819 | | % uses and sees relations |
| 820 | | find_uses(Machines,GlobalUses,NotIncludedWoDups,Ein,Eout) :- |
| 821 | | findall(usemch(UsedMch,UPrefix,Kind,FromMchName,Pos), |
| 822 | | use_usage(Machines,Pos,Kind,UsedMch,UPrefix,FromMchName), UnsortedUses), |
| 823 | | sort(UnsortedUses,Uses), |
| 824 | | check_include_use(Uses,Machines,NotIncluded,Ein,Eout), |
| 825 | | remove_duplicate_uses(NotIncluded,NotIncludedWoDups), |
| 826 | | GlobalUses = Uses. %maplist(remove_prefix,Uses,GlobalUses). |
| 827 | | |
| 828 | | %remove_prefix(usemch(U,_,_,_,_),U). |
| 829 | | same_usemch(usemch(U,Prefix,_,_,_),usemch(U,Prefix,_,_,_)). % use same machine with same prefix |
| 830 | | same_usemch(usemch_not_inc(U,Prefix,_,_,_,_),usemch_not_inc(U,Prefix,_,_,_,_)). |
| 831 | | |
| 832 | | % remove duplicate uses: a non-included/imported machine can be seen in many places; |
| 833 | | % we only need to add it later once to the dummy machine |
| 834 | | remove_duplicate_uses([],R) :- !, R=[]. |
| 835 | | remove_duplicate_uses([USE|T],Res) :- remove_dup_aux(T,USE,Res). |
| 836 | | remove_dup_aux([],USE,[USE]). |
| 837 | | remove_dup_aux([USE|T],PREVUSE,Res) :- |
| 838 | | (same_usemch(USE,PREVUSE) -> remove_dup_aux(T,PREVUSE,Res) |
| 839 | | ; Res = [PREVUSE|TR], remove_dup_aux(T,USE,TR)). |
| 840 | | |
| 841 | | |
| 842 | | |
| 843 | | % check_include_use/5 checks if the used machines are included in any machine |
| 844 | | % check_include_use(+Uses,+Machines,-NotIncluded,Ein,Eout) |
| 845 | | % Uses: The list of machine names that are used |
| 846 | | % Machines: The list of machines |
| 847 | | % NotIncluded: The list of used machines (their names) that are not included |
| 848 | | % Ein/Eout: The errors (as difference-list) |
| 849 | | check_include_use([],_,[],Errors,Errors). |
| 850 | | check_include_use([USEMCH|Rest],Machines,NotIncluded,Ein,Eout) :- |
| 851 | | USEMCH = usemch(UsedMach,UsePrefix,Kind,FromMchName,Pos), |
| 852 | | findall(i(MachName,UsePrefix,IPos),include_usage(Machines,UsedMach,UsePrefix,MachName,IPos),Inc), |
| 853 | | ( Inc=[] -> Ein=E1, |
| 854 | | % find all places where the machine is included with another prefix |
| 855 | | findall(OtherPrefix,include_usage(Machines,UsedMach,OtherPrefix,_,_IPos),OtherInclusions), |
| 856 | | NotIncluded = [usemch_not_inc(UsedMach,UsePrefix,Kind,FromMchName,Pos,OtherInclusions)|RestNotIncluded], |
| 857 | | (used_machine_not_included_anywhere(UsedMach,UsePrefix,Kind) -> true % we already produced a message |
| 858 | | ; assertz(used_machine_not_included_anywhere(UsedMach,UsePrefix,Kind)), |
| 859 | | (debug_mode(off),OtherInclusions=[],UsePrefix='' -> true |
| 860 | | ; add_machine_prefix(UsedMach,UsePrefix,FullName), |
| 861 | | (OtherInclusions=[] |
| 862 | | -> ajoin(['machine ',Kind, ' in ', FromMchName, |
| 863 | | ' not included/imported anywhere else (will create dummy top-level machine to include it): '],Msg) |
| 864 | | ; ajoin_with_sep(OtherInclusions,',',I2), |
| 865 | | (UsePrefix='' |
| 866 | | -> ajoin(['machine ',Kind, ' in ', FromMchName, |
| 867 | | ' without prefix only included/imported with prefixes [',I2, |
| 868 | | '] (will create dummy top-level machine to include it): '],Msg) |
| 869 | | ; I2='' |
| 870 | | -> ajoin(['machine ',Kind, ' in ', FromMchName, |
| 871 | | ' only included/imported without prefix (will create dummy top-level machine to include it): '],Msg) |
| 872 | | ; ajoin(['machine ',Kind, ' in ', FromMchName, ' only included/imported with other prefixes [',I2, |
| 873 | | '] (will create dummy top-level machine to include it): '],Msg) |
| 874 | | ) |
| 875 | | ), |
| 876 | | add_message(bmachine_construction,Msg,FullName,Pos) |
| 877 | | ) |
| 878 | | ) |
| 879 | | ; Inc=[_] -> NotIncluded = RestNotIncluded, Ein=E1 |
| 880 | | ; Inc=[i(_M1,_,Pos1),i(_M2,_,Pos2)|_], |
| 881 | | NotIncluded = RestNotIncluded, |
| 882 | | translate_span(Pos1,PS1), |
| 883 | | translate_span(Pos2,PS2), |
| 884 | | (UsePrefix = '' |
| 885 | | -> ajoin([Kind,' machine ',UsedMach,' is included more than once: ',PS1,' and ',PS2],Msg) |
| 886 | | ; ajoin([Kind,' machine ',UsedMach,' is included more than once with prefix ',UsePrefix, |
| 887 | | ': ',PS1,' and ',PS2],Msg) |
| 888 | | ), |
| 889 | | Ein = [error(Msg,Pos)|E1] |
| 890 | | ), |
| 891 | | check_include_use(Rest,Machines,RestNotIncluded,E1,Eout). |
| 892 | | |
| 893 | | |
| 894 | | |
| 895 | | % extend_not_included_uses(+Uses,+Main,-Name,+Machines,-AllMachines): |
| 896 | | % Create a dummy machine that extends the main machine and extends or includes |
| 897 | | % all seen/used machines that are not included if such machines exist. |
| 898 | | % In case of refinement this is done for the whole refinement chain. |
| 899 | | % Uses: List of machine names and prefix usemch/2 of the machines that are used/seen but not included |
| 900 | | % Main: The name of the main machine |
| 901 | | % Name: The name of the generated dummy machine (or Main if no dummy machine is generated) |
| 902 | | % Machines: List of all specified Machines |
| 903 | | % AllMachines: List of all Machines + the new dummy machine(s) |
| 904 | | extend_not_included_uses([],Main,Main,Machines,Machines) :- !. |
| 905 | | extend_not_included_uses(Uses,Main,NewMainName,Machines,AllMachines) :- |
| 906 | | get_refinement_hierarchy(Main,Machines,RefChain), |
| 907 | | maplist(extend_not_included_uses2(Uses,Machines),RefChain,NewMachines), |
| 908 | | append(NewMachines,Machines,AllMachines), |
| 909 | | dummy_machine_name(Main,NewMainName), |
| 910 | | debug_format(19,'Creating dummy machine called ~w for main machine~n',[NewMainName]). |
| 911 | | extend_not_included_uses2(Uses,Machines,Name,DummyMachine) :- |
| 912 | | debug_format(19,'Creating dummy subsidiary machine for refined machine ~w~n',[Name]), |
| 913 | | create_dummy_machine(Name,Machines,Parameters,DummyParameters,Sections,DummyMachine), |
| 914 | | IncludeMain = machine_reference(none,Name,Parameters), |
| 915 | | ( get_preference(seen_machines_included,true) -> |
| 916 | | % extend just the main machine, include the used/seen machines |
| 917 | | References = [extends(none,[IncludeMain]),includes(none,UReferences)] |
| 918 | | ; |
| 919 | | % extends the main machine and all used/seen machines |
| 920 | | References = [extends(none,[IncludeMain|UReferences])]), |
| 921 | | maplist(find_using(Machines),Uses,UReferences,LUParameters), |
| 922 | | append([Parameters|LUParameters],DummyParameters), |
| 923 | | copy_raw_definitions(Name,Machines,OptDefs), |
| 924 | | % we store a flag "is_dummy" in the machine because we have a special case |
| 925 | | % later, see type_constraints/7. |
| 926 | | append([References,[is_dummy],OptDefs],Sections). |
| 927 | | create_dummy_machine(Name,Machines,Parameters,DummyParameters,Sections,DummyMachine) :- |
| 928 | | dummy_machine_name(Name,DummyName), |
| 929 | ? | get_raw_model_type(Name,Machines,ModelType), |
| 930 | | !, |
| 931 | | Header = machine_header(_,Name,Parameters), |
| 932 | | DummyHeader = machine_header(none,DummyName,DummyParameters), |
| 933 | ? | member(Machine,Machines), |
| 934 | ? | generate_raw_machine(Header,DummyHeader,ModelType,Sections,Machine,DummyMachine),!. |
| 935 | | |
| 936 | | generate_raw_machine(OldHeader,NewHeader,_,NewSections, |
| 937 | | abstract_machine(_, ModelType,OldHeader,_), |
| 938 | | abstract_machine(none,ModelType,NewHeader,NewSections)). |
| 939 | | generate_raw_machine(OldHeader,NewHeader,ModelType,NewSections, |
| 940 | | refinement_machine(_, OldHeader,_Abstract, _), |
| 941 | | abstract_machine(none,ModelType,NewHeader,NewSections)). |
| 942 | | generate_raw_machine(OldHeader,NewHeader,ModelType,NewSections, |
| 943 | | implementation_machine(_, OldHeader,_Abstract, _), |
| 944 | | abstract_machine(none,ModelType,NewHeader,NewSections)). |
| 945 | | |
| 946 | | dummy_machine_name(Name,DummyName) :- |
| 947 | | atom_concat('MAIN_MACHINE_FOR_',Name,DummyName). |
| 948 | | |
| 949 | | add_machine_prefix(UsedMch,'',Name) :- !, UsedMch=Name. |
| 950 | | add_machine_prefix(UsedMch,UsePrefix,Name) :- ajoin([UsePrefix,'.',UsedMch],Name). |
| 951 | | |
| 952 | | find_using(Machines,usemch_not_inc(UsedMch,UsePrefix,_,_,_,OtherPrefixes), |
| 953 | | machine_reference(none,Name,Arguments),Arguments) :- |
| 954 | | % invent a dummy prefix for the SEEN/USED machine which is not included |
| 955 | | % to avoid name-clashes with main machine |
| 956 | | % was using(U).U, but awkward to type in REPL |
| 957 | | % try machine name itself; unless somewhere else it is included this way |
| 958 | | (member(UsedMch,OtherPrefixes) % somewhere we already have an INCLUDES UsedMach.UsedMach |
| 959 | | -> DummyPrefix = using(UsedMch) |
| 960 | | ; DummyPrefix = UsedMch), |
| 961 | | ajoin([DummyPrefix,'.',UsedMch],Name0), |
| 962 | | add_machine_prefix(Name0,UsePrefix,Name), |
| 963 | ? | member(M,Machines), get_machine_parameters(M,UsedMch,Params,_),!, |
| 964 | | maplist(add_use_param,Params,Arguments). |
| 965 | | add_use_param(identifier(_,Param),identifier(none,Name)) :- |
| 966 | | ( is_upper_case(Param) -> |
| 967 | | ajoin(['Useparam(',Param,')'],Name) |
| 968 | | ; |
| 969 | | ajoin(['useparam(',Param,')'],Name)). |
| 970 | | |
| 971 | | % copy_raw_definitions(+Name,+Machines,-OptDefs): |
| 972 | | % Get the definitions section from a raw (untyped) machine |
| 973 | | % Name: Name of the machine |
| 974 | | % Machines: List of Machines |
| 975 | | % OptDefs: [] if no definitions are present or [Def] if a definition section Def is present |
| 976 | | copy_raw_definitions(Name,Machines,OptDefs) :- |
| 977 | ? | get_constructed_machine_name_and_body(M,Name,_,Sections), |
| 978 | | memberchk(M,Machines),!, |
| 979 | | Def = definitions(_,_), |
| 980 | | ( memberchk(Def,Sections) -> |
| 981 | | OptDefs = [Def] |
| 982 | | ; |
| 983 | | OptDefs = []). |
| 984 | | |
| 985 | | add_def_dependency_information(DefsIn,DefsOut,Ein,Eout) :- |
| 986 | | extract_def_name_set(DefsIn,DefNames,DN), |
| 987 | | maplist(add_def_dep(DN),DefsIn,Defs1), |
| 988 | | check_for_cyclic_def_dependency(Defs1,DefNames,DefsOut,Ein,Eout). |
| 989 | | |
| 990 | | extract_def_name_set(Defs,DefNames,DN) :- |
| 991 | | maplist(get_def_name,Defs,DefNames), |
| 992 | | maplist(to_mapset_entry,DefNames,DN1), |
| 993 | | list_to_avl(DN1,DN). |
| 994 | | |
| 995 | | get_def_name(Def,Name) :- arg(1,Def,Name). |
| 996 | | get_def_pos(Def,Pos) :- arg(3,Def,Pos). |
| 997 | | get_def_dependencies(Def,Dependencies) :- arg(6,Def,Dependencies). |
| 998 | | to_mapset_entry(Name,Name-true). |
| 999 | | |
| 1000 | | add_def_dep(DN,In,Out) :- |
| 1001 | | analyse_definition_dependencies(In,DN,Deps), |
| 1002 | | In = definition_decl(Name,DefType,Pos,Args,RawExpr), |
| 1003 | | Out = definition_decl(Name,DefType,Pos,Args,RawExpr,Deps). |
| 1004 | | |
| 1005 | | check_for_cyclic_def_dependency(Defs,DefNames,DefsOut,Ein,Eout) :- |
| 1006 | | % check if we have a cyclic definition: |
| 1007 | | create_definitions_avl(Defs,DefsAvl), |
| 1008 | | search_for_cyclic_definition(DefNames,DefsAvl,[],Pos,RCycle),!, |
| 1009 | | % if we have found a cyclic definition, generate an error message, ... |
| 1010 | | reverse(RCycle,Cycle),add_arrows(Cycle,Msg0), |
| 1011 | | ajoin(['Found cyclic definitions: '|Msg0],Msg), |
| 1012 | | Ein = [error(Msg,Pos)|E1], |
| 1013 | | % ... remove the definitions in the cycle (to prevent later infinite loops) ... |
| 1014 | | exclude(definition_in_list(Cycle),Defs,Defs1), |
| 1015 | | % ... and check the remaining definitions. |
| 1016 | | check_for_cyclic_def_dependency(Defs1,DefNames,DefsOut,E1,Eout). |
| 1017 | | check_for_cyclic_def_dependency(Defs,_DefNames,Defs,E,E). |
| 1018 | | add_arrows([E],[E]) :- !. |
| 1019 | | add_arrows([E|Erest],[E,'->'|Arest]) :- add_arrows(Erest,Arest). |
| 1020 | | definition_in_list(List,Def) :- |
| 1021 | | get_def_name(Def,Name),memberchk(Name,List). |
| 1022 | | |
| 1023 | | create_definitions_avl(Defs,DefsAvl) :- |
| 1024 | | maplist(split_def_name,Defs,Entries), |
| 1025 | | list_to_avl(Entries,DefsAvl). |
| 1026 | | split_def_name(Def,Name-Def) :- get_def_name(Def,Name). |
| 1027 | | |
| 1028 | | |
| 1029 | | % just a depth-first search to find a cycle |
| 1030 | | search_for_cyclic_definition(DefNames,Definitions,Visited,Pos,Cycle) :- |
| 1031 | ? | member(Name,DefNames),avl_fetch(Name,Definitions,Definition), |
| 1032 | | get_def_pos(Definition,Pos), |
| 1033 | | ( memberchk(Name,Visited) -> |
| 1034 | | Cycle = [Name|Visited] |
| 1035 | | ; |
| 1036 | | get_def_dependencies(Definition,Dependencies), |
| 1037 | | search_for_cyclic_definition(Dependencies,Definitions,[Name|Visited],_,Cycle) |
| 1038 | | ). |
| 1039 | | |
| 1040 | | :- assert_must_succeed(( |
| 1041 | | list_to_avl([def1-true,def2-true,def3-true,def4-true],DefNames), |
| 1042 | | analyse_definition_dependencies( |
| 1043 | | conjunct(none, |
| 1044 | | equals(none, |
| 1045 | | identifier(none,x), |
| 1046 | | identifier(none,def1)), |
| 1047 | | equals(none, |
| 1048 | | definition(none,def4, |
| 1049 | | [function(none, |
| 1050 | | identifier(none,def3), |
| 1051 | | integer(none,5))]), |
| 1052 | | identifier(y))),DefNames,Defs), |
| 1053 | | Defs==[def1,def3,def4] |
| 1054 | | )). |
| 1055 | | % analyse_definition_dependencies(+Expr,+DefinitionNames,Deps): |
| 1056 | | % Expr: raw (i.e. untyped) expression to analyse |
| 1057 | | % DN: AVL set (i.e. mapping from elements to 'true') of the names of the definitions |
| 1058 | | % This is needed to decide if an identifier is a reference to a definition |
| 1059 | | % Deps: A list of used definitions (a list of their names) |
| 1060 | | analyse_definition_dependencies(Expr,DN,Deps) :- |
| 1061 | | analyse_definition_dependencies2(Expr,DN,Unsorted,[]), |
| 1062 | | sort(Unsorted,Deps). |
| 1063 | | analyse_definition_dependencies2(VAR,_DN) --> {var(VAR)},!, |
| 1064 | | {add_internal_error('Variable DEFINITION expression in',analyse_definition_dependencies)}. |
| 1065 | | analyse_definition_dependencies2([Expr|Rest],DN) --> |
| 1066 | | !, analyse_definition_dependencies2(Expr,DN), |
| 1067 | | analyse_definition_dependencies2(Rest,DN). |
| 1068 | | analyse_definition_dependencies2(definition(_Pos,Name,Args),DN) --> |
| 1069 | | !,[Name],analyse_definition_dependencies2(Args,DN). |
| 1070 | | analyse_definition_dependencies2(identifier(_Pos,Name),DN) --> |
| 1071 | | {avl_fetch(Name,DN),!},[Name]. |
| 1072 | | analyse_definition_dependencies2(Expr,DN) --> |
| 1073 | | { compound(Expr),functor(Expr,_Functor,Arity),!}, |
| 1074 | | analyse_definition_dependencies_arg(2,Arity,Expr,DN). |
| 1075 | | analyse_definition_dependencies2(_Expr,_DN) --> []. |
| 1076 | | |
| 1077 | | analyse_definition_dependencies_arg(I,Arity,Expr,DN) --> |
| 1078 | | { I =< Arity,!,arg(I,Expr,Arg),I2 is I+1 }, |
| 1079 | | analyse_definition_dependencies2(Arg,DN), |
| 1080 | | analyse_definition_dependencies_arg(I2,Arity,Expr,DN). |
| 1081 | | analyse_definition_dependencies_arg(_I,_Arity,_Expr,_DN) --> []. |
| 1082 | | |
| 1083 | | |
| 1084 | | :- use_module(tools_positions, [get_position_filenumber/2]). |
| 1085 | | |
| 1086 | | get_constructed_machine_name(MachineTerm,Name) :- get_constructed_machine_name_and_body(MachineTerm,Name,_Pos,_). |
| 1087 | | % name and pos; pos can be used for filenumber |
| 1088 | | get_constructed_machine_name_and_filenumber(MachineTerm,Name,Filenumber) :- |
| 1089 | | get_constructed_machine_name_and_body(MachineTerm,Name,Pos,_), |
| 1090 | | (get_position_filenumber(Pos,FN) -> Filenumber=FN ; Filenumber=unknown). |
| 1091 | | get_constructed_machine_name_and_body(abstract_machine(_,_ModelType,machine_header(Pos,Name,_),Body),Name,Pos,Body). |
| 1092 | | get_constructed_machine_name_and_body(refinement_machine(_,machine_header(Pos,Name,_),_Abstract,Body),Name,Pos,Body). |
| 1093 | | get_constructed_machine_name_and_body(implementation_machine(_,machine_header(Pos,Name,_),_Abstract,Body),Name,Pos,Body). |
| 1094 | | |
| 1095 | | refines(refinement_machine(_,machine_header(_,_Name,_),Abstract,_Body),Abstract). |
| 1096 | | refines(implementation_machine(_,machine_header(_,_Name,_),Abstract,_Body),Abstract). |
| 1097 | | |
| 1098 | | get_machine_parameters(abstract_machine(Pos,_ModelType,machine_header(_,Name,Parameters),_),Name,Parameters,Pos). |
| 1099 | | get_machine_parameters(refinement_machine(Pos,machine_header(_,Name,Parameters),_,_),Name,Parameters,Pos). |
| 1100 | | get_machine_parameters(implementation_machine(Pos,machine_header(_,Name,Parameters),_,_),Name,Parameters,Pos). |
| 1101 | | |
| 1102 | | get_raw_model_type(Main,Machines,ModelType) :- |
| 1103 | ? | get_constructed_machine_name_and_body(M,Main,_,_), |
| 1104 | | memberchk(M,Machines), |
| 1105 | | ( refines(M,RefName) -> |
| 1106 | | get_raw_model_type(RefName,Machines,ModelType) |
| 1107 | | ; |
| 1108 | | M = abstract_machine(_,ModelType,_,_)). |
| 1109 | | |
| 1110 | | some_machine_name_body(Machines,M,Name,Body) :- |
| 1111 | ? | member(M,Machines), |
| 1112 | | get_constructed_machine_name_and_body(M,Name,_,Body). |
| 1113 | | |
| 1114 | | use_usage(Machines,Pos,Kind,UsedMch,UsePrefix,FromMchName) :- |
| 1115 | ? | some_machine_name_body(Machines,_,FromMchName,Body), |
| 1116 | ? | ( member(sees(Pos,R),Body),Kind=seen |
| 1117 | | ; member(uses(Pos,R),Body),Kind=used), |
| 1118 | ? | member(identifier(_,PrefixUse),R), |
| 1119 | | split_prefix(PrefixUse,UsePrefix,UsedMch). |
| 1120 | | % include_usage/4 checks if there is any machine in Machines that |
| 1121 | | % includes/extends/imports the used machine |
| 1122 | | % include_usage(+Machines,+Use,-Name): |
| 1123 | | % Machines: The list of machines |
| 1124 | | % UsedMch: The name of the used machine |
| 1125 | | % UsePrefix: the prefix with which the machine is used |
| 1126 | | % Name: The name of the machine that imports the used machine |
| 1127 | | % include_usage/4 fails if there is not such an import |
| 1128 | | include_usage(Machines,UsedMch,UsePrefix,MachName,Pos) :- |
| 1129 | ? | some_machine_name_body(Machines,_,MachName,Body), |
| 1130 | | ( member(includes(_,R),Body) |
| 1131 | | ; member(extends(_,R), Body) |
| 1132 | | ; member(imports(_,R), Body)), |
| 1133 | | member(machine_reference(Pos,PrefixRef,_),R), |
| 1134 | | % The name could be prefixed, we need it without prefix: |
| 1135 | | split_prefix(PrefixRef,UsePrefix,UsedMch). |
| 1136 | | |
| 1137 | | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% |
| 1138 | | % uses and sees clauses |
| 1139 | | |
| 1140 | | % returns a list of references to used and seen machines |
| 1141 | | % the machines contain only identifier sections and |
| 1142 | | % the identifier are prefixed accordingly |
| 1143 | | % all identifier are marked as coming from a seen/used machine |
| 1144 | | use_and_see_machines(Sections,Machines,References) :- |
| 1145 | | get_uses_and_sees(Sections,Uses,Sees), |
| 1146 | | maplist(use_or_see_machine(used,Machines),Uses,Used), |
| 1147 | | maplist(use_or_see_machine(seen,Machines),Sees,Seen), |
| 1148 | | append(Used,Seen,References). |
| 1149 | | |
| 1150 | | % get uses and sees sections from the untyped machines |
| 1151 | | get_uses_and_sees(Sections,Uses,Sees) :- |
| 1152 | | get_uses_or_sees2(sees,Sections,Sees), |
| 1153 | | get_uses_or_sees2(uses,Sections,Uses). |
| 1154 | | get_uses_or_sees2(Mode,Sections,US) :- |
| 1155 | | optional_rawmachine_section(Mode,Sections,[],US1), |
| 1156 | | findall(I,member(identifier(_,I),US1),US). |
| 1157 | | |
| 1158 | | % Mode is used or seen |
| 1159 | | use_or_see_machine(Mode,TypedMachines,Ref,ref(Mode,Result)) :- |
| 1160 | | split_prefix(Ref,Prefix,MachName), |
| 1161 | | memberchk(machine(MachName,Typed),TypedMachines), |
| 1162 | | create_machine(MachName,Empty), |
| 1163 | | use_sections([sets],Mode,'',MachName,Typed,Empty,M1), |
| 1164 | | use_sections([constants,variables,promoted],Mode,Prefix,MachName,Typed,M1,Result). |
| 1165 | | use_sections(Sections,Mode,Prefix,MachName,Typed,Old,New) :- |
| 1166 | | expand_shortcuts(Sections,AllSections), |
| 1167 | | foldl(use_section(Mode,Prefix,MachName,Typed),AllSections,Old,New). |
| 1168 | | use_section(Mode,Prefix,MachName,Machine,Section,OldM,NewM) :- |
| 1169 | | get_section_texprs(Section,Machine,Identifiers), |
| 1170 | | write_section(Section,NewIds,OldM,NewM), |
| 1171 | | ( Prefix='' -> |
| 1172 | | Ids1=Identifiers |
| 1173 | | ; |
| 1174 | | prefix_identifiers(Identifiers,Prefix,Renamings), |
| 1175 | | rename_bt_l(Identifiers,Renamings,Ids1)), |
| 1176 | | maplist(add_use_info_to_identifier(Mode,MachName),Ids1,NewIds). |
| 1177 | | add_use_info_to_identifier(Mode,MachName,TExpr,New) :- |
| 1178 | | get_texpr_id(TExpr,PId), get_texpr_type(TExpr,Type), |
| 1179 | | get_texpr_id(New,PId), get_texpr_type(New,Type), |
| 1180 | | split_prefix(PId,_Prefix,Id), |
| 1181 | | get_texpr_info(TExpr,Info), |
| 1182 | | get_texpr_info(New,[usesee(MachName,Id,Mode)|Info]). |
| 1183 | | |
| 1184 | | |
| 1185 | | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% |
| 1186 | | % add a section to the machine that describes the linking of |
| 1187 | | % parameters and arguments |
| 1188 | | add_link_constraints(Includes,MType,Parameters,RefMachines,Old,New,Ein,Eout) :- |
| 1189 | | AllRefMachines = [ref(local,Old)|RefMachines], |
| 1190 | | extract_parameter_types(RefMachines,NonGroundExceptions), |
| 1191 | | foldl(add_link_section(MType,Parameters,AllRefMachines,NonGroundExceptions), |
| 1192 | | Includes,Links/Ein,[]/Eout), % TO DO: Daniel check if [] is correct here |
| 1193 | | %print(conjunct_predicates(Links,Link)),nl, |
| 1194 | | conjunct_predicates(Links,Link), |
| 1195 | | select_section(constraints,OConstraints,NConstraints,Old,New), |
| 1196 | | conjunct_predicates([Link,OConstraints],NConstraints). |
| 1197 | | add_link_section(MType,Parameters,RefMachines,NonGroundExceptions, |
| 1198 | | machine_reference(Pos,Ref,Args),Links/Ein,RLinks/Eout) :- |
| 1199 | | visible_env(MType,includes,RefMachines,Env,Ein,E1), |
| 1200 | | memberchk(parameters(Ref,TParameters),Parameters), |
| 1201 | | ( same_length(TParameters, Args) -> |
| 1202 | | get_texpr_types(TParameters,Types), |
| 1203 | | btype_ground_dl(Args,Env,NonGroundExceptions,Types,TArgs,E1,Eout), |
| 1204 | | maplist(create_plink_equality,TParameters,TArgs,LLinks) |
| 1205 | | ; |
| 1206 | | E1 = [error('wrong number of machine arguments',Pos)|Eout], |
| 1207 | | LLinks = []), |
| 1208 | | append(LLinks,RLinks,Links). |
| 1209 | | create_plink_equality(P,A,E) :- |
| 1210 | | create_texpr(equal(P,A),pred,[parameterlink],E). |
| 1211 | | |
| 1212 | | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% |
| 1213 | | % type machines |
| 1214 | | |
| 1215 | | type_machine(Header,Name,MType,RawMachine,RefMachines,TypedMachine,NewRefMachines,Ein,Eout) :- |
| 1216 | | Header = machine_header(_,Name,_), |
| 1217 | | create_machine(Name,Empty), |
| 1218 | | % (optional) definitions |
| 1219 | | extract_definitions(RawMachine,Empty,DefsOnly,Ein,E0), |
| 1220 | | debug_stats(extracted_definitions(Name)), |
| 1221 | | % create the identifiers that will be typed, |
| 1222 | | % Local will contain the identifier sections |
| 1223 | | create_id_sections(Header,RawMachine,Name,DefsOnly,Local), |
| 1224 | | debug_stats(created_identifier_sections(Name)), |
| 1225 | ? | create_freetypes(RawMachine,MType,RefMachines,Local,Local1,E0,E1), |
| 1226 | | % in case of a refinement, check if all newly defined operations are refinements |
| 1227 | | link_to_refinement(MType,Name,RawMachine,RefMachines,Local1,Local2,E1,E2), |
| 1228 | | % extract types that can be variables |
| 1229 | | debug_stats(created_link_to_refinement(Name)), |
| 1230 | | extract_parameter_types([ref(local,Local2)|RefMachines],NonGroundExceptions), |
| 1231 | | % check for a VALUES clause. They are a little bit tricky because they can replace |
| 1232 | | % already defined deferred sets by integers or other deferred sets |
| 1233 | | process_values_section(MType,RawMachine,NonGroundExceptions, |
| 1234 | | Local2/E2/RefMachines,Local3/E3/NewRefMachines), |
| 1235 | | % type-check the other sections (properties, invariant, operation_bodies, etc) |
| 1236 | | type_sections(RawMachine,MType,[ref(local,Local3)|NewRefMachines],NonGroundExceptions, |
| 1237 | | Name,E3,Eout,Local3,TypedMachine). |
| 1238 | | |
| 1239 | | % extract definitions from a definition file |
| 1240 | | extract_only_definitions(MainName,RawMachine,DefsOnlyMachine,FinalErrors) :- |
| 1241 | | create_machine(MainName,Empty), |
| 1242 | | extract_definitions(RawMachine,Empty,DefsOnlyMachine,Errors,[]), |
| 1243 | | sort(Errors,FinalErrors), |
| 1244 | | add_all_perrors(FinalErrors). |
| 1245 | | |
| 1246 | | extract_definitions(RawMachine,In,Out,Ein,Eout) :- |
| 1247 | | optional_rawmachine_sections([definitions,substitutions,predicates,expressions],RawMachine,[],AllDefinitions), |
| 1248 | | write_section(definitions,Definitions,In,Out), |
| 1249 | | % remove all references to definition files from definitions |
| 1250 | | exclude(is_file_definition,AllDefinitions,Definitions1), |
| 1251 | | % replace expression_definition(...) by defintion(expression,...), etc. |
| 1252 | | change_definition_style(Definitions1,Definitions2), |
| 1253 | | % analyse dependencies |
| 1254 | | add_def_dependency_information(Definitions2,Definitions3,Ein,Eout), |
| 1255 | | % replace external function definitions by calls to the external function |
| 1256 | | replace_external_declarations(Definitions3,Definitions). |
| 1257 | | |
| 1258 | | is_file_definition(file_definition(_Pos,_Filename)). |
| 1259 | | |
| 1260 | | change_definition_style(DefsIn,DefsOut) :- |
| 1261 | | maplist(change_definition_style2,DefsIn,DefsOut). |
| 1262 | | change_definition_style2(Def,definition_decl(Name,DefType,Pos,Args,RawExpr)) :- |
| 1263 | | Def =.. [Functor,Pos,Name,Args,RawExpr], |
| 1264 | | !, |
| 1265 | | maplist(check_def_argument(Name,Pos),Args), |
| 1266 | | map_def_functor(Functor,DefType). |
| 1267 | | change_definition_style2(Def,_) :- |
| 1268 | | add_internal_error('Unrecognised DEFINITION declaration:',Def),fail. |
| 1269 | | |
| 1270 | | map_def_functor(expression_definition,X) :- !, X=expression. |
| 1271 | | map_def_functor(predicate_definition,X) :- !, X=predicate. |
| 1272 | | map_def_functor(substitution_definition,X) :- !, X=substitution. |
| 1273 | | map_def_functor(expression,X) :- !, X=expression. % from EXPRESSIONS section |
| 1274 | | map_def_functor(predicate,X) :- !, X=predicate. % from PREDICATES section |
| 1275 | | map_def_functor(substitution,X) :- !, X=substitution. % from SUBSTITUTIONS section |
| 1276 | | map_def_functor(X,expression) :- add_internal_error('Illegal definition AST node:',X). |
| 1277 | | |
| 1278 | | % check formal arguments of definitions , e.g., here xx in square2 is not an identifier: xx == 20; square2(xx) == xx*xx |
| 1279 | | check_def_argument(_,_,identifier(_,_)) :- !. |
| 1280 | | check_def_argument(DefName,DefPos,definition(_,ID,_)) :- !, |
| 1281 | | tools:ajoin(['Formal parameter ', ID, ' is a definition call in Definition: '],Msg), |
| 1282 | | add_error(bmachine_construction,Msg,DefName,DefPos). |
| 1283 | | check_def_argument(DefName,DefPos,FP) :- !, |
| 1284 | | tools:ajoin(['Formal parameter ', FP, ' is not an identifier in Definition: '],Msg), |
| 1285 | | add_error(bmachine_construction,Msg,DefName,DefPos). |
| 1286 | | |
| 1287 | | replace_external_declarations(Definitions,NewDefs) :- |
| 1288 | | split_list(is_external_declaration,Definitions,ExtFunctionDecls,RestDefs), |
| 1289 | | foldl(replace_external_declaration,ExtFunctionDecls,RestDefs,NewDefs). |
| 1290 | | is_external_declaration(definition_decl(DefName,expression,_Pos,_Params,_Def,_Dependencies)) :- |
| 1291 | ? | external_name(DefName,ExtType,_ExpectedDefType,_ExtCall,FunName), |
| 1292 | | debug_format(4,'external ~w declared: ~w~n', [ExtType,FunName]). |
| 1293 | | external_name(DefName,_,_,_,_) :- |
| 1294 | | \+ atom(DefName),!, |
| 1295 | | add_internal_error('Non-atomic DEFINITION id:',DefName),fail. |
| 1296 | | external_name(DefName,function,expression,external_function_call,FunName) :- |
| 1297 | | atom_concat('EXTERNAL_FUNCTION_',FunName,DefName). |
| 1298 | | external_name(DefName,predicate,predicate,external_pred_call,FunName) :- |
| 1299 | | atom_concat('EXTERNAL_PREDICATE_',FunName,DefName). |
| 1300 | | external_name(DefName,substitution,substitution,external_subst_call,FunName) :- |
| 1301 | | atom_concat('EXTERNAL_SUBSTITUTION_',FunName,DefName). |
| 1302 | | |
| 1303 | | replace_external_declaration(definition_decl(DefName,expression,DefPos,TypeParams,Decl,_Deps),In,Out) :- |
| 1304 | | OldDefinition = definition_decl(FunName,ExpectedDefType,Pos,FunParams,FunDef,Deps), |
| 1305 | | NewDefinition = definition_decl(FunName,ExpectedDefType,Pos,FunParams,ExtCall,Deps), |
| 1306 | ? | ( external_name(DefName,_ExtType,ExpectedDefType,ExtCallFunctor,FunName), |
| 1307 | | ExtCall =.. [ExtCallFunctor,Pos,FunName,FunParams,FunDef, |
| 1308 | | rewrite_protected(TypeParams),rewrite_protected(Decl)], |
| 1309 | | selectchk(OldDefinition,In,NewDefinition,Out) -> |
| 1310 | | assert_external_procedure_used(FunName) |
| 1311 | | ; external_name(DefName,ExpectedKind,_,_,FunName), |
| 1312 | | selectchk(definition_decl(FunName,OtherDefType,_OtherPos,_,_,_),In,_,_),!, |
| 1313 | | % definition found for different type of external function |
| 1314 | | ajoin(['No DEFINITION associated with external ',ExpectedKind, |
| 1315 | | ' (but definition as ',OtherDefType,' exists):'],Msg), |
| 1316 | | add_error(replace_external_declaration,Msg,DefName,DefPos), Out=In |
| 1317 | | ; external_name(DefName,ExpectedKind,_,_,FunName) -> |
| 1318 | | % no definition found for external function |
| 1319 | | ajoin(['No DEFINITION associated with external ',ExpectedKind,':'],Msg), |
| 1320 | | add_error(replace_external_declaration,Msg,DefName,DefPos), Out=In |
| 1321 | | ; % no definition found for external function |
| 1322 | | ajoin(['No DEFINITION associated with:'],Msg), |
| 1323 | | add_error(replace_external_declaration,Msg,DefName,DefPos), Out=In |
| 1324 | | ). |
| 1325 | | |
| 1326 | | :- use_module(external_function_declarations, |
| 1327 | | [external_function_library/2, safe_external_function_library/2, |
| 1328 | | get_external_function_definition/3]). |
| 1329 | | % store external definitions of a given library in the type environment, e.g. for debugging in Repl or VisB |
| 1330 | | % Library could be "LibraryStrings.def" |
| 1331 | | |
| 1332 | | store_ext_defs(Library,In,Out) :- |
| 1333 | | (Library = all_available_libraries |
| 1334 | | -> findall(extfun(Id,Lib),external_function_library(Id,Lib),Ids) |
| 1335 | | ; Library = safe_available_libraries |
| 1336 | | -> findall(extfun(Id,Lib),safe_external_function_library(Id,Lib),Ids) |
| 1337 | | ; findall(extfun(Id,Library),external_function_library(Id,Library),Ids) |
| 1338 | | ), |
| 1339 | | (Ids=[] -> add_warning(store_ext_defs,'No external functions found for library: ',Library) ; true), |
| 1340 | | foldl(store_ext_def,Ids,In,Out). |
| 1341 | | |
| 1342 | | store_ext_def(extfun(Id,Library),In,Out) :- env_lookup_type(Id,In,_),!, |
| 1343 | | debug_println(4,not_storing_ext_def(Id,Library)), % already imported from stdlib or user has other definition |
| 1344 | | Out=In. |
| 1345 | | store_ext_def(extfun(FunName,Library),In,Out) :- |
| 1346 | ? | get_external_function_definition(FunName,Library,DEFINITION),!, |
| 1347 | | debug_println(4,storing_ext_def(FunName,Library)), |
| 1348 | | env_store(FunName,DEFINITION,[loc('automatically included',Library,definitions)],In,Out). |
| 1349 | | store_ext_def(extfun(Id,_),In,Out) :- |
| 1350 | | add_internal_error('Cannot add external definition: ',Id), |
| 1351 | | Out=In. |
| 1352 | | |
| 1353 | | |
| 1354 | | % store which machine promotes which operations |
| 1355 | | :- dynamic machine_promotes_operations/2, machine_hides_unpromoted_operation/4, machine_global_order/1. |
| 1356 | | :- dynamic used_machine_not_included_anywhere/3. |
| 1357 | | |
| 1358 | | reset_bmachine_construction :- |
| 1359 | | retractall(machine_promotes_operations(_,_)), |
| 1360 | | retractall(machine_hides_unpromoted_operation(_,_,_,_)), |
| 1361 | | retractall(abstract_variable_removed_in(_,_,_)), |
| 1362 | | retractall(machine_global_order(_)), |
| 1363 | | retractall(used_machine_not_included_anywhere(_,_,_)), |
| 1364 | | reset_external_procedure_used. |
| 1365 | | |
| 1366 | | |
| 1367 | | % maybe this information should be stored somewhere else ?? |
| 1368 | | :- dynamic external_procedure_used/1. |
| 1369 | | reset_external_procedure_used :- retractall(external_procedure_used(_)). |
| 1370 | | assert_external_procedure_used(FunName) :- |
| 1371 | | (external_procedure_used(FunName) -> true ; assertz(external_procedure_used(FunName))). |
| 1372 | | |
| 1373 | | link_to_refinement(machine,_,_RawMachine,_RefMachines,Local,Local,Errors,Errors). |
| 1374 | | link_to_refinement(refinement,Name,RawMachine,RefMachines,Local,NewLocal,Ein,Eout) :- |
| 1375 | | link_to_refinement(implementation,Name,RawMachine,RefMachines,Local,NewLocal,Ein,Eout). |
| 1376 | | link_to_refinement(implementation,Name,RawMachine,RefMachines,Local,NewLocal,Ein,Eout) :- |
| 1377 | | link_to_refinement2(implementation,Name,RawMachine,RefMachines,Local,NewLocal,Ein,Eout). |
| 1378 | | link_to_refinement2(_MType,Name,RawMachine,RefMachines,Local,NewLocal,Ein,Eout) :- |
| 1379 | | memberchk(ref(abstraction,AbstractMachine),RefMachines), |
| 1380 | | copy_constraints(Local,AbstractMachine,NewLocal,Ein,E1), |
| 1381 | | type_vars_in_refinement(AbstractMachine,NewLocal), |
| 1382 | | type_refinement_operations(Name,RawMachine,AbstractMachine,NewLocal,E1,Eout). |
| 1383 | | |
| 1384 | | copy_constraints(Local,AbstractMachine,NewLocal,Ein,Eout) :- |
| 1385 | | get_section(parameters,Local,LocalParameters), |
| 1386 | | get_section(parameters,AbstractMachine,AbstractParameters), |
| 1387 | | check_if_equal_identifiers(LocalParameters,AbstractParameters,Ein,Eout,Local), |
| 1388 | | get_section(constraints,AbstractMachine,Constraints), |
| 1389 | | write_section(constraints,Constraints,Local,NewLocal). |
| 1390 | | check_if_equal_identifiers(Local,Abstract,Ein,Eout,LocalMachine) :- |
| 1391 | | ( same_length(Local,Abstract) -> |
| 1392 | | foldl(check_if_equal_identifiers2,Local,Abstract,Ein,Eout) |
| 1393 | | ; |
| 1394 | | get_texpr_ids(Abstract,AIDs), |
| 1395 | | get_machine_name(LocalMachine,MachName), |
| 1396 | | ajoin(['Refinement ',MachName,' must have same Parameters ', AIDs,' as abstract Machine'],Msg), |
| 1397 | | Ein = [error(Msg,none)|Eout] |
| 1398 | | ). |
| 1399 | | check_if_equal_identifiers2(LParam,AParam,Ein,Eout) :- |
| 1400 | | get_texpr_id(LParam,LName), |
| 1401 | | get_texpr_id(AParam,AName), |
| 1402 | | ( LName = AName -> |
| 1403 | | % type in refinement is the same as in the abstraction |
| 1404 | | get_texpr_type(LParam,Type), |
| 1405 | | get_texpr_type(AParam,Type), |
| 1406 | | Ein=Eout |
| 1407 | | ; |
| 1408 | | get_texpr_pos(LParam,Pos), |
| 1409 | | ajoin(['Parameter ',LName,' of refinement machine must be ', |
| 1410 | | AName,' like in the abstract machine'],Msg), |
| 1411 | | Ein = [error(Msg,Pos)|Eout] |
| 1412 | | ). |
| 1413 | | |
| 1414 | | % in case of a refinement, give variables the same type as in the abstract machine |
| 1415 | | % the same for constants |
| 1416 | | type_vars_in_refinement(AbstractMachine,ConcreteMachine) :- |
| 1417 | | pass_type(AbstractMachine,[abstract_variables,concrete_variables], |
| 1418 | | ConcreteMachine,[abstract_variables,concrete_variables]), |
| 1419 | | pass_type(AbstractMachine,[abstract_constants,concrete_constants], |
| 1420 | | ConcreteMachine,[abstract_constants,concrete_constants]). |
| 1421 | | |
| 1422 | | % pass the type from variables in Sections1 of Machine1 to |
| 1423 | | % the variables of the same name in Sections2 of Machine2 |
| 1424 | | % Machine1,Machine2: a machine |
| 1425 | | % Sections1, Sections2: a list of section names |
| 1426 | | pass_type(Machine1,Sections1,Machine2,Sections2) :- |
| 1427 | | get_sections_and_append(Sections1,Machine1,Vars1), |
| 1428 | | get_sections_and_append(Sections2,Machine2,Vars2), |
| 1429 | | maplist(pass_type2(Vars2),Vars1). |
| 1430 | | get_sections_and_append([],_M,[]). |
| 1431 | | get_sections_and_append([Sec|RestSections],M,R) :- |
| 1432 | | get_section(Sec,M,L), append(L,Rest,R), |
| 1433 | | get_sections_and_append(RestSections,M,Rest). |
| 1434 | | pass_type2(DstVariables,SrcVariable) :- |
| 1435 | | get_texpr_id(SrcVariable,Id), |
| 1436 | | get_texpr_id(DstVariable,Id), |
| 1437 | | ( memberchk(DstVariable,DstVariables) -> |
| 1438 | | get_texpr_type(DstVariable,Type), |
| 1439 | | get_texpr_type(SrcVariable,Type) |
| 1440 | | ; |
| 1441 | | true). |
| 1442 | | |
| 1443 | | |
| 1444 | | % in case of a refinement, check if the defined operations are already defined |
| 1445 | | % in the abstract machine and copy that type. |
| 1446 | | type_refinement_operations(MName,RawMachine,AbstractMachine,Local,Ein,Eout) :- |
| 1447 | | get_operation_identifiers(RawMachine,Operations), |
| 1448 | | type_refinement_operations2(Operations,MName,Local,AbstractMachine,Ein,Eout). |
| 1449 | | type_refinement_operations2([],_,_,_AbstractMachine,Errors,Errors). |
| 1450 | | type_refinement_operations2([Op|Rest],MName,M,AbstractMachine,Ein,Eout) :- |
| 1451 | | get_abstract_operation_name_wo_infos(Op,AOp), |
| 1452 | | %print(treating_refines_operation(Op,AOp)),nl, |
| 1453 | | get_texpr_pos(Op,Pos), |
| 1454 | | % look up the abstract definition |
| 1455 | | get_abstract_op(AOp,MName,AbstractMachine,Pos,Ein,E1), |
| 1456 | | % store the type in the identifier section |
| 1457 | | copy_texpr_wo_info(Op,SOp), |
| 1458 | | ( get_section(promoted,M,Operations), |
| 1459 | | memberchk(SOp, Operations) -> true |
| 1460 | | ; get_section(unpromoted,M,Operations), % this is probably a LOCAL_OPERATION |
| 1461 | | memberchk(SOp, Operations) -> true |
| 1462 | | ; add_error(btypechecker,'Could not find operation for type checking:',Op),fail |
| 1463 | | ), |
| 1464 | | % do the rest |
| 1465 | | type_refinement_operations2(Rest,MName,M,AbstractMachine,E1,Eout). |
| 1466 | | % looks up the type of the operator in an abstract machine |
| 1467 | | get_abstract_op(Op,_,Abstraction,_,Errors,Errors) :- |
| 1468 | | % look for the operation in promoted and unpromoted |
| 1469 | | ( get_section(promoted,Abstraction,AbstractOps), member(Op,AbstractOps) |
| 1470 | | ; get_section(unpromoted,Abstraction,AbstractOps), member(Op,AbstractOps) ), |
| 1471 | | % forget alternatives |
| 1472 | | !. |
| 1473 | | get_abstract_op(Op,_,_Abstraction,_Pos,Errors,Errors) :- |
| 1474 | | % we might allow new operations |
| 1475 | | get_preference(allow_new_ops_in_refinement,true),!, % ALLOW_NEW_OPERATIONS_IN_REFINEMENT |
| 1476 | | get_texpr_type(Op,op(_,_)). |
| 1477 | | get_abstract_op(Op,MName,AbstractMachine,Pos,[warning(Msg,Pos)|Eout],Eout) :- |
| 1478 | | % in case we do not find the operation, store an error |
| 1479 | | get_texpr_id(Op,op(Id)), |
| 1480 | | get_machine_name(AbstractMachine,Name), |
| 1481 | | ajoin(['operation ', Id, ' from ', MName, ' is not defined in the abstract machine ',Name, |
| 1482 | | ' (set ALLOW_NEW_OPERATIONS_IN_REFINEMENT to TRUE to allow this)'], Msg). |
| 1483 | | % copy a typed expression without the additional information (just expression and type) |
| 1484 | | copy_texpr_wo_info(A,B) :- |
| 1485 | | % copy the expression and type, the additional information may be different |
| 1486 | | get_texpr_expr(A,Expr),get_texpr_expr(B,Expr), |
| 1487 | | get_texpr_type(A,Type),get_texpr_type(B,Type). |
| 1488 | | |
| 1489 | | get_abstract_operation_name_wo_infos(b(_,Type,Infos),Res) :- |
| 1490 | | memberchk(refines_operation(RefID),Infos),!, % renaming occurs: |
| 1491 | | Res = b(identifier(op(RefID)),Type,_). |
| 1492 | | get_abstract_operation_name_wo_infos(ID,Copy) :- copy_texpr_wo_info(ID,Copy). |
| 1493 | | |
| 1494 | | create_id_sections(Header,RawMachine,Name) --> |
| 1495 | | create_id_sections_header(Header), |
| 1496 | | %{print(created_header(Name)),nl}, |
| 1497 | | create_set_sections(RawMachine,Name), |
| 1498 | | %{print(created_set(Name)),nl}, |
| 1499 | | create_constants_sections(RawMachine), |
| 1500 | | %{print(created_constants(Name)),nl}, |
| 1501 | | create_variables_sections(RawMachine), |
| 1502 | | %{print(created_variables(Name)),nl}, |
| 1503 | | create_operations_sections(RawMachine,Name). |
| 1504 | | |
| 1505 | | extract_parameter_types(MachineRefs,ParameterTypes) :- |
| 1506 | | maplist(extract_parameter_types2,MachineRefs,ParameterTypesL), |
| 1507 | | append(ParameterTypesL,ParameterTypes). |
| 1508 | | extract_parameter_types2(ref(_,Machine),ParameterTypes) :- |
| 1509 | | get_section(parameters,Machine,VisibleParams), |
| 1510 | | get_section(internal_parameters,Machine,InternalParams), |
| 1511 | | append(VisibleParams,InternalParams,Params), |
| 1512 | | include(is_a_parameter_set,Params,ParameterSets), |
| 1513 | | maplist(get_texpr_set_type,ParameterSets,ParameterTypes). |
| 1514 | | is_a_parameter_set(TExpr) :- |
| 1515 | | get_texpr_info(TExpr,Info), |
| 1516 | | memberchk(parameter_set,Info). |
| 1517 | | |
| 1518 | | type_sections(RawMachine,MachineType,RefMachines,NonGroundExceptions,Name,Ein,Eout) --> |
| 1519 | | {debug_stats('TYPING CONSTRAINTS'(Name))}, |
| 1520 | | type_constraints(MachineType,Name,RawMachine,RefMachines,NonGroundExceptions,Ein,E1), |
| 1521 | | % Maybe the VALUES section must be moved up later because it may be used to |
| 1522 | | % substitute types (e.g. deferred sets to integers) for later use |
| 1523 | | {debug_stats('TYPING PROPERTIES'(Name))}, |
| 1524 | | type_section_with_single_predicate(properties,Name,[constants],MachineType,RawMachine,RefMachines,NonGroundExceptions,E1,E2), |
| 1525 | | {debug_stats('TYPING INVARIANT'(Name))}, |
| 1526 | | type_section_with_single_predicate(invariant,Name,[variables],MachineType,RawMachine,RefMachines,NonGroundExceptions,E2,E3), |
| 1527 | | {debug_stats('TYPING ASSERTIONS'(Name))}, |
| 1528 | | type_section_with_predicate_list(assertions,[],MachineType,RawMachine,RefMachines,NonGroundExceptions,E3,E4), |
| 1529 | | {debug_stats('TYPING INITIALISATION'(Name))}, |
| 1530 | | type_initialisation_section(RawMachine,Name,MachineType,RefMachines,NonGroundExceptions,E4,E5), |
| 1531 | | {debug_stats('TYPING OPERATIONS'(Name))}, |
| 1532 | | type_operations_section(RawMachine,MachineType,RefMachines,NonGroundExceptions,E5,Eout), |
| 1533 | | {debug_stats('FINISHED TYPING SECTIONS'(Name))}. |
| 1534 | | |
| 1535 | | % skip this section, it is copied from the abstract machine and |
| 1536 | | % does not need to be typed again |
| 1537 | | type_constraints(refinement,_,_RawMachine,_RefMachines,_NonGroundExceptions,Errors,Errors) --> !. |
| 1538 | | type_constraints(implementation,_,_RawMachine,_RefMachines,_NonGroundExceptions,Errors,Errors) --> !. |
| 1539 | | type_constraints(machine,Name,RawMachine,RefMachines,NonGroundExceptions,Ein,Eout) --> |
| 1540 | | % if the machine is a dummy machine (in presence of a not included seen or used |
| 1541 | | % machine), we must omit the check that the (lower case) parameters are all typed. |
| 1542 | | % We can assume that they are properly typed by the included machine. |
| 1543 | | {(is_dummy_machine(RawMachine) -> IdsToType = [] ; IdsToType = [parameters])}, |
| 1544 | | type_section_with_single_predicate(constraints,Name,IdsToType,machine, |
| 1545 | | RawMachine,RefMachines,NonGroundExceptions,Ein,Eout). |
| 1546 | | |
| 1547 | ? | is_dummy_machine(RawMachine) :- member(is_dummy,RawMachine),!. |
| 1548 | | |
| 1549 | | % Header: Parameters |
| 1550 | | create_id_sections_header(machine_header(_,_,Parameters),Old,New) :- |
| 1551 | | write_section(parameters,TParams,Old,New), |
| 1552 | | maplist(create_id_section_parameter,Parameters,TParams). |
| 1553 | | create_id_section_parameter(Param,TParam) :- |
| 1554 | | Expr=identifier(Name), |
| 1555 | | ext2int_with_pragma(Param,Expr,_,Type,Expr,[ParameterType],TParam), |
| 1556 | | ( is_upper_case(Name) -> |
| 1557 | | ParameterType = parameter_set, |
| 1558 | | Type = set(_) |
| 1559 | | ; |
| 1560 | | ParameterType = parameter_scalar). |
| 1561 | | is_upper_case(Name) :- \+ atom(Name),!, add_internal_error('Illegal call:', is_upper_case(Name)),fail. |
| 1562 | | is_upper_case(Name) :- atom_codes(Name,[C|_]), |
| 1563 | | memberchk(C,"ABCDEFGHIJKLMNOPQRSTUVWXYZ"). |
| 1564 | | |
| 1565 | | % Body: Sets |
| 1566 | | create_set_sections(Sections,MachineName) --> |
| 1567 | | write_section(deferred_sets,DeferredSets), |
| 1568 | | write_section(enumerated_sets,EnumeratedSets), |
| 1569 | | write_section(enumerated_elements,EnumeratedElements), |
| 1570 | | {optional_rawmachine_section(sets,Sections,[],Sets), |
| 1571 | | split_list(is_deferred_set_element,Sets,RawDeferredSets,RawEnumeratedSets), |
| 1572 | | maplist(create_deferred_set_section(MachineName),RawDeferredSets,DeferredSets), |
| 1573 | | maplist(create_enumerated_set_section(Sections,MachineName), |
| 1574 | | RawEnumeratedSets,EnumeratedSets,LEnumeratedElements), |
| 1575 | | append(LEnumeratedElements,EnumeratedElements)}. |
| 1576 | | is_deferred_set_element(AstElem) :- has_functor(AstElem,deferred_set,_). |
| 1577 | | create_deferred_set_section(MachineName,DS,TExpr) :- |
| 1578 | | unwrap_opt_description(DS,deferred_set(Pos,I),TInfos), |
| 1579 | | Infos = [given_set,def(deferred_set,MachineName)|TInfos], |
| 1580 | | create_global_id(I,Pos,Infos,TExpr). |
| 1581 | | create_enumerated_set_section(Sections,MachineName,ES,TExpr,Elements) :- |
| 1582 | | unwrap_opt_description(ES,EnumSetList,TInfos), |
| 1583 | | create_enum_set_aux(EnumSetList,Sections,MachineName,TInfos,TExpr,Elements). |
| 1584 | | |
| 1585 | | create_global_id(identifier(_,Id),Pos,Infos,TExpr) :- !, |
| 1586 | | add_warning(bmachine_construction,'Identifier unexpectedly not atomic: ',Id,Pos), % happened e.g. in ANTLR parser |
| 1587 | | create_identifier(Id,Pos,set(global(Id)),Infos,TExpr). |
| 1588 | | create_global_id(Id,Pos,Infos,TExpr) :- !, |
| 1589 | | create_identifier(Id,Pos,set(global(Id)),Infos,TExpr). |
| 1590 | | |
| 1591 | | create_enum_set_aux(enumerated_set(Pos,I,Elems),_,MachineName,TInfos,TExpr,Elements) :- !, |
| 1592 | | % regular case I = {Elems1, ...} |
| 1593 | | Infos = [given_set,def(enumerated_set,MachineName)|TInfos], |
| 1594 | | create_global_id(I,Pos,Infos,TExpr), |
| 1595 | | maplist(create_enum_set_element(I,MachineName),Elems,Elements). |
| 1596 | | create_enum_set_aux(enumerated_set_via_def(Pos,I,ElemsDEF),Sections,MachineName,TInfos,TExpr,Elements) :- !, |
| 1597 | | % we have the case I = ElemsDEF and DEFINITIONS ElemsDEF == {Elems1, ...} |
| 1598 | | Infos = [given_set,def(enumerated_set,MachineName)|TInfos], |
| 1599 | | create_global_id(I,Pos,Infos,TExpr), |
| 1600 | | (optional_rawmachine_section(definitions,Sections,[],Defs), |
| 1601 | | member(expression_definition(DPos,ElemsDEF,Paras,DefBody),Defs) |
| 1602 | | -> (Paras \= [] |
| 1603 | | -> add_error(bmachine_construction, |
| 1604 | | 'DEFINITION for enumerated set elements must not have parameters:',ElemsDEF,DPos), |
| 1605 | | Elements=[] |
| 1606 | | ; DefBody = set_extension(_,Elems), |
| 1607 | | maplist(create_enum_set_element(I,MachineName),Elems,Elements) |
| 1608 | | -> true |
| 1609 | | ; add_error(bmachine_construction, |
| 1610 | | 'DEFINITION for enumerated set elements must be of the form {El1,El2,...}:',ElemsDEF,DPos), |
| 1611 | | Elements=[] |
| 1612 | | ) |
| 1613 | | ; add_error(bmachine_construction,'No DEFINITION for enumerated set elements found:',ElemsDEF,Pos), |
| 1614 | | Elements=[] |
| 1615 | | ). |
| 1616 | | create_enum_set_aux(E,_,_,_,_,_) :- add_internal_error('Illegal enumerated set:',E),fail. |
| 1617 | | |
| 1618 | | |
| 1619 | | % deal with optional description(Pos,Desc,A) wrapper |
| 1620 | | has_functor(description(_,_Desc,A),Functor,Arity) :- !, functor(A,Functor,Arity). |
| 1621 | | has_functor(A,Functor,Arity) :- functor(A,Functor,Arity). |
| 1622 | | |
| 1623 | | % remove description wrapper and generate info field |
| 1624 | | unwrap_opt_description(Pragma,Res,Infos) :- |
| 1625 | | unwrap_pragma(Pragma,Expr,I),!, Res=Expr,Infos=I. |
| 1626 | | unwrap_opt_description(A,A,[]). |
| 1627 | | |
| 1628 | | |
| 1629 | | create_enum_set_element(Id,MachineName,Ext,Elem) :- |
| 1630 | | (Id=identifier(none,RID) |
| 1631 | | -> Type=global(RID), add_warning(bmachine_construction,'Unexpected non-atomic global set id: ',RID) |
| 1632 | | ; Type=global(Id)), |
| 1633 | | ext2int_with_pragma(Ext,Expr,_Pos,Type,Expr,[enumerated_set_element,def(enumerated_element,MachineName)],Elem). |
| 1634 | | |
| 1635 | | create_identifier(Id,Pos,Type,Infos,TExpr) :- |
| 1636 | | create_texpr(identifier(Id),Type,[nodeid(Pos)|Infos],TExpr). |
| 1637 | | |
| 1638 | | % Constants |
| 1639 | | create_constants_sections(RawMachine) --> |
| 1640 | | create_section_identifiers(constants,concrete_constants,RawMachine), |
| 1641 | | create_section_identifiers(abstract_constants,abstract_constants,RawMachine). |
| 1642 | | % Variables |
| 1643 | | create_variables_sections(RawMachine) --> |
| 1644 | | create_section_identifiers(concrete_variables,concrete_variables,RawMachine), |
| 1645 | | create_section_identifiers(variables,abstract_variables,RawMachine). |
| 1646 | | |
| 1647 | | % Freetypes: Treat them as additional constants, plus add entries in the "freetypes" |
| 1648 | | % section of the resulting machine |
| 1649 | | create_freetypes(RawMachine,MType,RefMachines,Old,New,Ein,Eout) :- |
| 1650 | | optional_rawmachine_section(freetypes,RawMachine,[],RawFreetypes), |
| 1651 | ? | create_freetypes2(RawFreetypes,MType,[ref(local,Old)|RefMachines],Old,New,Ein,Eout). |
| 1652 | | create_freetypes2([],_MType,_RefMachines,M,M,E,E) :- !. |
| 1653 | | create_freetypes2(RawFreetypes,MType,RefMachines,Old,New,Ein,Eout) :- |
| 1654 | | % we need the NonGroundExceptions for type checking |
| 1655 | | extract_parameter_types(RefMachines,NonGroundExceptions), |
| 1656 | | % create identifiers in the constants section |
| 1657 | ? | maplist(create_ids_for_freetype,RawFreetypes,IdsFreetypes), |
| 1658 | | % we just combined the results to keep the numbers of arguments low (too much for maplist) |
| 1659 | | maplist(split_ft,IdsFreetypes,IdentifiersL,Freetypes), |
| 1660 | | append(IdentifiersL,Identifiers), |
| 1661 | | % create properties for each freetype |
| 1662 | | foldl(create_properties_for_freetype(MType,RefMachines,NonGroundExceptions,Identifiers), |
| 1663 | | RawFreetypes,IdsFreetypes,PropertiesL,Ein,Eout), |
| 1664 | | conjunct_predicates(PropertiesL,Properties), |
| 1665 | | (debug_mode(off) -> true |
| 1666 | | ; format('Created PROPERTIES for FREETYPES:~n',[]), translate:nested_print_bexpr(Properties),nl), |
| 1667 | | append_to_section(abstract_constants,Identifiers,Old,Inter), |
| 1668 | | conjunct_to_section(properties,Properties,Inter,Inter2), |
| 1669 | | write_section(freetypes,Freetypes,Inter2,New). |
| 1670 | | |
| 1671 | | split_ft(ft(Ids,Freetype),Ids,Freetype). |
| 1672 | | |
| 1673 | | |
| 1674 | | create_ids_for_freetype(FT,ft([TId|TCons],freetype(Id,Cases))) :- |
| 1675 | | is_freetype_declaration(FT,_Pos,Id,_TypeParams,Constructors), |
| 1676 | | !, |
| 1677 | | create_typed_id_with_given_set_info(Id,set(freetype(Id)),TId), |
| 1678 | ? | maplist(create_ids_for_constructor(Id),Constructors,TCons,Cases). |
| 1679 | | create_ids_for_freetype(FT,_) :- |
| 1680 | | add_internal_error('Illegal freetype term:',create_ids_for_freetype(FT,_)),fail. |
| 1681 | | |
| 1682 | | % add given_set info so that is_just_type3 can detect this as a type |
| 1683 | | create_typed_id_with_given_set_info(IDName,Type,b(identifier(IDName),Type,[given_set])). |
| 1684 | | |
| 1685 | | % deconstruct a .prob Prolog encoding of a freetype declaration |
| 1686 | | % new versions of parser generate freetype parameters |
| 1687 | | is_freetype_declaration(freetype(Pos,Id,Constructors),Pos,Id,[],Constructors). |
| 1688 | | is_freetype_declaration(freetype(Pos,Id,TypeParams,Constructors),Pos,Id,TypeParams,Constructors) :- |
| 1689 | | (TypeParams=[] -> true ; add_warning(bmachine_construction,'Not yet supporting freetype parameters:',Id,Pos)). |
| 1690 | | |
| 1691 | | create_ids_for_constructor(Id,constructor(_Pos,Name,_Arg),TCons,case(Name,Type)) :- |
| 1692 | | create_typed_id(Name,set(couple(Type,freetype(Id))),TCons). |
| 1693 | | create_ids_for_constructor(Id,element(_Pos,Name),TCons,case(Name,constant([Name]))) :- |
| 1694 | | create_typed_id(Name,freetype(Id),TCons). |
| 1695 | | |
| 1696 | | create_properties_for_freetype(MType,RefMachines,NonGroundExceptions, AllFTIdentifiers, |
| 1697 | | FREETYPE,ft(Ids,_Freetypes),Properties,Ein,Eout) :- |
| 1698 | | is_freetype_declaration(FREETYPE,_Pos,Id,_TypeParams,Constructors), |
| 1699 | | debug_format(9,'Processing freetype ~w (one of ~w)~n',[Id,AllFTIdentifiers]), |
| 1700 | | % The freetype type |
| 1701 | | FType = freetype(Id), |
| 1702 | | % We use the standard type environment of properties... |
| 1703 | | visible_env(MType,properties,RefMachines,CEnv,Ein,E1), |
| 1704 | | % ...plus the identifiers of the free type (type name and constructor names) |
| 1705 | | add_identifiers_to_environment(Ids,CEnv,FEnv0), |
| 1706 | | % ...plus the identifiers of all free type names (will overwrite Id, but not a problem) |
| 1707 | | % Note: instead of adding all freetype ids, we could just add the ones preceding Id |
| 1708 | | add_identifiers_to_environment(AllFTIdentifiers,FEnv0,FEnv), |
| 1709 | | % We generate a comprehension set for all elements |
| 1710 | | create_typed_id(Id,set(FType),TId), |
| 1711 | | create_texpr(equal(TId,TComp),pred,[],FDef), |
| 1712 | | unique_typed_id("_freetype_arg",FType,Element), |
| 1713 | | create_recursive_compset([Element],ECond,set(FType),[],RecId,TComp), |
| 1714 | | create_typed_id(RecId,set(FType),TRecId), |
| 1715 | | % For each constructor, we generate a definition and a condition for the |
| 1716 | | % comprehension set above |
| 1717 | | foldl(create_properties_for_constructor(Id,FEnv,Element,TRecId,NonGroundExceptions), |
| 1718 | | Constructors,Defs,Conds,E1,Eout), |
| 1719 | | conjunct_predicates(Conds,ECond), |
| 1720 | | conjunct_predicates([FDef|Defs],Properties). |
| 1721 | | |
| 1722 | | /* create_properties_for_constructor(+Env,+Element,+RecId,+NGE,+Constructor,-Def,-Cond,Ein,Eout) |
| 1723 | | Env: Type environment |
| 1724 | | Element: A typed identifier "e" that is used in the definition of the freetype set: |
| 1725 | | ft = {e | e has_freetype_constructor x => e:...} |
| 1726 | | RecId: The typed identifier that can be used to refer to the freetype set (ft in the |
| 1727 | | example above |
| 1728 | | NGE: "Non ground exceptions", needed for type checking when having a parametrized machine |
| 1729 | | Constructor: The constructor expression as it comes from the parser |
| 1730 | | (constructor(Pos,Name,ArgSet) or element(Pos,Name)) |
| 1731 | | Def: The predicate that defines the constant for the constructor, |
| 1732 | | e.g. "cons = {i,o | i:NAT & o = freetype(cons,i)}" |
| 1733 | | Cond: The predicate that checks the argument of a freetype in the freetype set |
| 1734 | | (That would be the part "e:..." in the example above. |
| 1735 | | Ein,Eout: Used for type checker errors |
| 1736 | | */ |
| 1737 | | create_properties_for_constructor(FID,Env,Element,RecId,NonGroundExceptions, |
| 1738 | | Constructor,Def,Cond,Ein,Eout) :- |
| 1739 | | constructor_name(Constructor,Name), |
| 1740 | | env_lookup_type(Name,Env,CType), |
| 1741 | | create_properties_for_constructor2(Constructor,Env,NonGroundExceptions,FID, |
| 1742 | | Element,RecId,CDef,Cond,Ein,Eout), |
| 1743 | | get_texpr_type(CDef,CType), |
| 1744 | | create_typed_id(Name,CType,CId), |
| 1745 | | create_texpr(equal(CId,CDef),pred,[],Def). |
| 1746 | | constructor_name(element(_Pos,Name),Name). |
| 1747 | | constructor_name(constructor(_Pos,Name,_Domain),Name). |
| 1748 | | create_properties_for_constructor2(element(_Pos,Name),_Env,_NonGroundExceptions,FID, |
| 1749 | | _Element,_RecId,CDef,Cond,Ein,Ein) :- |
| 1750 | | create_texpr(value(freeval(FID,Name,term(Name))),freetype(FID),[],CDef), |
| 1751 | | create_texpr(truth,pred,[],Cond). |
| 1752 | | create_properties_for_constructor2(constructor(_Pos,Name,RArg),Env,NonGroundExceptions, |
| 1753 | | FID,Element,RecId,CDef,Cond,Ein,Eout) :- |
| 1754 | | % First, type check the given set of the domain: |
| 1755 | | btype_ground_dl([RArg],Env,NonGroundExceptions,[set(DType)],[TDomain],Ein,Eout), |
| 1756 | | % then create the RHS of "c = {i,o | i:Domain & o=freetype_constructor(Name,i)}" |
| 1757 | | create_definition_for_constructor(Name,TDomain,FID,CDef), |
| 1758 | | % The check in the freetype comprehension set is of the form |
| 1759 | | % e "of_freetype_case" Name => "content_of"(e) : Domain |
| 1760 | | create_texpr(implication(IsCase,DomainTest),pred,[],Cond), |
| 1761 | | create_texpr(freetype_case(FID,Name,Element),pred,[],IsCase), |
| 1762 | | create_texpr(freetype_destructor(FID,Name,Element),DType,[],Content), |
| 1763 | | % all references to the freetype itself are replaced by the recursive reference |
| 1764 | | replace_id_by_expr(TDomain,FID,RecId,TDomain2), |
| 1765 | | create_texpr(member(Content,TDomain2),pred,[],DomainTest). |
| 1766 | | |
| 1767 | | :- use_module(bsyntaxtree,[get_texpr_set_type/2]). |
| 1768 | | |
| 1769 | | /* The constructor is a function to the freetype, defined with a comprehension set: |
| 1770 | | The general form is "c = {i,o | i:Domain & o=freetype_constructor(Name,i)}" |
| 1771 | | create_definition_for_constructor(+Name,+DType,+FID,-CType,-CDef) :- |
| 1772 | | Name: Name of the constructor |
| 1773 | | TDomain: The user-specified domain |
| 1774 | | FID: The name of the free type |
| 1775 | | CDef: The RHS of the definition "Name = CDef" |
| 1776 | | */ |
| 1777 | | create_definition_for_constructor(Name,TDomain,FID,CDef) :- |
| 1778 | | % get the type of the domain: |
| 1779 | | get_texpr_set_type(TDomain,DType), |
| 1780 | | % create argument and result identifiers: |
| 1781 | | unique_typed_id("_constr_arg",DType,TArgId), % was constructor_arg and constructor_res |
| 1782 | | unique_typed_id("_constr_res",freetype(FID),TResId), |
| 1783 | | % The comprehension set as a whole |
| 1784 | | CType = set(couple(DType,freetype(FID))), |
| 1785 | | create_texpr(comprehension_set([TArgId,TResId],Pred),CType, |
| 1786 | | [prob_annotation('SYMBOLIC')],CDef), |
| 1787 | | create_texpr(conjunct(DomainCheck,Construction),pred,[],Pred), |
| 1788 | | % "i:Domain" |
| 1789 | | create_texpr(member(TArgId,TDomain),pred,[],DomainCheck), |
| 1790 | | % "o=freetype_constructor(i) |
| 1791 | | create_texpr(freetype_constructor(FID,Name,TArgId),freetype(FID),[],FreetypeCons), |
| 1792 | | create_texpr(equal(TResId,FreetypeCons),pred,[],Construction). |
| 1793 | | |
| 1794 | | % Operations |
| 1795 | | create_operations_sections(RawMachine,Name,Old,New) :- |
| 1796 | | write_section(promoted,PromotedOperationIds,Old,New0), |
| 1797 | | get_operation_identifiers(RawMachine,operations,OperationIdentifiers), |
| 1798 | | (get_operation_identifiers(RawMachine,local_operations,LocOpIDs), |
| 1799 | | LocOpIDs \= [] % if there is a LOCAL_OPERATIONS section we assume user wants to call them |
| 1800 | | -> maplist(add_infos_to_identifier([is_local_operation]),LocOpIDs,LocOpIds2), |
| 1801 | | append_to_section(unpromoted,LocOpIds2,New0,New), |
| 1802 | | % Now remove all LOCAL_OPERATIONS from the promoted ones |
| 1803 | | % see for example prob_examples/examples/B/ClearSy/RoboSim/SRanger_case_Jul25/logic_i.imp |
| 1804 | | exclude(duplicate_local_operation_id(Name,LocOpIDs),OperationIdentifiers,PromotedOperationIds) |
| 1805 | | ; New = New0, PromotedOperationIds = OperationIdentifiers |
| 1806 | | ). |
| 1807 | | |
| 1808 | | |
| 1809 | | |
| 1810 | | % check if a LOCAL_OPERATION is already declared in the OPERATIONS section: |
| 1811 | | % in this case: we use the operation body defined in the OPERATIONS section, but remove it from the promoted list |
| 1812 | | duplicate_local_operation_id(Name,OpIds,TID) :- |
| 1813 | | get_texpr_id(TID,op(OpID)), |
| 1814 | | member(TID2,OpIds), |
| 1815 | | get_texpr_id(TID2,op(OpID)),!, |
| 1816 | | debug_println(9,duplicate_local_operation_id(OpID,Name)). |
| 1817 | | |
| 1818 | | get_operation_identifiers(RawMachine,OperationIdentifiers) :- |
| 1819 | | get_operation_identifiers(RawMachine,operations,OperationIdentifiers). |
| 1820 | | get_operation_identifiers(RawMachine,SECTION,OperationIdentifiers) :- |
| 1821 | | optional_rawmachine_section(SECTION,RawMachine,[],Ops), |
| 1822 | | maplist(extract_operation_identifier,Ops,OperationIdentifiers). |
| 1823 | | extract_operation_identifier(Ext,TId) :- |
| 1824 | | remove_pos(Ext, operation(ExtId,_,_,_)),!, |
| 1825 | | ext2int_with_pragma(ExtId,identifier(I),_,op(_,_),identifier(op(I)),Infos,TId), |
| 1826 | | operation_infos(Infos). |
| 1827 | | extract_operation_identifier(Ext,TId) :- |
| 1828 | | remove_pos(Ext, refined_operation(ExtId,_,_,RefinesOp,_)),!, |
| 1829 | | ext2int_with_pragma(ExtId,identifier(I),_,op(_,_),identifier(op(I)),[refines_operation(RefinesOp)|Infos],TId), |
| 1830 | | operation_infos(Infos). |
| 1831 | | extract_operation_identifier(Ext,TId) :- |
| 1832 | | remove_pos(Ext, description_operation(_Desc,RealOp)),!, |
| 1833 | | extract_operation_identifier(RealOp,TId). |
| 1834 | | extract_operation_identifier(Ext,_) :- add_internal_error('Unknown operation node:',Ext),fail. |
| 1835 | | |
| 1836 | | % VALUES section: |
| 1837 | | % process_values_section(MachineType,RawMachine,NonGroundExceptions,Min/Ein/RefMIn,Mout/Eout/RefMOut): |
| 1838 | | % Type-check the VALUES section and change the type of valuated deferred sets, if necessary |
| 1839 | | % MachineType, RawMachine, NonGroundExceptions: as usual, see other comments |
| 1840 | | % Min/Mout: The currently constructed machine |
| 1841 | | % Ein/Eout: The difference list of errors |
| 1842 | | % RefMin/RefMout: The list of already typechecked machines. These typechecked machines can be |
| 1843 | | % altered by this predicate because if a deferred set is valuated by an integer set or |
| 1844 | | % other deferred set, all occurrences of the original type are replaced by the new type, |
| 1845 | | % even for the already typed machines. |
| 1846 | | process_values_section(MachineType,RawMachine,NonGroundExceptions,Min/Ein/RefMIn,Mout/Eout/RefMOut) :- |
| 1847 | | optional_rawmachine_section(values,RawMachine,[],RawValues), |
| 1848 | | process_values_section_aux(RawValues,MachineType,NonGroundExceptions, |
| 1849 | | Min/Ein/RefMIn,Mout/Eout/RefMOut). |
| 1850 | | process_values_section_aux([],_MachineType,_NonGroundExceptions,In,Out) :- !,In=Out. |
| 1851 | | process_values_section_aux(RawValues,MachineType,NonGroundExceptions, |
| 1852 | | Min/Ein/RefMin,Mout/Eout/RefMout) :- |
| 1853 | | debug_stats('TYPING VALUES'), |
| 1854 | | type_values_section(MachineType,RawValues,RefMin,NonGroundExceptions,Min/Ein,Mout/Eout), |
| 1855 | | % will be added as additional_property in bmachine |
| 1856 | | RefMin=RefMout. |
| 1857 | | |
| 1858 | | type_values_section(MachineType,RawValues,RefMachines,NonGroundExceptions,Min/Ein,Mout/Eout) :- |
| 1859 | | write_section(values,Values,Min,Mout), |
| 1860 | | visible_env(MachineType,values_expression,RefMachines,Env,Ein,E1), |
| 1861 | | % We have to pass an environment that can be modified because in each |
| 1862 | | % valuation the previously valuated constants can be used. |
| 1863 | | foldl(extract_values_entry(NonGroundExceptions),RawValues,Values,Env/E1,_ResultingEnv/Eout). |
| 1864 | | |
| 1865 | | extract_values_entry(NonGroundExceptions, values_entry(POS,ValueID,ValueExpr), Entry, |
| 1866 | | EnvIn/Ein,EnvOut/Eout) :- |
| 1867 | | % TODO: There seem to be a lot of additional constraints for valuations in VALUES that are not |
| 1868 | | % yet handled here |
| 1869 | | btype_ground_dl([ValueExpr],EnvIn,NonGroundExceptions,[Type],[TExpr],Ein,Eout), |
| 1870 | | clean_up(TExpr,[],CTExpr), % ensure we remove things like mult_or_cart/2 |
| 1871 | | create_identifier(ValueID,POS,Type,[valuated_constant],TypedID), |
| 1872 | | create_texpr(values_entry(TypedID,CTExpr),values_entry,[nodeid(POS)],Entry), |
| 1873 | | debug_println(9,valued_constant(ValueID)), |
| 1874 | | EnvOut=EnvIn. |
| 1875 | | %add_identifiers_to_environment([TypedID],EnvIn,EnvOut). % ideally we should register the new type of TypedID |
| 1876 | | % However: ProB can currently only process VALUES clauses where the type does not change |
| 1877 | | |
| 1878 | | % type_section_with_single_predicate(+Sec,+Name,+SectionsToType,+MachineType,+Sections, |
| 1879 | | % +RefMachines,+NonGroundExceptions,+Ein,-Eout,+Old,-New): |
| 1880 | | % Type a section such as INVARIANT, PROPERTIES, CONSTRAINTS with a single predicate |
| 1881 | | % Sec: section name in the raw (untyped) machine (e.g. invariant) |
| 1882 | | % Name: name of machine from which this section comes |
| 1883 | | % SectionsToType: list of section names that contain identifiers that must be typed |
| 1884 | | % by this predicate (e.g. all variables must be typed by the invariant) |
| 1885 | | % MachineType: machine type (machine, refinement, ...) |
| 1886 | | % Sections: list of sections representing the raw (untyped) machine |
| 1887 | | % RefMachines: list of already typed machines |
| 1888 | | % NonGroundExceptions: list of types that may be not ground because the concrete type |
| 1889 | | % is determinded by machine parameter |
| 1890 | | % Ein/Eout: difference list of errors |
| 1891 | | % Old/New: the new typed section is added (by conjunction) to the machine |
| 1892 | | type_section_with_single_predicate(Sec,Name,SectionsToType,MachineType,Sections, |
| 1893 | | RefMachines,NonGroundExceptions,Ein,Eout,Old,New) :- |
| 1894 | | optional_rawmachine_section(Sec,Sections,truth(none),Predicate), |
| 1895 | | ( Predicate = truth(_) -> |
| 1896 | | % even if there is no content, we must check if all identifiers are typed |
| 1897 | | check_if_all_ids_are_typed(SectionsToType,RefMachines,NonGroundExceptions,Ein,Eout), |
| 1898 | | Old=New |
| 1899 | | ; |
| 1900 | | get_machine_infos(Sections,Infos), |
| 1901 | | toplevel_raw_predicate_sanity_check(Sec,Name,Predicate,Infos), |
| 1902 | | type_predicates(Sec,SectionsToType,MachineType,[Predicate],RefMachines,NonGroundExceptions, |
| 1903 | | [Typed],Ein,Eout), |
| 1904 | | conjunct_to_section(Sec,Typed,Old,New) |
| 1905 | | ), |
| 1906 | | !. |
| 1907 | | type_section_with_single_predicate(Sec,Name,SectsToType,MchType,_,_,_,_,_,_,_) :- |
| 1908 | | add_internal_error('type_section_with_single_predicate failed', |
| 1909 | | type_section_with_single_predicate(Sec,Name,SectsToType,MchType,_,_,_,_,_,_,_)), |
| 1910 | | fail. |
| 1911 | | |
| 1912 | | % get some infos relevant for sanity check: |
| 1913 | | get_machine_infos(Sections,Infos) :- |
| 1914 | | ((rawmachine_section_exists(concrete_variables,Sections) ; rawmachine_section_exists(abstract_variables,Sections)) |
| 1915 | | -> Infos = [has_variables|I1] ; Infos = I1), |
| 1916 | | ((rawmachine_section_exists(concrete_constants,Sections) ; rawmachine_section_exists(abstract_constants,Sections)) |
| 1917 | | -> I1 = [has_constants] ; I1 = []). |
| 1918 | | |
| 1919 | | % Type a section with multiple predicates, such as ASSERTIONS |
| 1920 | | type_section_with_predicate_list(Sec,SectionsToType,MachineType,Sections, |
| 1921 | | RefMachines,NonGroundExceptions,Ein,Eout,Old,New) :- |
| 1922 | | write_section(Sec,Typed,Old,New), |
| 1923 | | optional_rawmachine_section(Sec,Sections,[],Predicates), |
| 1924 | | type_predicates(Sec,SectionsToType,MachineType,Predicates,RefMachines,NonGroundExceptions,Typed,Ein,Eout), |
| 1925 | | !. |
| 1926 | | type_section_with_predicate_list(Sec,SectsToType,MchType,Sects,RefMchs,NonGrndExc,Ein,Eout,Old,New) :- |
| 1927 | | add_internal_error('type_section_with_predicate_list failed', |
| 1928 | | type_section_with_predicate_list(Sec,SectsToType,MchType,Sects,RefMchs,NonGrndExc,Ein,Eout,Old,New)), |
| 1929 | | fail. |
| 1930 | | |
| 1931 | | |
| 1932 | | type_predicates(_Sec,SectionsToType,_MachineType,[],RefMachines,NonGroundExceptions,Typed,Ein,Eout) :- |
| 1933 | | !,Typed=[], |
| 1934 | | check_if_all_ids_are_typed(SectionsToType,RefMachines,NonGroundExceptions,Ein,Eout). |
| 1935 | | type_predicates(Sec,SectionsToType,MachineType,Predicates,RefMachines,NonGroundExceptions,Typed,Ein,Eout) :- |
| 1936 | | visible_env(MachineType, Sec, RefMachines, Env, Ein, E1), |
| 1937 | | same_length(Predicates,Types),maplist(is_pred_type,Types), |
| 1938 | | btype_ground_dl_in_section(Sec,Predicates,Env,NonGroundExceptions,Types,Typed1,E1,E2), |
| 1939 | | mark_with_section(Sec,Typed1,Typed), |
| 1940 | | check_if_all_ids_are_typed(SectionsToType,RefMachines,NonGroundExceptions,E2,Eout), |
| 1941 | | (no_perrors_occured(Ein,Eout) |
| 1942 | | -> perform_post_static_check(Typed) % only run if no type errors, it makes use of find_typed_identifier_uses |
| 1943 | | ; true |
| 1944 | | ). |
| 1945 | | |
| 1946 | | no_perrors_occured(Ein,Eout) :- Ein==Eout,!. |
| 1947 | | no_perrors_occured([H|T],Eout) :- nonvar(H),not_a_perror(H),no_perrors_occured(T,Eout). |
| 1948 | | |
| 1949 | | not_a_perror(warning(_,_)). |
| 1950 | | % other possible values: error(Msg,Pos), internal_error(Msg,Pos); see get_perror/2 |
| 1951 | | |
| 1952 | | % check if the identifiers that should be typed by this section are completly typed |
| 1953 | | check_if_all_ids_are_typed([],_RefMachines,_NonGroundExceptions,Ein,Eout) :- !,Ein=Eout. |
| 1954 | | check_if_all_ids_are_typed(SectionsToType,RefMachines,NonGroundExceptions,Ein,Eout) :- |
| 1955 | | memberchk(ref(local,Local),RefMachines), |
| 1956 | | get_all_identifiers(SectionsToType,Local,IdentifiersToType), |
| 1957 | | check_ground_types_dl(IdentifiersToType, NonGroundExceptions, Ein, Eout). |
| 1958 | | |
| 1959 | | |
| 1960 | | mark_with_section(Sec,In,Out) :- |
| 1961 | | maplist(mark_with_section2(Sec),In,Out). |
| 1962 | | mark_with_section2(Sec,In,Out) :- |
| 1963 | | remove_bt(In,conjunct(A,B),conjunct(NA,NB),Out),!, |
| 1964 | | mark_with_section2(Sec,A,NA), mark_with_section2(Sec,B,NB). |
| 1965 | | mark_with_section2(Sec,In,Out) :- |
| 1966 | | add_texpr_infos(In,[section(Sec)],Out). |
| 1967 | | |
| 1968 | | type_initialisation_section(Sections,Name,MType,RefMachines,NonGroundExceptions,Ein,Eout,Old,New) :- |
| 1969 | | write_section(initialisation,Initialisation,Old,New), |
| 1970 | | ( rawmachine_section_with_opt_desc(initialisation,Sections,Init,Desc,DescPos) -> |
| 1971 | | visible_env(MType, initialisation, RefMachines, InitEnv, Ein, E1), |
| 1972 | | btype_ground_dl([Init],InitEnv,NonGroundExceptions,[subst],[TypedInit],E1,Eout), |
| 1973 | | (Desc='' -> TypedInit2 = TypedInit |
| 1974 | | ; add_texpr_infos(TypedInit,[description(Desc),description_position(DescPos)],TypedInit2) |
| 1975 | | ), |
| 1976 | | Initialisation=[init_stmt(Name,TypedInit2)] |
| 1977 | | ; |
| 1978 | | Ein=Eout, |
| 1979 | | Initialisation=[]). |
| 1980 | | |
| 1981 | | :- use_module(library(ugraphs)). |
| 1982 | | |
| 1983 | | type_operations_section(Sections,MType,RefMachines,NonGroundExceptions,Ein,Eout,Old,New) :- |
| 1984 | | write_section(operation_bodies,Operations,Old,New), |
| 1985 | | visible_env(MType, operation_bodies, RefMachines, Env, Ein, E1), |
| 1986 | | optional_rawmachine_section(operations,Sections,[],Ops1), |
| 1987 | | optional_rawmachine_section(local_operations,Sections,[], LocalOps2), |
| 1988 | | exclude(duplicate_local_operation(Ops1),LocalOps2,FOps2), |
| 1989 | | append(FOps2,Ops1,Ops), |
| 1990 | | topological_sort_operations(Ops,LocalOps2,Env,SOps), |
| 1991 | | (debug_mode(off) -> true ; length(SOps,NrOps),debug_stats(finished_topological_sorting(NrOps))), |
| 1992 | | same_length(SOps,Types), maplist(is_op_type,Types), |
| 1993 | ? | btype_ground_dl(SOps,Env,NonGroundExceptions,Types,Operations,E1,Eout),!. |
| 1994 | | |
| 1995 | | % check if a LOCAL_OPERATION also exists as a regular operation; if so we can ignore it and |
| 1996 | | % just use the full operation; see also duplicate_local_operation_id above |
| 1997 | | duplicate_local_operation(NonLocalOps,LocalOperation) :- |
| 1998 | | raw_op_id(LocalOperation,OpName), |
| 1999 | | member(NonLocalOp,NonLocalOps), |
| 2000 | | raw_op_id(NonLocalOp,OpName), % we found a non-local operation with the same name |
| 2001 | | !, |
| 2002 | | raw_op_pos(LocalOperation,LPos), |
| 2003 | | raw_op_pos(NonLocalOp,NPos), |
| 2004 | | translate_span(NPos,PS2), |
| 2005 | | ajoin(['Ignoring LOCAL_OPERATION already defined in OPERATIONS section ',PS2,': '],Msg), |
| 2006 | | add_message(bmachine_construction,Msg,OpName,LPos). |
| 2007 | | |
| 2008 | | |
| 2009 | | allow_local_or_expr_op_calls :- |
| 2010 | | (get_preference(allow_local_operation_calls,true) -> true |
| 2011 | | ; get_preference(allow_operation_calls_in_expr,true)). |
| 2012 | | % at the moment ProB allows local calls inside expressions, independently of the allow_local_operation_calls preference |
| 2013 | | |
| 2014 | | % perform a topological sort of the operations: treat called operation before calling operation |
| 2015 | | % only relevant when allow_local_operation_calls is set to true |
| 2016 | | topological_sort_operations(Ops,LocalOps,Env,SortedOps) :- |
| 2017 | | (LocalOps = [] % there are no LOCAL_OPERATIONS |
| 2018 | | -> allow_local_or_expr_op_calls % unless call operations in machine itself, no need to perform a topological sort |
| 2019 | | ; true % we have local_operations, we need topological sort to ensure they are processed before other operations |
| 2020 | | ), |
| 2021 | | findall(OtherID-ID, (member(Op,Ops),op_calls_op(Op,Env,ID,OtherID)),Edges), |
| 2022 | | % print(edges(Edges)),nl, |
| 2023 | | % TO DO: maybe only store edges where OtherID also appears in Ops (i.e., call within same machine) |
| 2024 | | Edges \= [], |
| 2025 | | !, |
| 2026 | | findall(ID,(member(operation(_,RawID,_,_,_),Ops),raw_id(RawID,ID)),Vertices), %print(vertices(Vertices)),nl, |
| 2027 | | vertices_edges_to_ugraph(Vertices,Edges,Graph), |
| 2028 | | (top_sort(Graph,Sorted) |
| 2029 | | -> sort_ops(Sorted,Ops,SortedOps) |
| 2030 | | ; get_preference(allow_operation_calls_in_expr,true) -> |
| 2031 | | add_warning(topological_sort,'Mutual recursion or cycle in the (local) operation call graph, this may cause problems computing reads information: ',Edges), |
| 2032 | | SortedOps=Ops |
| 2033 | | % not necessarily a problem, because operations called in expressions are not allowed to modify the state |
| 2034 | | % TODO: however, we may have an issue with computing reads information correctly for mutual recursion !? |
| 2035 | | % direct recursion should be ok |
| 2036 | | ; add_error(topological_sort,'Cycle in the (local) operation call graph: ',Edges), |
| 2037 | | SortedOps=Ops). |
| 2038 | | topological_sort_operations(Ops,_,_,Ops). |
| 2039 | | |
| 2040 | | sort_ops([],Ops,Ops). % Ops should be [] |
| 2041 | | sort_ops([OpID|T],Ops,Res) :- |
| 2042 | | raw_op_id(Op1,OpID), |
| 2043 | | (select(Op1,Ops,TOps) |
| 2044 | | -> Res = [Op1|TSOps], sort_ops(T,TOps,TSOps) |
| 2045 | | ; % operation from another machine |
| 2046 | | % print(could_not_find(OpID,Ops)),nl, |
| 2047 | | sort_ops(T,Ops,Res) |
| 2048 | | ). |
| 2049 | | |
| 2050 | | is_op_type(op(_,_)). |
| 2051 | | is_pred_type(pred). |
| 2052 | | |
| 2053 | | % compute which other operations are directly called |
| 2054 | | op_calls_op(operation(_,RawID,_,_,RawBody),Env,ID,OtherID) :- raw_id(RawID,ID), |
| 2055 | | raw_body_calls_operation(RawBody,ID,Env,OtherID). |
| 2056 | | |
| 2057 | | raw_body_calls_operation(RawBody,ID,Env,OtherID) :- |
| 2058 | | raw_member(OpCall,RawBody), |
| 2059 | | raw_op_call(OpCall,ID,Env,RawOtherID), raw_id(RawOtherID,OtherID). |
| 2060 | | |
| 2061 | | raw_op_call(operation_call(_,RawOtherID,_,_),_,_, RawOtherID). |
| 2062 | | raw_op_call(operation_call_in_expr(_,RawOtherID,_),ID,_, RawOtherID) :- |
| 2063 | | \+ raw_id(RawOtherID,ID). % we do not look at direct recursion: it poses no problem for computing reads/writes info |
| 2064 | | raw_op_call(function(_,RawOtherID,_), ID, Env, RawOtherID) :- % function calls possibly not yet translated to operation_call_in_expr |
| 2065 | | get_preference(allow_operation_calls_in_expr,true), |
| 2066 | | \+ raw_id(RawOtherID,ID), % direct recursion ok |
| 2067 | | btypechecker:is_operation_call(RawOtherID,Env). |
| 2068 | | raw_op_call(identifier(Pos,OtherID), ID, Env, RawOtherID) :- % possible operation call in expr without arguments |
| 2069 | | OtherID \= ID, % direct recursion ok |
| 2070 | | get_preference(allow_operation_calls_in_expr,true), |
| 2071 | | RawOtherID = identifier(Pos,OtherID), |
| 2072 | | btypechecker:is_operation_call(RawOtherID,Env). |
| 2073 | | |
| 2074 | | |
| 2075 | | raw_op_id(operation(_,RawID,_,_,_RawBody),ID) :- raw_id(RawID,ID). |
| 2076 | | raw_id(identifier(_,ID),ID). |
| 2077 | | raw_op_pos(operation(Pos,_RawID,_,_,_RawBody),Pos). |
| 2078 | | |
| 2079 | | % a utility function to work on the raw AST Functor(POS,Arg1,...,Argn) |
| 2080 | | % this will not be able to look inside DEFINITIONS ! |
| 2081 | | % TO DO: deal with more raw substitutions which have list arguments |
| 2082 | | raw_member(X,X). |
| 2083 | | raw_member(X,parallel(_,List)) :- !, member(Term,List), raw_member(X,Term). |
| 2084 | | raw_member(X,sequence(_,List)) :- !, member(Term,List), raw_member(X,Term). |
| 2085 | | raw_member(X,[H|T]) :- !, (raw_member(X,H) ; raw_member(X,T)). |
| 2086 | | raw_member(X,Term) :- compound(Term), Term =.. [_Functor,_Pos|Args], |
| 2087 | | member(A,Args), raw_member(X,A). |
| 2088 | | |
| 2089 | | |
| 2090 | | create_section_identifiers(Section,DestSection,RawMachine,Old,New) :- |
| 2091 | | write_section(DestSection,Vars,Old,New), |
| 2092 | | optional_rawmachine_section(Section,RawMachine,[],Identifiers), |
| 2093 | | create_section_ids2(Identifiers,[],Vars,DestSection,New). |
| 2094 | | |
| 2095 | | create_section_ids2([],_,[],_,_). |
| 2096 | | create_section_ids2([Ext|Rest],Infos,Res,DestSection,MachSections) :- |
| 2097 | | expand_definition_to_variable_list(Ext,MachSections,List),!, |
| 2098 | | append(List,Rest,NewList), |
| 2099 | | create_section_ids2(NewList,Infos,Res,DestSection,MachSections). |
| 2100 | | create_section_ids2([Ext|Rest],Infos,Res,DestSection,MachSections) :- |
| 2101 | | create_section_id(Ext,Infos,DestSection,TId), |
| 2102 | | ( TId = error(Msg,Term,Pos) -> |
| 2103 | | Res = TRest, add_error(bmachine_construction,Msg,Term,Pos) |
| 2104 | | ; |
| 2105 | | Res = [TId|TRest]), |
| 2106 | | create_section_ids2(Rest,Infos,TRest,DestSection,MachSections). |
| 2107 | | create_section_id(Ext,Infos,DestSection,TId) :- |
| 2108 | | (unwrap_pragma(Ext,Ext2,PragmaInfos) -> append(PragmaInfos,Infos,FullInfos) |
| 2109 | | ; Ext2=Ext, FullInfos=Infos), |
| 2110 | | I=identifier(_), |
| 2111 | | ( ext2int(Ext2,I,_Pos,_Type,I,FullInfos,TId) -> |
| 2112 | | true |
| 2113 | | ; Ext2 = definition(POSINFO,ID,_) -> |
| 2114 | | TId = error('Trying to use DEFINITION name as identifier: ', |
| 2115 | | (ID,within(DestSection)), POSINFO) |
| 2116 | | ; |
| 2117 | | TId = error('Illegal identifier: ', |
| 2118 | | (Ext2,within(DestSection)), Ext2) |
| 2119 | | ). |
| 2120 | | |
| 2121 | | % support using DEFINITIONS which are variable lists; |
| 2122 | | % currently for ProB parser you need to write VARS == (x,y,..) for Atelier-B: VARS == x,y,.. |
| 2123 | | expand_definition_to_variable_list(definition(_POSINFO,ID,_),MachSections,List) :- |
| 2124 | | get_section(definitions,MachSections,Defs), |
| 2125 | | member(definition_decl(ID,expression,_InnerPos,[],RawExpr,_Deps),Defs), |
| 2126 | | extract_identifier_list(RawExpr,List,[]). |
| 2127 | | |
| 2128 | | % convert a raw tuple into a raw identifier list: |
| 2129 | | extract_identifier_list(identifier(Pos,ID)) --> [identifier(Pos,ID)]. |
| 2130 | | extract_identifier_list(couple(_,List)) --> |
| 2131 | | extract_identifier_list(List). |
| 2132 | | extract_identifier_list([]) --> []. |
| 2133 | | extract_identifier_list([H|T]) --> extract_identifier_list(H), extract_identifier_list(T). |
| 2134 | | |
| 2135 | | |
| 2136 | | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% |
| 2137 | | % sort the machines topologically |
| 2138 | | |
| 2139 | | % can be used to store the result: |
| 2140 | | assert_machine_order(Order) :- |
| 2141 | | retractall(machine_global_order(_)), |
| 2142 | | debug_print(9,machine_global_order(Order)), |
| 2143 | | assertz(machine_global_order(Order)). |
| 2144 | | |
| 2145 | | get_mach_position(Order,M,Ref,Pos-mch(M,Ref)) :- |
| 2146 | | get_machine_name(M,Name), |
| 2147 | ? | (nth1(Pos,Order,Name) -> true |
| 2148 | | ; add_internal_error('Unknown machine:',Name:Order), |
| 2149 | | Pos=0). |
| 2150 | | get_machine(_-mch(M,_),M). % re-extract info after sorting |
| 2151 | | get_reference(_-mch(_,R),R). |
| 2152 | | |
| 2153 | | :- use_module(library(samsort),[samkeysort/2]). |
| 2154 | | sort_machines_by_global_order(Machines,SortedMachines) :- |
| 2155 | | sort_machines_by_global_order(Machines,_,SortedMachines,_). |
| 2156 | | sort_machines_by_global_order(Machines,Refs,SortedMachines,SortedRefs) :- |
| 2157 | | machine_global_order(Order), |
| 2158 | | maplist(get_mach_position(Order),Machines,Refs,KM), % add position so that sorting works |
| 2159 | | samkeysort(KM,SKM), % for test 925 it is important to keep duplicates and not use sort/2 |
| 2160 | | maplist(get_machine,SKM,SortedMachines), |
| 2161 | | maplist(get_reference,SKM,SortedRefs),!. |
| 2162 | | %maplist(get_machine_name,Sorted,SNs),print(sorted(SNs)),nl. |
| 2163 | | sort_machines_by_global_order(M,R,M,R) :- |
| 2164 | | add_internal_error('Sorting machines failed:',M). |
| 2165 | | |
| 2166 | | % perform the actual computation: |
| 2167 | | machine_order(Machines,Order) :- |
| 2168 | | machine_dependencies(Machines,Dependencies), |
| 2169 | | topsort(Dependencies,Order). |
| 2170 | | |
| 2171 | | % sort the machines topologically |
| 2172 | | topsort(Deps,Sorted) :- |
| 2173 | | topsort2(Deps,[],Sorted). |
| 2174 | | topsort2([],_,[]) :- !. |
| 2175 | | topsort2(Deps,Known,Sorted) :- |
| 2176 | | split_list(all_deps_known(Known),Deps,DAvailable,DNotAvailable), |
| 2177 | | DAvailable = [_|_], % we have new machines available whose dependencies are all known |
| 2178 | | !, |
| 2179 | | maplist(dep_name,DAvailable,Available), |
| 2180 | | append(Available,Known,NewKnown), |
| 2181 | | append(Available,Rest,Sorted), |
| 2182 | | topsort2(DNotAvailable,NewKnown,Rest). |
| 2183 | | topsort2(Deps,_Known,_) :- |
| 2184 | | member(dep(Name,NameDeps),Deps), |
| 2185 | | add_error(bmachine_construction,'Could not resolve machine dependencies for: ',Name:depends_on(NameDeps)), |
| 2186 | | fail. |
| 2187 | | |
| 2188 | ? | all_deps_known(K,dep(_Name,Deps)) :- sort(Deps,DS),sort(K,KS),subseq0(KS,DS),!. |
| 2189 | | dep_name(dep(Name,_Deps),Name). |
| 2190 | | |
| 2191 | | % find dependencies between machines |
| 2192 | | machine_dependencies(Machines,Dependencies) :- |
| 2193 | | maplist(machine_dependencies2,Machines,Deps), |
| 2194 | | sort(Deps,Dependencies). |
| 2195 | | machine_dependencies2(M,dep(Name,Deps)) :- |
| 2196 | | get_constructed_machine_name_and_body(M,Name,_,Body), |
| 2197 | | findall(Ref, |
| 2198 | | (refines(M,Ref);machine_reference(Body,Ref)), |
| 2199 | | Deps). |
| 2200 | | |
| 2201 | | machine_reference(MachineBody,Ref) :- |
| 2202 | ? | ( member(sees(_,R),MachineBody) |
| 2203 | | ; member(uses(_,R),MachineBody) ), |
| 2204 | ? | member(identifier(_,PrefixRef),R), |
| 2205 | | split_prefix(PrefixRef,_,Ref). |
| 2206 | | machine_reference(MachineBody,Ref) :- |
| 2207 | | ( member(includes(_,R),MachineBody) |
| 2208 | ? | ; member(extends(_,R),MachineBody) |
| 2209 | | ; member(imports(_,R),MachineBody) ), |
| 2210 | ? | member(machine_reference(_,PrefixRef,_),R), |
| 2211 | | split_prefix(PrefixRef,_,Ref). |
| 2212 | | |
| 2213 | | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% |
| 2214 | | % refinements |
| 2215 | | merge_refinement_and_abstraction(Name,Concrete,RefMachines,Result,Ein,Eout) :- |
| 2216 | | memberchk(ref(abstraction,Abstraction),RefMachines), |
| 2217 | | append_sections([sets,concrete_constants,concrete_variables],Abstraction,Concrete,M1), |
| 2218 | | append_if_new(abstract_constants,Abstraction,M1,M2), |
| 2219 | | get_section(properties,Abstraction,AbstractProperties), |
| 2220 | | conjunct_to_section(properties,AbstractProperties,M2,M3), |
| 2221 | | % now get current invariant Invariant and filter out gluing/linking invariant |
| 2222 | | % (the linking invariant talks about variables which no longer exist; hence we cannot check it anymore) |
| 2223 | | select_section(invariant,Invariant,FullConcreteInvariant,M3,M4), |
| 2224 | | write_section(linking_invariant,LinkingInvariant,M4,Merged), |
| 2225 | | % we now also copy from the abstraction those invariants which are still valid |
| 2226 | | get_machine_sorted_variables(Abstraction,SortedAbsVars), |
| 2227 | | get_machine_sorted_variables(Concrete,SortedConcrVars), |
| 2228 | | assert_removed_abs_vars(SortedAbsVars,SortedConcrVars,Name), |
| 2229 | | get_section(invariant,Abstraction,AbstractInvariant), |
| 2230 | | filter_abstract_invariant(AbstractInvariant,SortedConcrVars,AbsInvariantStillValid), |
| 2231 | | filter_linking_invariant(Invariant,LinkingInvariant,ConcreteInvariant), |
| 2232 | | conjunct_predicates([AbsInvariantStillValid,ConcreteInvariant],FullConcreteInvariant), |
| 2233 | | propagate_abstract_operations(Abstraction,Merged,RefMachines,Result,Ein,Eout). |
| 2234 | | merge_refinement_and_abstraction(_,Machine,_,Machine,Errors,Errors). |
| 2235 | | |
| 2236 | | :- use_module(probsrc(bsyntaxtree), [same_id/3]). |
| 2237 | | assert_removed_abs_vars([],_,_). |
| 2238 | | assert_removed_abs_vars([TID1|H],[],Name) :- !, |
| 2239 | | assert_abstract_variable_removed_in(Name,TID1), |
| 2240 | | assert_removed_abs_vars(H,[],Name). |
| 2241 | | assert_removed_abs_vars([TID1|T1],[TID2|T2],Name) :- same_id(TID1,TID2,_),!, |
| 2242 | | assert_removed_abs_vars(T1,T2,Name). |
| 2243 | | assert_removed_abs_vars([TID1|T1],[TID2|T2],Name) :- TID1 @< TID2,!, |
| 2244 | | assert_abstract_variable_removed_in(Name,TID1), |
| 2245 | | assert_removed_abs_vars(T1,[TID2|T2],Name). |
| 2246 | | assert_removed_abs_vars([TID1|T1],[_|T2],Name) :- % TID2 added in Name |
| 2247 | | assert_removed_abs_vars([TID1|T1],T2,Name). |
| 2248 | | |
| 2249 | | |
| 2250 | | assert_abstract_variable_removed_in(Name,TID) :- |
| 2251 | | get_texpr_id(TID,ID), |
| 2252 | | ajoin(['Variable ',ID,' removed in refinement machine: '],Msg), |
| 2253 | | add_debug_message(bmachine_construction,Msg,Name,TID), |
| 2254 | | assertz(abstract_variable_removed_in(ID,Name,TID)). |
| 2255 | | |
| 2256 | | |
| 2257 | | % append sections from abstract machine to concrete machine: |
| 2258 | | append_sections(Sections,AbsMachine,Old,New) :- |
| 2259 | | expand_shortcuts(Sections,AllSections), |
| 2260 | | append_sections2(AllSections,AbsMachine,Old,New). |
| 2261 | | append_sections2([],_,M,M). |
| 2262 | | append_sections2([Section|Rest],AbsMachine,Old,New) :- |
| 2263 | | get_section(Section,AbsMachine,Content), |
| 2264 | | append_to_section3(Section,Content,Old,Inter), |
| 2265 | | append_sections2(Rest,AbsMachine,Inter,New). |
| 2266 | | |
| 2267 | | append_to_section3(Section,Content,Old,Inter) :- section_can_have_duplicates(Section),!, |
| 2268 | | append_to_section_and_remove_dups(Section,Content,Old,Inter). |
| 2269 | | append_to_section3(Section,Content,Old,Inter) :- append_to_section(Section,Content,Old,Inter). |
| 2270 | | |
| 2271 | | :- assert_must_succeed((create_machine(abs,EA), create_machine(conc,EB), |
| 2272 | | write_section(abstract_constants,[b(identifier(x),integer,[some_info])],EA,A), |
| 2273 | | write_section(abstract_constants,[b(identifier(x),integer,[other_info]), |
| 2274 | | b(identifier(y),integer,[info])],EB,B), |
| 2275 | | append_if_new(abstract_constants,A,B,ResultM), |
| 2276 | | get_section(abstract_constants,ResultM,ResultConst), |
| 2277 | | ResultConst==[b(identifier(x),integer,[other_info]), |
| 2278 | | b(identifier(y),integer,[info])] |
| 2279 | | )). |
| 2280 | | |
| 2281 | | append_if_new(Section,Machine,In,Out) :- |
| 2282 | | get_section(Section,Machine,Content), |
| 2283 | | select_section(Section,Old,New,In,Out), |
| 2284 | | get_texpr_ids(Old,ExistingIds), |
| 2285 | | exclude(is_in_existing_ids(ExistingIds),Content,NewElements), |
| 2286 | | append(Old,NewElements,New). |
| 2287 | | is_in_existing_ids(ExistingIds,TId) :- |
| 2288 | | get_texpr_id(TId,Id), |
| 2289 | | memberchk(Id,ExistingIds). |
| 2290 | | |
| 2291 | | % filter linking and concrete invariant |
| 2292 | | filter_linking_invariant(Invariant,Linking,Concrete) :- |
| 2293 | | split_conjuncts(Invariant,Predicates), |
| 2294 | | split_list(contains_abstraction_refs,Predicates,Linkings,Concretes), |
| 2295 | | conjunct_predicates(Linkings,Linking), |
| 2296 | | conjunct_predicates(Concretes,Concrete). |
| 2297 | | |
| 2298 | | |
| 2299 | | % contains_abstraction_refs can be used on predicates of the current machine: the abstraction info field has been computed for this machine |
| 2300 | | contains_abstraction_refs(TExpr) :- |
| 2301 | | syntaxtraversion(TExpr,_,_,Infos,Subs,_), |
| 2302 | | ( memberchk(abstraction,Infos) % This info field comes from the last argument of visibility/6 |
| 2303 | | -> true |
| 2304 | | ; member(Sub,Subs), |
| 2305 | | contains_abstraction_refs(Sub)). |
| 2306 | | |
| 2307 | | % Determine which part of the abstract invariant can be imported into the refinement machine |
| 2308 | | % TODO: should this be applied to WHILE loop INVARIANTS? |
| 2309 | | filter_abstract_invariant(AbsInvariant,SortedConcrVars,ConcreteInv) :- |
| 2310 | | split_conjuncts(AbsInvariant,Predicates), |
| 2311 | | filter_abs_invs(Predicates,SortedConcrVars,Concretes), |
| 2312 | | conjunct_predicates(Concretes,ConcreteInv). %, print('COPY: '), translate:print_bexpr(Concrete),nl. |
| 2313 | | :- use_module(translate,[translate_bexpression/2]). |
| 2314 | | |
| 2315 | | filter_abs_invs([],_,[]). |
| 2316 | | filter_abs_invs([TExpr|TInv],SortedConcrVars,Res) :- |
| 2317 | | contains_abstract_variables2(SortedConcrVars,TExpr,Cause),!, |
| 2318 | | (silent_mode(on) -> true |
| 2319 | | ; translate_bexpression(Cause,ID), |
| 2320 | | ajoin(['Discarding abstract INVARIANT (requires variable `',ID,'`): '],Msg), |
| 2321 | | add_message(bmachine_construction,Msg,TExpr,Cause) |
| 2322 | | ), |
| 2323 | | (adapt_invariant(SortedConcrVars,TExpr,NewTExpr) |
| 2324 | | -> Res = [NewTExpr|TRes], |
| 2325 | | add_message(bmachine_construction,'Replaced abstract INVARIANT by: ',NewTExpr,Cause) |
| 2326 | | ; Res=TRes |
| 2327 | | ), |
| 2328 | | filter_abs_invs(TInv,SortedConcrVars,TRes). |
| 2329 | | filter_abs_invs([TExpr|TInv],SortedConcrVars,[TExpr|TRes]) :- |
| 2330 | | filter_abs_invs(TInv,SortedConcrVars,TRes). |
| 2331 | | |
| 2332 | | contains_abstract_variables2(SortedConcrVars,TExpr,Cause) :- |
| 2333 | | syntaxtraversion(TExpr,Expr,Type,Infos,Subs,_), |
| 2334 | | ( memberchk(loc(_,_Mch,abstract_variables),Infos) % are there other things that pose problems: abstract_constants ? |
| 2335 | | -> %print('Abs: '),translate:print_bexpr(TExpr),nl, print(SortedConcrVars),nl, |
| 2336 | | Cause=TExpr, |
| 2337 | | \+ ord_member_nonvar_chk(b(Expr,Type,_),SortedConcrVars) % otherwise variable is re-introduced with same type |
| 2338 | | % in some Event-B models: VARIABLES keyword is used and in refinement VARIABLES are re-listed |
| 2339 | | % TO DO: check what happens when variable not immediately re-introduced |
| 2340 | | ; member(Sub,Subs), |
| 2341 | | contains_abstract_variables2(SortedConcrVars,Sub,Cause) |
| 2342 | | ). |
| 2343 | | |
| 2344 | | % try and keep part of invariant, e.g., if f:ABS-->Ran translate to f: TYPE +-> Ran |
| 2345 | | adapt_invariant(SortedConcrVars,b(member(LHS,RHS),pred,I),b(member(LHS,NewRHS),pred,I)) :- |
| 2346 | | \+ contains_abstract_variables2(SortedConcrVars,LHS,_), |
| 2347 | | adapt_to_concrete_superset(RHS,SortedConcrVars,NewRHS), |
| 2348 | | \+ get_texpr_expr(NewRHS,typeset). % not really useful |
| 2349 | | |
| 2350 | | adapt_to_concrete_superset(b(E,Type,Info),SortedConcrVars,b(NewE,Type,Info)) :- |
| 2351 | | adapt_super2(E,SortedConcrVars,NewE). % TODO: adapt info fields? |
| 2352 | | adapt_to_concrete_superset(b(_E,Type,_Info),_SortedConcrVars,b(typeset,Type,[])). |
| 2353 | | % Range of function remains concrete, Domain is abstract and no longer available: |
| 2354 | | adapt_super2(PFUN,SortedConcrVars,partial_function(NewDom,RAN)) :- |
| 2355 | | is_fun(PFUN,partial,DOM,RAN), |
| 2356 | | \+ contains_abstract_variables2(SortedConcrVars,RAN,_), |
| 2357 | | adapt_to_concrete_superset(DOM,SortedConcrVars,NewDom). |
| 2358 | | adapt_super2(TFUN,SortedConcrVars,partial_function(NewDom,RAN)) :- |
| 2359 | | is_fun(TFUN,total,DOM,RAN), |
| 2360 | | \+ contains_abstract_variables2(SortedConcrVars,RAN,_), |
| 2361 | | adapt_to_concrete_superset(DOM,SortedConcrVars,NewDom). |
| 2362 | | % Domain of function remains concrete, Range is abstract and no longer available: |
| 2363 | | adapt_super2(PFUN,SortedConcrVars,partial_function(DOM,NewRan)) :- |
| 2364 | | is_fun(PFUN,partial,DOM,RAN), |
| 2365 | | \+ contains_abstract_variables2(SortedConcrVars,DOM,_), |
| 2366 | | adapt_to_concrete_superset(RAN,SortedConcrVars,NewRan). |
| 2367 | | adapt_super2(TFUN,SortedConcrVars,total_function(DOM,NewRan)) :- |
| 2368 | | is_fun(TFUN,total,DOM,RAN), |
| 2369 | | \+ contains_abstract_variables2(SortedConcrVars,DOM,_), |
| 2370 | | adapt_to_concrete_superset(RAN,SortedConcrVars,NewRan). |
| 2371 | | adapt_super2(FUN,SortedConcrVars,partial_function(NewDom,NewRan)) :- |
| 2372 | | is_fun(FUN,_,DOM,RAN), |
| 2373 | | adapt_to_concrete_superset(DOM,SortedConcrVars,NewDom), |
| 2374 | | adapt_to_concrete_superset(RAN,SortedConcrVars,NewRan). |
| 2375 | | % TODO: more cases, intersection(ABS,CONCR) -> CONCR, cartesian_product |
| 2376 | | |
| 2377 | | is_fun(partial_function(DOM,RAN),partial,DOM,RAN). |
| 2378 | | is_fun(partial_injection(DOM,RAN),partial,DOM,RAN). |
| 2379 | | is_fun(partial_surjection(DOM,RAN),partial,DOM,RAN). |
| 2380 | | is_fun(partial_bijection(DOM,RAN),partial,DOM,RAN). |
| 2381 | | is_fun(total_function(DOM,RAN),total,DOM,RAN). |
| 2382 | | is_fun(total_injection(DOM,RAN),total,DOM,RAN). |
| 2383 | | is_fun(total_surjection(DOM,RAN),total,DOM,RAN). |
| 2384 | | is_fun(total_bijection(DOM,RAN),total,DOM,RAN). |
| 2385 | | |
| 2386 | | % --------------------- |
| 2387 | | |
| 2388 | | get_machine_sorted_variables(Machine,SortedAllVars) :- |
| 2389 | | get_section(abstract_variables,Machine,AbsVars), |
| 2390 | | get_section(concrete_variables,Machine,ConcVars), |
| 2391 | | append(ConcVars,AbsVars,AllVars), |
| 2392 | | sort(AllVars,SortedAllVars). |
| 2393 | | |
| 2394 | | split_conjuncts(Expr,List) :- |
| 2395 | | split_conjuncts2(Expr,List,[]). |
| 2396 | | split_conjuncts2(Expr) --> |
| 2397 | | {get_texpr_expr(Expr,conjunct(A,B)),!}, |
| 2398 | | split_conjuncts2(A), |
| 2399 | | split_conjuncts2(B). |
| 2400 | | split_conjuncts2(Expr) --> [Expr]. |
| 2401 | | |
| 2402 | | % copy the abstract operations or re-use their preconditions |
| 2403 | | % TODO: think about copying Initialisation? |
| 2404 | | propagate_abstract_operations(Abstract,Concrete,RefMachines,Result,Ein,Eout) :- |
| 2405 | | get_section(promoted,Abstract,APromoted), |
| 2406 | | get_section(operation_bodies,Abstract,ABodies), |
| 2407 | | % signature: select_section(SecName,OldContent,NewContent,OldMachine,NewMachine) |
| 2408 | | select_section(promoted,CPromotedIn,CPromotedOut,Concrete,Concrete2), |
| 2409 | | select_section(operation_bodies,CBodiesIn,CBodiesOut,Concrete2,Result), |
| 2410 | | propagate_aops(APromoted,ABodies,RefMachines,CPromotedIn,CBodiesIn,CPromotedOut,CBodiesOut,Ein,Eout). |
| 2411 | | propagate_aops([],_ABodies,_RefMachines,CPromoted,CBodies,CPromoted,CBodies,Errors,Errors). |
| 2412 | | propagate_aops([APromoted|ApRest],ABodies,RefMachines,CPromotedIn,CBodiesIn,CPromotedOut,CBodiesOut,Ein,Eout) :- |
| 2413 | | get_operation(APromoted,ABodies,AbstractOp), |
| 2414 | | def_get_texpr_id(APromoted,op(APromotedOpName)), |
| 2415 | | copy_texpr_wo_info(APromoted,CProm), |
| 2416 | | ( member(CProm,CPromotedIn) -> |
| 2417 | | debug_format(19,'Refining promoted abstract operation ~w to refinement machine.~n',[APromotedOpName]), |
| 2418 | | extract_concrete_preconditions(AbstractOp,RefMachines,Pre), |
| 2419 | | change_operation(APromoted,ConcreteOpOld,ConcreteOpNew,CBodiesIn,CBodiesRest), |
| 2420 | | add_precondition(Pre,ConcreteOpOld,ConcreteOpNew), % propagate PRE down to concrete operation |
| 2421 | | CPromotedIn = CPromotedRest, |
| 2422 | | Ein = E1 |
| 2423 | | % TO DO: do not copy if event is refined at least once with renaming ! |
| 2424 | | ; is_refined_by_some_event(APromotedOpName,CPromotedIn,ConcreteOpName) -> |
| 2425 | | debug_format(19,'Not copying abstract operation ~w to refinement machine, as it is refined by ~w.~n',[APromotedOpName,ConcreteOpName]), |
| 2426 | | CPromotedRest=CPromotedIn, CBodiesRest=CBodiesIn, |
| 2427 | | E1=Ein |
| 2428 | | ; |
| 2429 | | debug_format(19,'Copying abstract operation ~w to refinement machine, as it is not refined.~n',[APromotedOpName]), |
| 2430 | | % TO DO: check that this is also the right thing to do for Atelier-B Event-B |
| 2431 | | % TO DO: check that the variables are also still there |
| 2432 | | check_copied_operation(APromoted,AbstractOp,RefMachines,Ein,E1), |
| 2433 | | append(CPromotedIn,[APromoted],CPromotedRest), |
| 2434 | | append(CBodiesIn,[AbstractOp],CBodiesRest) |
| 2435 | | ), |
| 2436 | | propagate_aops(ApRest,ABodies,RefMachines,CPromotedRest,CBodiesRest,CPromotedOut,CBodiesOut,E1,Eout). |
| 2437 | | |
| 2438 | | is_refined_by_some_event(AbstractName,CPromotedList,ConcreteName) :- |
| 2439 | | member(TID,CPromotedList), |
| 2440 | | get_texpr_info(TID,Infos), |
| 2441 | | memberchk(refines_operation(AbstractName),Infos), |
| 2442 | | def_get_texpr_id(TID,ConcreteName). |
| 2443 | | |
| 2444 | | get_operation(TId,Bodies,Operation) :- |
| 2445 | | select_operation(TId,Bodies,Operation,_BodiesRest). |
| 2446 | | change_operation(TId,OldOp,NewOp,OldBodies,[NewOp|NewBodies]) :- |
| 2447 | | select_operation(TId,OldBodies,OldOp,NewBodies). |
| 2448 | | select_operation(TId,Bodies,Operation,BodiesRest) :- |
| 2449 | | copy_texpr_wo_info(TId,OpId), |
| 2450 | | get_texpr_expr(Operation,operation(OpId,_,_,_)), |
| 2451 | | select(Operation,Bodies,BodiesRest),!. |
| 2452 | | |
| 2453 | | extract_concrete_preconditions(Op,RefMachines,FPre) :- |
| 2454 | | extract_preconditions_op(Op,Pre), |
| 2455 | | extract_op_arguments(Op,Args), |
| 2456 | | conjunction_to_list(Pre,Pres), |
| 2457 | | % todo: check the "machine" parameter |
| 2458 | | visible_env(machine,operation_bodies,RefMachines,Env1,_Errors,[]), |
| 2459 | | store_variables(Args,Env1,Env), |
| 2460 | | filter_predicates_with_unknown_identifiers(Pres,Env,FPres), |
| 2461 | | conjunct_predicates(FPres,FPre). |
| 2462 | | |
| 2463 | | extract_op_arguments(Op,Params) :- |
| 2464 | | get_texpr_expr(Op,operation(_,_,Params,_)). |
| 2465 | | |
| 2466 | | extract_preconditions_op(OpExpr,Pre) :- |
| 2467 | | get_texpr_expr(OpExpr,operation(_,_,_,Subst)), |
| 2468 | | extract_preconditions(Subst,Pres,_), |
| 2469 | | conjunct_predicates(Pres,Pre). |
| 2470 | | extract_preconditions(TExpr,Pres,Inner) :- |
| 2471 | | get_texpr_expr(TExpr,Expr), |
| 2472 | | extract_preconditions2(Expr,TExpr,Pres,Inner). |
| 2473 | | extract_preconditions2(precondition(Pre,Subst),_,[Pre|Pres],Inner) :- !, |
| 2474 | | extract_preconditions(Subst,Pres,Inner). |
| 2475 | | extract_preconditions2(block(Subst),_,Pres,Inner) :- !, |
| 2476 | | extract_preconditions(Subst,Pres,Inner). |
| 2477 | | extract_preconditions2(_,Inner,[],Inner). |
| 2478 | | |
| 2479 | | :- use_module(btypechecker,[prime_atom0/2]). |
| 2480 | | filter_predicates_with_unknown_identifiers([],_Env,[]). |
| 2481 | | filter_predicates_with_unknown_identifiers([Pred|Prest],Env,Result) :- |
| 2482 | | ( find_unknown_identifier(Pred,Env,_Id) -> |
| 2483 | | !,Result = Rrest |
| 2484 | | ; |
| 2485 | | Result = [Pred|Rrest]), |
| 2486 | | filter_predicates_with_unknown_identifiers(Prest,Env,Rrest). |
| 2487 | | find_unknown_identifier(Pred,Env,Id) :- |
| 2488 | | get_texpr_id(Pred,Id),!, |
| 2489 | | \+ env_lookup_type(Id,Env,_), |
| 2490 | | (atom(Id),prime_atom0(UnprimedId,Id) |
| 2491 | | -> % we have an identifier with $0 at end |
| 2492 | | \+ env_lookup_type(UnprimedId,Env,_) % check unprimed identifier also unknown |
| 2493 | | ; true). |
| 2494 | | find_unknown_identifier(Pred,Env,Id) :- |
| 2495 | | syntaxtraversion(Pred,_,_,_,Subs,Names), |
| 2496 | | store_variables(Names,Env,Subenv), |
| 2497 | | find_unknown_identifier_l(Subs,Subenv,Id). |
| 2498 | | find_unknown_identifier_l([S|_],Env,Id) :- |
| 2499 | | find_unknown_identifier(S,Env,Id),!. |
| 2500 | | find_unknown_identifier_l([_|Rest],Env,Id) :- |
| 2501 | | find_unknown_identifier_l(Rest,Env,Id). |
| 2502 | | |
| 2503 | | :- use_module(library(ordsets),[ord_union/3]). |
| 2504 | | % we add a precondition to an existing operation |
| 2505 | | % Note: we need to update the reads info computed by the type checker (compute_accessed_vars_infos_for_operation) |
| 2506 | | add_precondition(b(truth,_,_),Old,New) :- !, Old=New. |
| 2507 | | add_precondition(Pre,b(Old,T,I),b(New,T,I2)) :- |
| 2508 | | Old=operation(Id,Res,Params,Subst), |
| 2509 | | New=operation(Id,Res,Params,NewSubst), |
| 2510 | | extract_preconditions(Subst,OldPres,Inner), |
| 2511 | | conjunct_predicates([Pre|OldPres],NewPre), |
| 2512 | | create_texpr(precondition(NewPre,Inner),subst,[],NewSubst), |
| 2513 | | (select(reads(OldReads),I,I1) % we do not have to update modifies(.), non_det_modifies(.), reads_locals(.),... |
| 2514 | | -> I2=[reads(NewReads)|I1], |
| 2515 | | get_texpr_ids(Params,Ignore), |
| 2516 | | find_identifier_uses(Pre,Ignore,PreUsedIds), |
| 2517 | | ord_union(PreUsedIds,OldReads,NewReads) |
| 2518 | | ; add_internal_error('No reads info for operation: ',add_precondition(Pre,b(Old,T,I),b(New,T,I2))), |
| 2519 | | I2=I). |
| 2520 | | |
| 2521 | | |
| 2522 | | |
| 2523 | | check_copied_operation(OpRef,Op,RefMachines,Ein,Eout) :- |
| 2524 | | % todo: check the "refinement" parameter |
| 2525 | | visible_env(refinement,operation_bodies,RefMachines,Env1,_Errors,[]), |
| 2526 | | get_texpr_id(OpRef,OpId),get_texpr_type(OpRef,OpType), |
| 2527 | | env_store(OpId,OpType,[],Env1,Env), |
| 2528 | | findall(U, find_unknown_identifier(Op,Env,U), Unknown1), |
| 2529 | | ( Unknown1=[] -> Ein=Eout |
| 2530 | | ; |
| 2531 | | sort(Unknown1,Unknown), |
| 2532 | | op(OpName) = OpId, |
| 2533 | | join_ids(Unknown,IdList), |
| 2534 | | (Unknown = [_] -> Plural=[]; Plural=['s']), |
| 2535 | | append([['Operation ',OpName, |
| 2536 | | ' was copied from abstract machine but the identifier'], |
| 2537 | | Plural, |
| 2538 | | [' '], |
| 2539 | | IdList, |
| 2540 | | [' cannot be seen anymore']],Msgs), |
| 2541 | | ajoin(Msgs,Msg), Ein = [error(Msg,none)|Eout] |
| 2542 | | ). |
| 2543 | | join_ids([I],[Msg]) :- !,opname(I,Msg). |
| 2544 | | join_ids([A|Rest],[Msg,','|Mrest]) :- opname(A,Msg),join_ids(Rest,Mrest). |
| 2545 | | opname(op(Id),Id) :- !. |
| 2546 | | opname(Id,Id). |
| 2547 | | |
| 2548 | | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% |
| 2549 | | % split an identifier into a (possible empty) prefix and the name itself |
| 2550 | | % e.g. split_prefix('path.to.machine', 'path.to', 'machine'). |
| 2551 | | split_prefix(Term,Prefix,Main) :- |
| 2552 | | one_arg_term(Functor,Arg,Term),!, |
| 2553 | | one_arg_term(Functor,MArg,Main), |
| 2554 | | split_prefix(Arg,Prefix,MArg). |
| 2555 | | split_prefix(PR,Prefix,Main) :- |
| 2556 | | safe_atom_chars(PR,Chars,split_prefix1), |
| 2557 | | split_prefix2(Chars,Chars,[],CPrefix,CMain), |
| 2558 | | safe_atom_chars(Main,CMain,split_prefix2), |
| 2559 | | safe_atom_chars(Prefix,CPrefix,split_prefix3). |
| 2560 | | split_prefix2([],Main,_,[],Main). |
| 2561 | | split_prefix2([C|Rest],Previous,PrefBefore,Prefix,Main) :- |
| 2562 | | ( C='.' -> |
| 2563 | | append(PrefBefore,RestPrefix,Prefix), |
| 2564 | | split_prefix2(Rest,Rest,[C],RestPrefix,Main) |
| 2565 | | ; |
| 2566 | | append(PrefBefore,[C],NextPref), |
| 2567 | | split_prefix2(Rest,Previous,NextPref,Prefix,Main)). |
| 2568 | | |
| 2569 | | rawmachine_section(Elem,List,Result) :- |
| 2570 | | rawmachine_section_with_opt_desc(Elem,List,Result,_,_). |
| 2571 | | |
| 2572 | | |
| 2573 | | rawmachine_section_with_opt_desc(Elem,List,Result,Desc,Pos) :- section_can_have_description_pragma(Elem), |
| 2574 | | functor(Pattern,Elem,2), |
| 2575 | | arg(2,Pattern,Result), |
| 2576 | | select(description_machine_clause(Pos,DescText,Pattern),List,_),!, |
| 2577 | | (DescText = description_text(_Pos,Desc) -> true ; Desc='?illegal_desc?'). |
| 2578 | | rawmachine_section_with_opt_desc(Elem,List,Result,'',unknown) :- |
| 2579 | | functor(Pattern,Elem,2), |
| 2580 | | arg(2,Pattern,Result), |
| 2581 | ? | select(Pattern,List,Rest),!, |
| 2582 | | (functor(Pattern2,Elem,2),member(Pattern2,Rest) |
| 2583 | | -> arg(1,Pattern2,Pos), |
| 2584 | | add_error(bmachine_construction,'Multiple sections for: ',Elem,Pos) |
| 2585 | | ; true). |
| 2586 | | |
| 2587 | | |
| 2588 | | section_can_have_description_pragma(initialisation). |
| 2589 | | |
| 2590 | | optional_rawmachine_section(Elem,RawMachineSecList,Default,Result) :- |
| 2591 | | ( rawmachine_section(Elem,RawMachineSecList,Result1) -> Result=Result1 |
| 2592 | | ; Result=Default). |
| 2593 | | |
| 2594 | | % get result from multiple sections and merge |
| 2595 | | optional_rawmachine_sections([],_RawMachineSecList,Acc,Acc). |
| 2596 | | optional_rawmachine_sections([Elem|T],RawMachineSecList,Acc,Result) :- |
| 2597 | | ( rawmachine_section(Elem,RawMachineSecList,Result1) |
| 2598 | | -> clever_append(Result1,Acc,Acc2) |
| 2599 | | ; Acc2=Acc), |
| 2600 | | optional_rawmachine_sections(T,RawMachineSecList,Acc2,Result). |
| 2601 | | |
| 2602 | | clever_append([],Y,R) :- !, R=Y. |
| 2603 | | clever_append(X,Y,R) :- X \= [_|_],!, % can happen for old parser for EXPRESSIONS/PREDICATES |
| 2604 | | add_error(bmachine_construction,'Illegal section format (update parser?): ',X), R=Y. |
| 2605 | | clever_append(X,[],R) :- !, R=X. |
| 2606 | | clever_append(X,Y,R) :- append(X,Y,R). |
| 2607 | | |
| 2608 | | one_arg_term(Functor,Arg,Term) :- %print(one_arg_term(Functor,Arg,Term)),nl, |
| 2609 | | functor(Term,Functor,1),arg(1,Term,Arg). |
| 2610 | | |
| 2611 | | % check if a rawmachine section list has a given section |
| 2612 | | rawmachine_section_exists(Elem,List) :- % |
| 2613 | | functor(Pattern,Elem,2), |
| 2614 | ? | (member(Pattern,List) -> true). |
| 2615 | | |
| 2616 | | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% |
| 2617 | | % visibility rules |
| 2618 | | |
| 2619 | | % the visibility/5 predicate declares what a part of a machine can see |
| 2620 | | % visibility(MType, Scope, Section, Access, Info) means: |
| 2621 | | % In a machine of type MType (machine, refinement, implementation), |
| 2622 | | % an expression in a Section (like invariant) can see |
| 2623 | | % the identifiers in the Access sections. Access is a list of |
| 2624 | | % sections, where shortcuts are allowed (see shortcut/2, e.g., shortcut(operations,[unpromoted,promoted]).). |
| 2625 | | % Scope defines where (in relation to the Section) |
| 2626 | | % the section in Access are (local: same machine, included: in an |
| 2627 | | % included machine, etc.) |
| 2628 | | % Info is a list of additional information that is added to each |
| 2629 | | % identifier in the environment to build up. E.g. in an operation |
| 2630 | | % definition, constants are marked readonly. |
| 2631 | | visibility(machine, local, constraints, [parameters],[]). |
| 2632 | | visibility(machine, local, includes, [parameters,sets,constants],[]). |
| 2633 | | visibility(machine, local, properties, [sets,constants],[]). |
| 2634 | | visibility(machine, local, invariant, [parameters,sets,constants,variables],[]). |
| 2635 | | visibility(machine, local, operation_bodies, [parameters,sets,constants],[readonly]). |
| 2636 | | visibility(machine, local, operation_bodies, [operations],Info) :- Info =[readonly,dontcall]. |
| 2637 | | % an operation to be readonly: means we cannot assign to it; but the operation itself can change variables |
| 2638 | | % for allow_operation_calls_in_expr=true we check that operation is inquiry in type checker |
| 2639 | | % (get_preference(allow_operation_calls_in_expr,true) -> Info = [inquiry] |
| 2640 | | % ; Info =[readonly,dontcall] ). % we check in btype(operation_call_in_expr) |
| 2641 | | visibility(machine, local, operation_bodies, [variables],[]). |
| 2642 | ? | visibility(machine, local, initialisation, Access,[not_initialised|Info]) :- visibility(machine,local,operation_bodies,Access,Info). |
| 2643 | | |
| 2644 | | visibility(machine, Scope, assertions, [Allow],[inquiry|DC]) :- |
| 2645 | | (Scope = local -> Allow=operations, DC=[dontcall] ; Allow=promoted, DC=[]), |
| 2646 | | get_preference(allow_operation_calls_in_expr,true). % if we allow calling operations in expressions |
| 2647 | | visibility(machine, Scope, invariant, [promoted],[inquiry]) :- |
| 2648 | | Scope \= local, % do not allow calling local operations in invariant; their correctness relies on the invariant |
| 2649 | | get_preference(allow_operation_calls_in_expr,true). |
| 2650 | | |
| 2651 | | visibility(machine, included, properties, [sets,constants],[]). |
| 2652 | | visibility(machine, included, invariant, [sets,constants,variables],[]). |
| 2653 | | visibility(machine, included, operation_bodies, [sets,constants,variables],[readonly]). |
| 2654 | | visibility(machine, included, operation_bodies, [promoted],Info) :- Info = [readonly]. |
| 2655 | | % for allow_operation_calls_in_expr=true we check that operation is inquiry in type checker |
| 2656 | | % (get_preference(allow_operation_calls_in_expr,true) -> Info = [inquiry] ; Info=[readonly]). |
| 2657 | | %visibility(machine, included, initialisation, [sets,constants,variables,promoted],[readonly]). |
| 2658 | | visibility(machine, included, initialisation, [sets,constants,promoted],[readonly]). |
| 2659 | | visibility(machine, included, initialisation, [variables],Info) :- |
| 2660 | | (get_preference(allow_overriding_initialisation,true) |
| 2661 | | -> Info = [] % allow overriding INITIALISATION / making it more concrete |
| 2662 | | ; Info = [readonly]). % default Atelier-B semantics |
| 2663 | | |
| 2664 | | visibility(machine, used, properties, [sets,constants],[]). |
| 2665 | | visibility(machine, used, invariant, [parameters,sets,constants,variables],[]). |
| 2666 | | visibility(machine, used, operation_bodies, [parameters,sets,constants,variables],[readonly]). |
| 2667 | | visibility(machine, used, initialisation, [parameters,sets,constants,variables],[readonly]). |
| 2668 | | visibility(machine, used, operation_bodies, [operations],[inquiry]) :- |
| 2669 | | get_preference(allow_operation_calls_for_uses,true). %% added by leuschel, allowed in Schneider Book |
| 2670 | | % but not allowed by Atelier-B; see test 2135 |
| 2671 | | |
| 2672 | | visibility(machine, seen, includes, [sets,constants],[]). |
| 2673 | | visibility(machine, seen, properties, [sets,constants],[]). |
| 2674 | | visibility(machine, seen, invariant, [sets,constants],[]). |
| 2675 | | visibility(machine, seen, operation_bodies, [sets,constants,variables],[readonly]). |
| 2676 | | visibility(machine, seen, initialisation, [sets,constants,variables],[readonly]). |
| 2677 | | visibility(machine, seen, operation_bodies, [operations],[inquiry]). %% added by leuschel, allow query operation |
| 2678 | | |
| 2679 | | visibility(refinement, local, Section, Access, Info) :- |
| 2680 | | Section \= assertions, % assertions are handled below |
| 2681 | | visibility(machine, local, Section, Access, Info). |
| 2682 | | |
| 2683 | | visibility(refinement, abstraction, includes, [sets,concrete_constants],[]). |
| 2684 | | visibility(refinement, abstraction, properties, [sets,constants],[]). |
| 2685 | | visibility(refinement, abstraction, invariant, [sets,constants,concrete_variables],[]). |
| 2686 | | visibility(refinement, abstraction, invariant, [abstract_variables],[abstraction]). |
| 2687 | | visibility(refinement, abstraction, operation_bodies, [sets,concrete_constants],[readonly]). |
| 2688 | | visibility(refinement, abstraction, operation_bodies, [concrete_variables],[]). |
| 2689 | | |
| 2690 | | visibility(refinement, included, properties, [sets,constants],[]). |
| 2691 | | visibility(refinement, included, invariant, [sets,constants,variables],[]). |
| 2692 | | visibility(refinement, included, operation_bodies, [sets,constants,variables,promoted],[re]). % What is re ??? TO DO: investigate |
| 2693 | | |
| 2694 | | visibility(refinement, seen, includes, [sets,constants],[]). |
| 2695 | | visibility(refinement, seen, properties, [sets,constants],[]). |
| 2696 | | visibility(refinement, seen, invariant, [sets,constants],[]). |
| 2697 | | visibility(refinement, seen, operation_bodies, [sets,constants,variables],[readonly]). |
| 2698 | | visibility(refinement, seen, operation_bodies, [operations],[inquiry]). |
| 2699 | | |
| 2700 | | visibility(refinement, Ref, initialisation, Access, [not_initialised|Info]) :- |
| 2701 | | visibility(refinement,Ref,operation_bodies,Access,Info). |
| 2702 | | |
| 2703 | | % assertions have same visibility as invariant |
| 2704 | | visibility(MType, Ref, assertions, Part, Access) :- |
| 2705 | ? | visibility(MType,Ref,invariant,Part,Access). |
| 2706 | | |
| 2707 | | visibility(implementation, Ref, Section, Part, Access) :- |
| 2708 | | visibility(refinement, Ref, Section, Part, Access). |
| 2709 | | visibility(implementation, local, values_expression, [concrete_constants,sets],[]). % seems to have no effect (yet); see ArrayValuationAImp |
| 2710 | | visibility(implementation, included, values_expression, [concrete_constants,sets],[]). |
| 2711 | | visibility(implementation, seen, values_expression, [concrete_constants,sets],[]). |
| 2712 | | visibility(implementation, abstraction,values_expression, [concrete_constants,sets],[]). |
| 2713 | | |
| 2714 | | % For predicates over pre- and post-states |
| 2715 | | visibility(MType, Rev, prepost, Access, Info) :- |
| 2716 | ? | visibility(MType, Rev, invariant, Access, Info). |
| 2717 | | visibility(MType, Rev, prepost, Access, [primed,poststate|Info]) :- |
| 2718 | ? | visibility(MType, Rev, invariant, Access, Info). |
| 2719 | | |
| 2720 | | % add error messages for some common mistakes (access to parameters in the properties) |
| 2721 | | visibility(machine, local, properties, [parameters], [error('a parameter cannot be accessed in the PROPERTIES section')]). |
| 2722 | | % the following rule should be helpful for the user, but additionally it also |
| 2723 | | % provides a mechanism to re-introduce abstract variables in the INVARIANT |
| 2724 | | % section of a while loop (to enable this, an identifier is also marked with "abstraction") |
| 2725 | | % in the predicate allow_access_to_abstract_var |
| 2726 | | visibility(refinement, abstraction, operation_bodies, [abstract_variables], |
| 2727 | | [error('illegal access to an abstract variable in an operation'),abstraction]). |
| 2728 | | visibility(refinement, abstraction, operation_bodies, [abstract_constants], |
| 2729 | | [error('illegal access to an abstract constant in an operation (only allowed in WHILE INVARIANT or ASSERT)'),abstraction]). |
| 2730 | | |
| 2731 | | |
| 2732 | | % lookups up all identifier sections that are accessible from |
| 2733 | | % the given section, removes all shortcuts and removes |
| 2734 | | % duplicate entries |
| 2735 | | % |
| 2736 | | % Returns a list of vis(Section,Info) where Section is the |
| 2737 | | % identifier section that can be seen with Info as a list |
| 2738 | | % of additional information |
| 2739 | | expanded_visibility(MType, Ref, Part, Access) :- |
| 2740 | | findall(vis(Section,Infos), |
| 2741 | | ( visibility(MType,Ref,Part,Sections1,Infos), |
| 2742 | | expand_shortcuts(Sections1,Sections), |
| 2743 | | member(Section,Sections)), |
| 2744 | | Access1), |
| 2745 | | sort(Access1,Access). |
| 2746 | | %format('MType=~w, Ref=~w, Part=~w~n Vis=~w~n',[MType,Ref,Part,Access]). |
| 2747 | | |
| 2748 | | % visible_env/6 creates a type environment for a certain |
| 2749 | | % part of a machine by looking up which identifier should |
| 2750 | | % be visible from there and what additional information should |
| 2751 | | % be added (e.g. to restrict access to read-only) |
| 2752 | | % |
| 2753 | | % The visibility/6 facts are used to define which identifier are visible |
| 2754 | | % |
| 2755 | | % MType: machine type (machine, refinement, ...) |
| 2756 | | % Part: part of the machine for which the environment should be created |
| 2757 | | % RefMachines: referred machines that are already typed |
| 2758 | | % Env: The created environment |
| 2759 | | % Errors: errors might be added if multiple variables with the same identifier |
| 2760 | | % are declared |
| 2761 | | visible_env(MType, Part, RefMachines, Env, Err_in, Err_out) :- |
| 2762 | | env_empty(Init), |
| 2763 | | visible_env(MType, Part, RefMachines, Init, Env, Err_in, Err_out). |
| 2764 | | % visible_env/7 is like visible_env/6, but an initial environment |
| 2765 | | % can be given in "In" |
| 2766 | | visible_env(MType, Part, RefMachines, In, Out, Err_in, Err_out) :- |
| 2767 | | foldl(visible_env2(MType,Part),RefMachines,In/Err_in,Out/Err_out). |
| 2768 | | visible_env2(MType,Part,extended_local_ref(Machine),InEnvErr,OutEnvErr) :- !, |
| 2769 | | Scope=local, |
| 2770 | | get_machine_name(Machine,MName), |
| 2771 | | %format('adding identifiers from machine ~w for scope ~w~n',[MName,Scope]), |
| 2772 | | get_section(definitions,Machine,Defs), |
| 2773 | | foldl(env_add_def(MName),Defs,InEnvErr,InEnvErr2), |
| 2774 | | (bmachine:additional_configuration_machine(_MchName,AddMachine), |
| 2775 | | get_section(definitions,AddMachine,AdditionalDefs) |
| 2776 | | -> foldl(env_add_def(MName),AdditionalDefs,InEnvErr2,InterEnvErr) |
| 2777 | | ; InterEnvErr = InEnvErr2 |
| 2778 | | ), |
| 2779 | | expanded_visibility(MType, Scope, Part, Access), |
| 2780 | | foldl(create_vis_env(Scope,MName,Machine),Access,InterEnvErr,OutEnvErr). |
| 2781 | | visible_env2(MType,Part,ref(Scope,Machine),InEnvErr,OutEnvErr) :- |
| 2782 | | get_machine_name(Machine,MName), |
| 2783 | | %format('adding identifiers from machine ~w for scope ~w~n',[MName,Scope]), |
| 2784 | | ( Scope == local -> |
| 2785 | | get_section(definitions,Machine,Defs), |
| 2786 | | %nl,print(adding_defs(Defs)),nl,nl, |
| 2787 | | foldl(env_add_def(MName),Defs,InEnvErr,InterEnvErr) |
| 2788 | | ; |
| 2789 | | InEnvErr=InterEnvErr), |
| 2790 | | expanded_visibility(MType, Scope, Part, Access), |
| 2791 | | foldl(create_vis_env(Scope,MName,Machine),Access,InterEnvErr,OutEnvErr). |
| 2792 | | env_add_def(MName,definition_decl(Name,PType,Pos,Params,Body,_Deps),InEnvErr,OutEnvErr) :- |
| 2793 | | Type = definition(PType,Params,Body), |
| 2794 | | Info = [nodeid(Pos),loc(local,MName,definitions)], |
| 2795 | | create_texpr(identifier(Name),Type,Info,TExpr), |
| 2796 | | add_unique_variable(TExpr,InEnvErr,OutEnvErr),!. |
| 2797 | | env_add_def(MName,Def,EnvErr,EnvErr) :- |
| 2798 | | add_internal_error('Cannot deal with DEFINITION: ',env_add_def(MName,Def)). |
| 2799 | | |
| 2800 | | create_vis_env(Scope,MName,IDS,vis(Section,Infos),InEnvErr,OutEnvErr) :- |
| 2801 | | get_section(Section,IDS,Identifiers1), |
| 2802 | | % get_texpr_ids(Identifiers1,II),format('Got identifiers for ~w:~w = ~w~n',[MName,Section,II]), |
| 2803 | | (Section=freetypes |
| 2804 | | -> generate_free_type_ids(Identifiers1,Identifiers2) |
| 2805 | | ; Identifiers2=Identifiers1), |
| 2806 | | maplist(add_infos_to_identifier([loc(Scope,MName,Section)|Infos]),Identifiers2,Identifiers), |
| 2807 | | l_add_unique_variables(Identifiers,InEnvErr,OutEnvErr). |
| 2808 | | |
| 2809 | | % optimized version of foldl(add_unique_variable,Identifiers,InEnvErr,OutEnvErr). |
| 2810 | | l_add_unique_variables([],Env,Env). |
| 2811 | | l_add_unique_variables([ID|T],InEnvErr,OutEnvErr) :- |
| 2812 | | add_unique_variable(ID,InEnvErr,IntEnv), |
| 2813 | | l_add_unique_variables(T,IntEnv,OutEnvErr). |
| 2814 | | |
| 2815 | | % freetypes: generate IDs for Z freetype section |
| 2816 | | % The classical B FREETYPE section is dealt with in another place (TODO: unify this) |
| 2817 | | generate_free_type_ids([freetype(FTypeId,Cases)|T],[b(identifier(FTypeId),set(freetype(FTypeId)),[])|FT]) :- !, |
| 2818 | | findall(b(identifier(CaseID),CaseType,[]), |
| 2819 | | (member(case(CaseID,ArgType),Cases), gen_freecase_type(ArgType,FTypeId,CaseType)), |
| 2820 | | FT, FT2), |
| 2821 | | %write(generated_freetype_cases(FT)),nl, |
| 2822 | | generate_free_type_ids(T,FT2). |
| 2823 | | generate_free_type_ids(T,T). |
| 2824 | | |
| 2825 | | gen_freecase_type(ArgType,FTypeId,Type) :- nonvar(ArgType), ArgType=constant(_),!, Type = freetype(FTypeId). |
| 2826 | | gen_freecase_type(ArgType,FTypeId,set(couple(ArgType,freetype(FTypeId)))). |
| 2827 | | |
| 2828 | | add_unique_variable(Var1,Old/Err_in,New/Err_out) :- |
| 2829 | | optionally_rewrite_id(Var1,Var), |
| 2830 | | get_texpr_id(Var,Id), |
| 2831 | | get_texpr_type(Var,Type), |
| 2832 | | get_texpr_info(Var,InfosOfNew),!, |
| 2833 | | ( env_lookup_type(Id,Old,_) -> |
| 2834 | | % we have a collision of two identifiers |
| 2835 | | handle_collision(Var,Id,Type,Old,InfosOfNew,New,Err_in,Err_out) |
| 2836 | | ; |
| 2837 | | % no collision, just introduce the new identifier |
| 2838 | | env_store(Id,Type,InfosOfNew,Old,New), |
| 2839 | | %btypechecker:portray_env(New),nl, |
| 2840 | | Err_in=Err_out |
| 2841 | | ). |
| 2842 | | add_unique_variable(Var,Env/Err,Env/Err) :- print(Var),nl, |
| 2843 | | ( Var = b(definition(DEFNAME,_),_,INFO) -> |
| 2844 | | add_error(add_unique_variable,'DEFINITION used in place of Identifier: ',DEFNAME,INFO) |
| 2845 | | ; Var = b(description(Txt,_),_,INFO) -> |
| 2846 | | add_error(add_unique_variable,'Unsupported @desc pragma: ',Txt,INFO) |
| 2847 | | ; |
| 2848 | | add_error(add_unique_variable,'Expected Identifier, but got: ',Var,Var) |
| 2849 | | ). |
| 2850 | | |
| 2851 | | add_infos_to_identifier(NewInfos,In,Out) :- |
| 2852 | | add_texpr_infos(In,NewInfos,Out). |
| 2853 | | |
| 2854 | | % get the ID of the variable, prime it if the infos contain "primed" |
| 2855 | | optionally_rewrite_id(Var,NewVar) :- |
| 2856 | | get_texpr_info(Var,InfosIn), |
| 2857 | | ( selectchk(primed,InfosIn,InfosOut) -> |
| 2858 | | get_texpr_id(Var,Id1), |
| 2859 | | get_texpr_type(Var,Type), |
| 2860 | | atom_concat(Id1,'\'',Id), |
| 2861 | | create_texpr(identifier(Id),Type,InfosOut,NewVar) |
| 2862 | | ; |
| 2863 | | Var = NewVar). |
| 2864 | | |
| 2865 | | :- use_module(translate,[translate_span/2]). |
| 2866 | | % in case of a collision, we have three options: |
| 2867 | | % - overwrite the old identifier, |
| 2868 | | % - ignore the new identifier or |
| 2869 | | % - generate an error message |
| 2870 | | handle_collision(Var,Name,Type,OldEnv,InfosOfNew,NewEnv,Ein,Eout) :- |
| 2871 | | env_lookup_infos(Name,OldEnv,InfosOfExisting), |
| 2872 | | %btypechecker:portray_env(OldEnv),nl, |
| 2873 | | ( collision_precedence(Name,InfosOfExisting,InfosOfNew) -> |
| 2874 | | % this identifier should be ignored |
| 2875 | | OldEnv = NewEnv, |
| 2876 | | Ein = Eout |
| 2877 | | ; collision_precedence(Name,InfosOfNew,InfosOfExisting) -> |
| 2878 | | % the existing should be overwritten |
| 2879 | | env_store(Name,Type,InfosOfNew,OldEnv,NewEnv), |
| 2880 | | Ein = Eout |
| 2881 | | ; |
| 2882 | | % generate error and let the environment unchanged |
| 2883 | | (Name = op(IName) -> Kind='Operation identifier'; Name=IName, Kind='Identifier'), |
| 2884 | | get_texpr_pos(Var,Pos1), |
| 2885 | | safe_get_info_pos(InfosOfExisting,Pos2), |
| 2886 | | ( double_inclusion_allowed(Name,Pos1,Pos2,InfosOfExisting) |
| 2887 | | -> %print(double_inclusion_of_id_allowed(Name,Type,Pos1,OldEnv,InfosOfExisting)),nl, |
| 2888 | | OldEnv=NewEnv, |
| 2889 | | Ein=Eout |
| 2890 | | ; (better_pos(Pos2,Pos1), \+ better_pos(Pos1,Pos2) |
| 2891 | | -> Pos = Pos2, translate_span(Pos1,PS1) |
| 2892 | | ; Pos = Pos1, |
| 2893 | | PS1='' % Pos1 is already part of error span |
| 2894 | | ), |
| 2895 | | translate_inclusion_path(InfosOfExisting,Path2), |
| 2896 | | get_texpr_info(Var,Info1), translate_inclusion_path(Info1,Path1), |
| 2897 | | (Pos1=Pos2, Path1=Path2 |
| 2898 | | -> ajoin([Kind,' \'', IName, '\'', PS1, Path1, ' included twice '],Msg) |
| 2899 | | % This should probably not happen; internal error in machine construction? |
| 2900 | | ; translate_span(Pos2,PS2), |
| 2901 | | %ajoin(['Identifier \'', IName, '\' declared twice at (Line:Col[:File]) ', PS1, Path1, ' and ', PS2, Path2],Msg), |
| 2902 | | ajoin([Kind,' \'', IName, '\'', PS1, Path1, ' already declared at ', PS2, Path2],Msg) |
| 2903 | | ), |
| 2904 | | %format(user_error,'*** ~w~n',[Msg]),trace, |
| 2905 | | Ein = [error(Msg,Pos)|Eout], |
| 2906 | | OldEnv = NewEnv |
| 2907 | | ) |
| 2908 | | ). |
| 2909 | | |
| 2910 | | |
| 2911 | | % example identifier: %b(identifier(aa),integer,[loc(seen,M2,concrete_constants),readonly,usesee(M2,aa,seen),origin([included/M1]),nodeid(pos(18,2,2,11,2,13))]) |
| 2912 | | |
| 2913 | | % try and infer inclusion path of identifier from Infos |
| 2914 | | translate_inclusion_path(Infos,Str) :- member(loc(How,Machine,Section),Infos),!, |
| 2915 | | (member(origin(Path),Infos) -> get_origin_path(Path,T) ; T=[')']), |
| 2916 | | ajoin([' (', How,' from ', Section, ' section of ', Machine |T],Str). |
| 2917 | | translate_inclusion_path(_,''). |
| 2918 | | |
| 2919 | | get_origin_path([How/Machine|T],[', ', How,' from ',Machine|TRes]) :- !, |
| 2920 | | get_origin_path(T,TRes). |
| 2921 | | get_origin_path(_,[')']). |
| 2922 | | |
| 2923 | | |
| 2924 | | % SEE ISSUE PROB-403, test 1857 |
| 2925 | | % Correct behaviour related to multiple instantiation is specified in |
| 2926 | | % B Reference Manual (AtelierB 4.2.1), 8.3 B Project/Instantiating and renaming. |
| 2927 | | % => Constants and Sets defined in machines instantiated multiple times CAN be used in the including machine with their original (non-prefixed names). |
| 2928 | | % Note: this code did lead to the constants being added multiple times; this has been fixed in concat_section_contents |
| 2929 | | double_inclusion_allowed(Name,Pos1,Pos2,InfosOfExisting) :- |
| 2930 | | %print(check_double_inclusion(Name,Pos1,Pos2,InfosOfExisting)),nl, |
| 2931 | | Pos1==Pos2, |
| 2932 | | %print(chk(InfosOfExisting)),nl, |
| 2933 | | member(loc(LOC,_,Section),InfosOfExisting), |
| 2934 | | %print(try(LOC,Section)),nl, |
| 2935 | | section_can_be_included_multiple_times_nonprefixed(Section), |
| 2936 | | % check that we are in a context of an included machine identifier: |
| 2937 | | (inclusion_directive(LOC,Name,Pos2) |
| 2938 | | -> true |
| 2939 | | ; %LOC is probably local |
| 2940 | | member(origin([INCL/_MACHINE|_]),InfosOfExisting), |
| 2941 | | inclusion_directive(INCL,Name,Pos2) |
| 2942 | | ). |
| 2943 | | |
| 2944 | | inclusion_directive(included,_,_). |
| 2945 | | inclusion_directive(used,_,_). |
| 2946 | | inclusion_directive(seen,_,_). % imports ?? |
| 2947 | | inclusion_directive(abstraction,Name,Pos) :- % probably not allowed by Atelier-B |
| 2948 | | (debug_mode(off) -> true |
| 2949 | | ; add_message(bmachine_construction,'Allowing double inclusion from abstraction of: ',Name,Pos)). |
| 2950 | | |
| 2951 | | section_can_be_included_multiple_times_nonprefixed(abstract_constants). |
| 2952 | | section_can_be_included_multiple_times_nonprefixed(concrete_constants). |
| 2953 | | section_can_be_included_multiple_times_nonprefixed(sets). |
| 2954 | | section_can_be_included_multiple_times_nonprefixed(enumerated_sets). |
| 2955 | | section_can_be_included_multiple_times_nonprefixed(enumerated_elements). |
| 2956 | | section_can_be_included_multiple_times_nonprefixed(deferred_sets). % added 2.12.2022 |
| 2957 | | section_can_be_included_multiple_times_nonprefixed(constants). % shortcut |
| 2958 | | |
| 2959 | | |
| 2960 | | % decide which position info is better: prefer info in main file (highlighting) |
| 2961 | | :- use_module(bmachine,[b_get_main_filenumber/1]). |
| 2962 | | better_pos(Pos,_) :- get_position_filenumber(Pos,Filenumber), |
| 2963 | | b_get_main_filenumber(Filenumber). |
| 2964 | | better_pos(_,none). |
| 2965 | | |
| 2966 | | safe_get_info_pos(Info,Pos) :- (get_info_pos(Info,Pos) -> true ; Pos=none). |
| 2967 | | |
| 2968 | | % collision_precedence/3 decides if the first variable takes |
| 2969 | | % precedence over the second in case of a collision |
| 2970 | | % the decision is made by the additional information of both |
| 2971 | | % variables |
| 2972 | | collision_precedence(_Name,PreferredVarInfos,DroppedVarInfos) :- |
| 2973 | | % in case of a re-introduced variable from the abstraction, |
| 2974 | | % we prefer the concrete variable to the abstract one. |
| 2975 | | is_abstraction(DroppedVarInfos,PreferredVarInfos),!. |
| 2976 | | collision_precedence(_Name,PreferredVarInfos,DroppedVarInfos) :- |
| 2977 | | % We are checking an Event-B model with multi-level support |
| 2978 | | % and have the same variable in two different refinement levels. |
| 2979 | | % Then the one in the more refined module takes precedence |
| 2980 | | member(level(L1),PreferredVarInfos), |
| 2981 | | member(level(L2),DroppedVarInfos), |
| 2982 | | % Level 0 is the abstract level, level 1 the first refinement, etc. |
| 2983 | | L1 > L2,!. |
| 2984 | | collision_precedence(Name,PreferredVarInfos,DroppedVarInfos) :- |
| 2985 | | % A local definition takes precedence over a non-local identifier |
| 2986 | | % TODO: |
| 2987 | | member(loc(local,_DefMachine,definitions),PreferredVarInfos), |
| 2988 | | member(loc(_,_VarMachine,Section),DroppedVarInfos), |
| 2989 | | Section \= definitions,!, |
| 2990 | | (preferences:get_preference(warn_if_definition_hides_variable,true) |
| 2991 | | % default is true; we could also check clash_strict_checks |
| 2992 | | -> get_id_kind(Section,HiddenIdKind), |
| 2993 | | (get_info_pos(PreferredVarInfos,Pos1), Pos1 \= none, |
| 2994 | | get_info_pos(DroppedVarInfos,Pos2), Pos2 \= none |
| 2995 | | -> translate:translate_span(Pos1,Pos1Str), translate:translate_span(Pos2,Pos2Str), |
| 2996 | | ajoin(['Warning: DEFINITION of ', Name, ' at ', Pos1Str, |
| 2997 | | ' hides ',HiddenIdKind,' with same name at ', Pos2Str, '.'], Msg) |
| 2998 | | ; ajoin(['Warning: DEFINITION of ', Name, ' hides ',HiddenIdKind,' with same name.'], Msg), |
| 2999 | | Pos1 = unknown |
| 3000 | | ), |
| 3001 | | store_warning(Msg,Pos1) % TO DO: add position info |
| 3002 | | ; true |
| 3003 | | ). |
| 3004 | | % TO DO: allow identical DEFINITIONS ? |
| 3005 | | |
| 3006 | | % translate section name into a name for the identifier |
| 3007 | | get_id_kind(abstract_constants,'constant'). |
| 3008 | | get_id_kind(concrete_constants,'constant'). |
| 3009 | | get_id_kind(parameters,'parameter'). |
| 3010 | | get_id_kind(deferred_sets,'deferred set'). |
| 3011 | | get_id_kind(enumerated_sets,'enumerated set'). |
| 3012 | | get_id_kind(enumerated_elements,'enumerated set element'). |
| 3013 | | get_id_kind(freetypes,'freetype'). |
| 3014 | | get_id_kind(promoted,'operation'). |
| 3015 | | % TODO: complete and use in other places |
| 3016 | | get_id_kind(_SectionName,'variable'). |
| 3017 | | |
| 3018 | | |
| 3019 | | % is_abstraction/2 tries to find out if (in case of a name clash of |
| 3020 | | % two variables) the second variable is just the re-introduced abstract |
| 3021 | | % variable in a refinement. |
| 3022 | | % InfosAbs is the list of information about the abstract variable |
| 3023 | | % InfosConc is the list of information about the concrete variable |
| 3024 | | is_abstraction(InfosAbs,InfosConc) :- |
| 3025 | | % one variable is an abstract variable, introduced in the abstraction |
| 3026 | | member(loc(abstraction,_,abstract_variables),InfosAbs), |
| 3027 | | % the other is either an abstract or concrete variable, |
| 3028 | | member(VarType,[abstract_variables,concrete_variables]), |
| 3029 | | % introduced either locally or in an included machine |
| 3030 | | member(Scope,[local,included]), |
| 3031 | | member(loc(Scope,_,VarType),InfosConc). |
| 3032 | | % and the same for constants: |
| 3033 | | is_abstraction(InfosAbs,InfosConc) :- |
| 3034 | | % one variable is an abstract variable, introduced in the abstraction |
| 3035 | | member(loc(abstraction,_,abstract_constants),InfosAbs), |
| 3036 | | % the other is either an abstract or concrete variable, |
| 3037 | | member(VarType,[abstract_constants,concrete_constants]), |
| 3038 | | % introduced either locally or in an included machine |
| 3039 | | member(Scope,[local,included]), |
| 3040 | | member(loc(Scope,_,VarType),InfosConc). |
| 3041 | | |
| 3042 | | % shortcuts for sections, to ease the use of typical combinations of |
| 3043 | | % sections |
| 3044 | | shortcut(all_parameters,[parameters,internal_parameters]). |
| 3045 | | shortcut(sets,[deferred_sets,enumerated_sets,enumerated_elements|T]) :- |
| 3046 | | (animation_minor_mode(M), (M=z ; M=eventb) |
| 3047 | | -> T = [freetypes] |
| 3048 | | ; T = []). % The FREETYPES section in classical B is unfortunately dealt with differently and |
| 3049 | | % we currently have errors if add the freetypes section here |
| 3050 | | shortcut(constants,[abstract_constants,concrete_constants]). |
| 3051 | | shortcut(variables,[abstract_variables,concrete_variables]). |
| 3052 | | shortcut(operations,[unpromoted,promoted]). |
| 3053 | | shortcut(identifiers,[all_parameters,sets,constants,variables,operations]). |
| 3054 | | |
| 3055 | | expand_shortcuts(Sections,Expanded) :- |
| 3056 | | foldl(expand_shortcut,Sections,Expanded,[]). |
| 3057 | | expand_shortcut(Section,Sections,RSections) :- |
| 3058 | | ( shortcut(Section,Expanded) -> |
| 3059 | | foldl(expand_shortcut,Expanded,Sections,RSections) |
| 3060 | | ; valid_section(Section) -> |
| 3061 | | Sections = [Section|RSections] |
| 3062 | | ; |
| 3063 | | add_internal_error('invalid section',expand_shortcut(Section,Sections,RSections)),fail). |
| 3064 | | |
| 3065 | | % find sections that can see given sections |
| 3066 | | find_relevant_sections(RSecs,MTypes,Result) :- |
| 3067 | | expand_shortcuts(RSecs,Sections), |
| 3068 | | findall(R, |
| 3069 | | ( member(MType,MTypes), |
| 3070 | | visibility(MType,local,R,SAccess,_), |
| 3071 | | expand_shortcuts(SAccess,Access), |
| 3072 | | member(S,Sections), |
| 3073 | | member(S,Access), |
| 3074 | | valid_section(R)), |
| 3075 | | Result1), |
| 3076 | | sort(Result1,Result). |
| 3077 | | |
| 3078 | | |
| 3079 | | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% |
| 3080 | | % renaming |
| 3081 | | |
| 3082 | | rename_relevant_sections(DefSecs,Renamings,Machine,New) :- |
| 3083 | | find_relevant_sections(DefSecs,[machine],Relevant), |
| 3084 | | rename_in_sections(Relevant,Renamings,Machine,New). |
| 3085 | | rename_in_sections([],_,M,M). |
| 3086 | | rename_in_sections([Section|Rest],Renamings,Old,New) :- |
| 3087 | | select_section_texprs(Section,OTExprs,NTExprs,Old,Inter), |
| 3088 | | rename_bt_l(OTExprs,Renamings,NTExprs), |
| 3089 | | rename_in_sections(Rest,Renamings,Inter,New). |
| 3090 | | |
| 3091 | | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% |
| 3092 | | :- use_module(kernel_freetypes,[register_freetypes/1]). |
| 3093 | | % cleaning up machine |
| 3094 | | clean_up_machine(In,RefMachines,Out) :- |
| 3095 | | extract_parameter_types([ref(local,In)|RefMachines],NonGroundExceptions), |
| 3096 | | clean_up_machine2(NonGroundExceptions,In,Out). |
| 3097 | | clean_up_machine2(NonGroundExceptions) --> |
| 3098 | | get_section_content(enumerated_sets,Enum), |
| 3099 | | get_section_content(enumerated_elements,Elems), |
| 3100 | | {register_enumerated_sets(Enum,Elems)}, % register name of enumerated sets, e.g., to detect finite in ast_cleanup |
| 3101 | | get_section_content(freetypes,Freetypes), |
| 3102 | | {register_freetypes(Freetypes)}, % so that info is available in ast_cleanup for eval_set_extension |
| 3103 | | clean_up_section(constraints,NonGroundExceptions), |
| 3104 | | clean_up_section(properties,NonGroundExceptions), |
| 3105 | | clean_up_section(invariant,NonGroundExceptions), |
| 3106 | | clean_up_section(initialisation,NonGroundExceptions), |
| 3107 | | clean_up_section(assertions,NonGroundExceptions), |
| 3108 | | clean_up_section(operation_bodies,NonGroundExceptions). |
| 3109 | | :- load_files(library(system), [when(compile_time), imports([environ/2])]). |
| 3110 | | :- if(environ(prob_safe_mode,true)). |
| 3111 | | clean_up_section(Section,NonGroundExceptions,In,Out) :- |
| 3112 | | select_section_texprs(Section,Old,New,In,Out), |
| 3113 | | %format('Cleaning up and optimizing section ~w~n',[Section]), %maplist(check_ast,Old), % this will raise errors |
| 3114 | | clean_up_l_with_optimizations(Old,NonGroundExceptions,New,Section), |
| 3115 | | %format('Checking result of clean_up section ~w~n',[Section]), |
| 3116 | | maplist(check_ast(true),New), |
| 3117 | | formatsilent('Finished checking section ~w~n',[Section]). |
| 3118 | | :- else. |
| 3119 | | clean_up_section(Section,NonGroundExceptions,In,Out) :- |
| 3120 | | % debug_stats(cleaning_up(Section)), |
| 3121 | | select_section_texprs(Section,Old,New,In,Out), |
| 3122 | | clean_up_l_with_optimizations(Old,NonGroundExceptions,New,Section). |
| 3123 | | :- endif. |
| 3124 | | |
| 3125 | | get_section_content(SecName,SectionContent,Mch,Mch) :- get_section(SecName,Mch,SectionContent). |
| 3126 | | |
| 3127 | | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% |
| 3128 | | % type expressions in context of an already type-checked machine |
| 3129 | | % TO DO: maybe do some performance optimisations for identifiers, values, ... to avoid creating scope, see formula_typecheck2_for_eval optimisation |
| 3130 | | % b_type_literal does it in bmachine before calling type_in_machine_l |
| 3131 | | type_in_machine_l(Exprs,Scope,NonGroundExceptions,Machine,Types,TExprs,Errors) :- |
| 3132 | | MType = machine, |
| 3133 | | create_scope_if_necessary(Exprs,Scope,MType,Machine,Env,Errors,E1), % this can be expensive for big B machines |
| 3134 | | %runtime_profiler:profile_single_call(create_scope,unknown, |
| 3135 | | % bmachine_construction:create_scope(Scope,MType,Machine,Env,Errors,E1)), |
| 3136 | | btype_ground_dl(Exprs,Env,NonGroundExceptions,Types,TExprUncleans,E1,[]), |
| 3137 | | perform_post_static_check(TExprUncleans), |
| 3138 | ? | maplist(clean_up_pred_or_expr(NonGroundExceptions),TExprUncleans,TExprs). |
| 3139 | | |
| 3140 | | % detect a few common expressions which do not require creating a scope of all the identifiers |
| 3141 | | create_scope_if_necessary([E],_Scope,MType,Machine,Env,Ein,Eout) :- raw_expr_wo_ids(E),!, |
| 3142 | | create_scope([],MType,Machine,Env,Ein,Eout). |
| 3143 | | create_scope_if_necessary(_Exprs,Scope,MType,Machine,Env,Ein,Eout) :- |
| 3144 | | create_scope(Scope,MType,Machine,Env,Ein,Eout). |
| 3145 | | |
| 3146 | | % a few common raw ASTs which do not refer to identifiers |
| 3147 | | raw_expr_wo_ids(falsity(_)). |
| 3148 | | raw_expr_wo_ids(truth(_)). |
| 3149 | | raw_expr_wo_ids(empty_set(_)). |
| 3150 | | raw_expr_wo_ids(equal(_,A,B)) :- raw_expr_wo_ids(A), raw_expr_wo_ids(B). |
| 3151 | | raw_expr_wo_ids(not_equal(_,A,B)) :- raw_expr_wo_ids(A), raw_expr_wo_ids(B). |
| 3152 | | raw_expr_wo_ids(interval(_,A,B)) :- raw_expr_wo_ids(A), raw_expr_wo_ids(B). |
| 3153 | | raw_expr_wo_ids(add(_,A,B)) :- raw_expr_wo_ids(A), raw_expr_wo_ids(B). |
| 3154 | | raw_expr_wo_ids(minus_or_set_subtract(_,A,B)) :- raw_expr_wo_ids(A), raw_expr_wo_ids(B). |
| 3155 | | raw_expr_wo_ids(mult_or_cart(_,A,B)) :- raw_expr_wo_ids(A), raw_expr_wo_ids(B). |
| 3156 | | raw_expr_wo_ids(unary_minus(_,A)) :- raw_expr_wo_ids(A). |
| 3157 | | raw_expr_wo_ids(boolean_true(_)). |
| 3158 | | raw_expr_wo_ids(boolean_false(_)). |
| 3159 | | raw_expr_wo_ids(bool_set(_)). |
| 3160 | | raw_expr_wo_ids(integer(_,_)). |
| 3161 | | raw_expr_wo_ids(real(_,_)). |
| 3162 | | raw_expr_wo_ids(string(_,_)). |
| 3163 | | |
| 3164 | | |
| 3165 | | % note prob_ids(visible), external_library(all_available_libraries) scope is expanded somewhere else |
| 3166 | | create_scope(pre_expanded_scope(PEnv,Errors),_MType,_Machine,Env,Ein,Eout) :- |
| 3167 | | !, % already pre-expanded |
| 3168 | | Env=PEnv, append(Errors,Eout, Ein). |
| 3169 | | create_scope(Scope,MType,Machine,Env,Ein,Eout) :- |
| 3170 | | env_empty(Init), |
| 3171 | | add_theory_operators(Machine,Init,WithOperators), |
| 3172 | | foldl(create_scope2(MType,Machine),Scope,WithOperators/Ein,Env/Eout). |
| 3173 | | add_theory_operators(Machine,Ein,Eout) :- |
| 3174 | | get_section(operators,Machine,Operators), |
| 3175 | | keys_and_values(Operators,Ids,Ops), |
| 3176 | | foldl(env_store_operator,Ids,Ops,Ein,Eout). |
| 3177 | | create_scope2(MType,Machine,Scope,In/Ein,Out/Eout) :- |
| 3178 | | ( Scope = constants -> |
| 3179 | | visible_env(MType,properties,[ref(local,Machine)],In,Out,Ein,Eout) |
| 3180 | | ; Scope = variables -> |
| 3181 | | visible_env(MType,invariant,[ref(local,Machine)],In,Out,Ein,Eout) |
| 3182 | | ; Scope = variables_and_additional_defs -> |
| 3183 | | visible_env(MType,invariant,[extended_local_ref(Machine)],In,Out,Ein,Eout) |
| 3184 | | ; Scope = assertions_scope_and_additional_defs -> |
| 3185 | | visible_env(MType,assertions,[extended_local_ref(Machine)],In,Out,Ein,Eout) |
| 3186 | | ; Scope = prepost -> |
| 3187 | | visible_env(MType,prepost,[ref(local,Machine)],In,Out,Ein,Eout) |
| 3188 | | ; Scope = operation_bodies -> |
| 3189 | | visible_env(MType,operation_bodies,[ref(local,Machine)],In,Out,Ein,Eout) |
| 3190 | | ; Scope = operation(Op) -> |
| 3191 | | create_operation_scope(Op,Machine,In,Out), Ein=Eout |
| 3192 | | ; Scope = env(ExplicitEnv) -> |
| 3193 | | ExplicitEnv = Out, Ein=Eout |
| 3194 | | ; Scope = identifier(Ids) -> |
| 3195 | | store_variables(Ids,In,Out), Ein=Eout |
| 3196 | | ; Scope = external_library(LibName) % be sure to make these last to avoid duplication errors |
| 3197 | | -> store_ext_defs(LibName,In,Out), Ein=Eout |
| 3198 | | ; |
| 3199 | | add_error(bmachine_construction, 'invalid scope', Scope),fail). |
| 3200 | | create_operation_scope(Op,Machine,In,Out) :- |
| 3201 | | get_section(operation_bodies,Machine,OpBodies), |
| 3202 | | get_texpr_id(OpId,op(Op)), |
| 3203 | | get_texpr_expr(TOp,operation(OpId,Results,Params,_)), |
| 3204 | | ( member(TOp,OpBodies) -> |
| 3205 | | append(Results,Params,LocalVariables), |
| 3206 | | store_variables(LocalVariables,In,Out) |
| 3207 | | ; |
| 3208 | | ajoin(['operation \'',Op,'\' not found for building scope'], Msg), |
| 3209 | | add_error(bmachine_construction,Msg),fail). |
| 3210 | | store_variables(Ids,In,Out) :- foldl(store_variable,Ids,In,Out). |
| 3211 | | store_variable(Id,In,Out) :- |
| 3212 | | get_texpr_id(Id,Name),get_texpr_type(Id,Type), |
| 3213 | | env_store(Name,Type,[],In,Out). |
| 3214 | | |
| 3215 | | type_open_predicate_with_quantifier(OptionalOuterQuantifier,Predicate,Scope,Machine,TResult,Errors) :- |
| 3216 | | type_open_formula(Predicate,Scope,false,Machine,pred,Identifiers,TPred,Errors), |
| 3217 | | ( Identifiers = [] -> |
| 3218 | | TResult = TPred |
| 3219 | | ; OptionalOuterQuantifier=forall -> |
| 3220 | | create_forall(Identifiers,TPred,TResult) |
| 3221 | | ; OptionalOuterQuantifier=no_quantifier -> |
| 3222 | | TResult = TPred |
| 3223 | | ; % OptionalOuterQuantifier=exists |
| 3224 | | %perform_do_not_enumerate_analysis(Identifiers,TPred,'EXISTS',Span,TPred2), % now done by apply_kodkod_or_other_optimisations |
| 3225 | | create_exists(Identifiers,TPred,TResult) |
| 3226 | | ). |
| 3227 | | |
| 3228 | | type_open_formula(Raw,Scope,AllowOpenIdsinExpressions,Machine,Type,Identifiers,Result,Errors) :- |
| 3229 | | create_scope_if_necessary([Raw],Scope,machine,Machine,Env1,Errors,E1), |
| 3230 | | ( Identifiers==[] -> Mode=closed, Env1=Env |
| 3231 | | ; Mode=open, openenv(Env1,Env)), |
| 3232 | | btype_ground_dl([Raw],Env,[],[Type],[TExprUnclean],E1,E2), |
| 3233 | | ( Mode=closed -> true |
| 3234 | | ; |
| 3235 | | openenv_identifiers(Env,Identifiers), % TODO: treat theory operators ? |
| 3236 | | check_ground_types_dl(Identifiers,[],E2,E3) |
| 3237 | | ), |
| 3238 | | %print(type_open_formula(Identifiers,TExprUnclean)),nl, |
| 3239 | | mark_outer_quantifier_ids(TExprUnclean,TExprUnclean2), |
| 3240 | | perform_post_static_check([TExprUnclean2]), |
| 3241 | | clean_up_pred_or_expr([],TExprUnclean2,TResult), % TODO: only run if requested |
| 3242 | | ( Identifiers = [] -> % no newly introduced identifiers, no problem |
| 3243 | | E3 = [] |
| 3244 | | ; Type = pred -> % newly introduced identifiers in a predicate - ok |
| 3245 | | E3 = [] |
| 3246 | | ; AllowOpenIdsinExpressions=true -> % we explicitly allow open ids in expressions |
| 3247 | | E3 = [] |
| 3248 | | ; % newly introduced identifiers in expression make no sense |
| 3249 | | % (is that so?) |
| 3250 | | foldl(add_unknown_identifier_error,Identifiers,E3,[]) |
| 3251 | | ), |
| 3252 | | Result = TResult. |
| 3253 | | add_unknown_identifier_error(TId,[error(Msg,Pos)|E],E) :- |
| 3254 | | get_texpr_id(TId,Id), |
| 3255 | | ajoin(['Unknown identifier ',Id,'.'],Msg), |
| 3256 | | % TO DO: generate fuzzy match and possible completions message |
| 3257 | | get_texpr_pos(TId,Pos). |
| 3258 | | |
| 3259 | | % mark outermost identfiers so that they don't get optimized away |
| 3260 | | % e.g., ensure that we print the solution for something like #(y2,x2).(x2 : 0..10 & y2 : 0..10 & x2 = 10 & y2 = 10) |
| 3261 | | mark_outer_quantifier_ids(b(exists(IDS,Pred),pred,Info),Res) :- |
| 3262 | | maplist(mark_id,IDS,MIDS),!, |
| 3263 | | Res = b(exists(MIDS,Pred),pred,Info). |
| 3264 | | mark_outer_quantifier_ids(b(let_predicate(IDS,Exprs,Pred),pred,Info),Res) :- |
| 3265 | | maplist(mark_id,IDS,MIDS),!, |
| 3266 | | Res = b(let_predicate(MIDS,Exprs,Pred),pred,Info). |
| 3267 | | mark_outer_quantifier_ids(b(forall(IDS,LHS,RHS),pred,Info),Res) :- |
| 3268 | | maplist(mark_id,IDS,MIDS),!, |
| 3269 | | Res = b(forall(MIDS,LHS,RHS),pred,Info). |
| 3270 | | mark_outer_quantifier_ids(X,X). |
| 3271 | | |
| 3272 | | mark_id(b(identifier(ID),TYPE,INFO),b(identifier(ID),TYPE,[do_not_optimize_away|INFO])). |
| 3273 | | |
| 3274 | | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% |
| 3275 | | |
| 3276 | | % some additional static checks; they should be run only once before ast_cleanup runs |
| 3277 | | % TO DO: move maybe some of the exists/forall checks here; would be simpler and not require removed_typing inspection |
| 3278 | | |
| 3279 | | :- use_module(bsyntaxtree,[map_over_typed_bexpr/2]). |
| 3280 | | perform_post_static_check([Typed|_]) :- %print(t(Typed)),nl, |
| 3281 | | preferences:get_preference(disprover_mode,false), |
| 3282 | | map_over_typed_bexpr(post_static_check,Typed), |
| 3283 | | fail. |
| 3284 | | perform_post_static_check([_|T]) :- !, perform_post_static_check(T). |
| 3285 | | perform_post_static_check(_). |
| 3286 | | |
| 3287 | | post_static_check(b(E,T,I)) :- |
| 3288 | | %bsyntaxtree:check_infos(I,post_static_check), |
| 3289 | | post_static_check_aux(E,T,I). |
| 3290 | | |
| 3291 | | :- use_module(bsyntaxtree,[find_identifier_uses/3, is_a_disjunct_or_implication/4]). |
| 3292 | | :- use_module(library(ordsets),[ord_subtract/3]). |
| 3293 | | % should detect patterns like { zz | # r__1, q__1, zz . ( ...)} |
| 3294 | | % {x,z|z=1}[{TRUE}] = {1} |
| 3295 | | % %x.(1=1|1)(TRUE) = 1 |
| 3296 | | post_static_check_aux(lambda(Ids,Body,Expr),_T,Info) :- |
| 3297 | | get_texpr_ids(Ids,AtomicIds), sort(AtomicIds,SortedIds), |
| 3298 | | find_identifier_uses(Body,[],UsedIds1), |
| 3299 | | find_identifier_uses(Expr,[],UsedIds2), % relevant for tests 1106, 1264, 1372, 1622 to also look at Expr |
| 3300 | | ord_subtract(SortedIds,UsedIds1,S2), |
| 3301 | | ord_subtract(S2,UsedIds2,UnusedIds), UnusedIds \= [], |
| 3302 | | add_warning_with_info('Condition of lambda does not use these identifiers: ',UnusedIds,Body,Info). |
| 3303 | | post_static_check_aux(comprehension_set(Ids,Body),_T,Info) :- |
| 3304 | | get_texpr_ids(Ids,AtomicIds), sort(AtomicIds,SortedIds), |
| 3305 | | find_identifier_uses(Body,[],UsedIds), |
| 3306 | | ord_subtract(SortedIds,UsedIds,UnusedIds), UnusedIds \= [], |
| 3307 | | add_warning_with_info('Body of comprehension set does not use these identifiers: ',UnusedIds,Body,Info). |
| 3308 | | post_static_check_aux(exists(Ids,P),_T,Info) :- |
| 3309 | | is_a_disjunct_or_implication(P,Type,_Q,_R), |
| 3310 | | exists_body_warning(Ids,P,Info,Type). |
| 3311 | | |
| 3312 | | % see also check_implication_inside_exists ast cleanup rule |
| 3313 | | exists_body_warning(_,_,_,_) :- animation_minor_mode(X),(X=eventb ; X=tla),!. |
| 3314 | | exists_body_warning(Ids,P,I,Type) :- |
| 3315 | | ajoin(['Body of existential quantifier is a(n) ',Type, |
| 3316 | | ' (not allowed by Atelier-B): '],Msg), |
| 3317 | | add_warning_with_info(Msg,b(exists(Ids,P),pred,I),P,I). |
| 3318 | | |
| 3319 | | |
| 3320 | | |
| 3321 | | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% |
| 3322 | | % Warnings |
| 3323 | | |
| 3324 | | :- use_module(bsyntaxtree,[contains_info_pos/1]). |
| 3325 | | add_warning_with_info(Msg1,Msg2,P,Info) :- |
| 3326 | | (contains_info_pos(Info) -> Pos=Info ; Pos=P), |
| 3327 | | add_warning(bmachine_construction,Msg1,Msg2,Pos). |
| 3328 | | |
| 3329 | | :- dynamic warnings/2. |
| 3330 | | clear_warnings :- |
| 3331 | | retractall( warnings(_,_) ). |
| 3332 | | show_warnings :- |
| 3333 | | warnings(Warning,Span), |
| 3334 | | add_warning(bmachine_construction, Warning,'',Span), |
| 3335 | | fail. |
| 3336 | | show_warnings. |
| 3337 | | |
| 3338 | | |
| 3339 | | store_warning(Warning,Span) :- |
| 3340 | | (warnings(Warning,Span) -> true ; assertz(warnings(Warning,Span))). |