1% ---------------------------------------------------------------------- 2% BEGIN LICENSE BLOCK 3% Version: CMPL 1.1 4% 5% The contents of this file are subject to the Cisco-style Mozilla Public 6% License Version 1.1 (the "License"); you may not use this file except 7% in compliance with the License. You may obtain a copy of the License 8% at www.eclipse-clp.org/license. 9% 10% Software distributed under the License is distributed on an "AS IS" 11% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See 12% the License for the specific language governing rights and limitations 13% under the License. 14% 15% The Original Code is The ECLiPSe Constraint Logic Programming System. 16% The Initial Developer of the Original Code is Cisco Systems, Inc. 17% Portions created by the Initial Developer are 18% Copyright (C) 1989-2006 Cisco Systems, Inc. All Rights Reserved. 19% 20% Contributor(s): ECRC GmbH 21% Contributor(s): IC-Parc, Imperal College London 22% 23% END LICENSE BLOCK 24% 25% System: ECLiPSe Constraint Logic Programming System 26% Version: $Id: pdb.pl,v 1.4 2013/02/18 00:42:58 jschimpf Exp $ 27% ---------------------------------------------------------------------- 28 29/* 30 * SEPIA PROLOG SOURCE MODULE 31 */ 32 33/* 34 * IDENTIFICATION: pdb.pl, part of module(sepia_kernel) 35 * 36 * DESCRIPTION: (used to be db.pl) 37 * 38 * CONTENTS: 39 * 40 */ 41 42 43%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 44 45:- system. % compiler directive to add the SYSTEM flag 46 47:- export 48 current_atom/1, 49 current_functor/1, 50 current_module/1, 51 current_op/3, 52 current_predicate/1, 53 current_built_in/1, 54 is_built_in/1, 55 current_macro/4, 56 pred/1, 57 trimcore/0, 58 abolish_op/2, 59 (als)/1, 60 (als)/2. 61 62:- tool( current_predicate/1, current_predicate_body/2). 63:- tool( current_built_in/1, current_built_in_body/2). 64:- tool( is_built_in/1, is_built_in_body/2). 65:- tool( current_op/3, current_op_body/4). 66:- tool( current_macro/4, current_macro_body/5). 67:- tool( abolish_op/2, abolish_op_body/3). 68:- tool( pred/1, pred_body/2). 69:- tool((als)/1, (als)/2). 70 71%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 72 73 74current_atom(Atom) :- var(Atom), !, current_functor(Atom, 0, 0, 0). 75current_atom(Atom) :- atom(Atom), !. 76current_atom(Atom) :- error(5, current_atom(Atom)). 77 78current_functor(Name/Arity) :- 79 ( (var(Name) ; atom(Name)), 80 (var(Arity) ; integer(Arity), Arity >= 0 ) 81 -> 82 current_functor(Name, Arity, 0, 0) 83 ; 84 error(5, current_functor(Name/Arity)) 85 ). 86 87current_module(M) :- 88 var(M), !, 89 current_functor(M, 0, 1, 0), % atoms with properties only 90 is_a_module(M). 91current_module(M) :- 92 atom(M), !, 93 is_a_module(M). 94current_module(M) :- 95 error(5, current_module(M)). 96 97current_op_body(Preced, Assoc, Name, Module):- 98 legal_current_op(Preced, Assoc, Name, Module) 99 -> 100 ( var(Name) -> 101 current_functor(Name, 0, 1, 0) % atoms with properties only 102 ; 103 true 104 ), 105 ( 106 is_infix_op(Preced, Assoc, Name, _, Module) 107 ; 108 is_prefix_op(Preced, Assoc, Name, _, Module) 109 ; 110 is_postfix_op(Preced, Assoc, Name, _, Module) 111 ), 112 Preced \== 0 113 ; 114 get_bip_error(Err), 115 error(Err, current_op(Preced, Assoc, Name), Module). 116 117 118current_macro_body(Functor, Pred, List, PredModule, Module) :- 119 check_var_or_partial_macro_spec(Functor), 120 check_var_or_partial_qual_predspec(Pred), 121 check_var_or_partial_list(List), 122 check_var_or_atom(PredModule), 123 !, 124 current_macro_body1(Functor, Pred, List, PredModule, Module). 125current_macro_body(Functor, Pred, List, PredModule, Module) :- 126 bip_error(current_macro(Functor, Pred, List, PredModule), Module). 127 128current_macro_body1(Functor, Pred, List, PredModule, Module) :- 129 var(Functor), 130 !, 131 ( 132 current_functor(Name, Arity, 1, 0), % functors with properties only 133 Functor = Name/Arity 134 ; 135 current_type(T), 136 Functor = type(T) 137 ), 138 is_macro(Functor, Pred, List, PredModule, Module). 139current_macro_body1(Functor, Pred, List, PredModule, Module) :- 140 Functor = Name/Arity, 141 atom(Name), 142 integer(Arity), 143 !, 144 is_macro(Functor, Pred, List, PredModule, Module). 145current_macro_body1(Functor, Pred, List, PredModule, Module) :- 146 Functor = Name/Arity, 147 !, 148 current_functor(Name, Arity, 1, 0), 149 is_macro(Functor, Pred, List, PredModule, Module). 150current_macro_body1(Type, Pred, List, PredModule, Module) :- 151 Type = type(T), 152 current_type(T), 153 is_macro(Type, Pred, List, PredModule, Module). 154 155 156abolish_op_body(Operator, Assoc, Module) :- 157 abolish_op_(Operator, Assoc, Module) 158 -> 159 true 160 ; 161 get_bip_error(Error), 162 error(Error, abolish_op(Operator, Assoc), Module). 163 164 165matches_predspec(N/A) :- 166 ( var(N) -> true ; atom(N) ), 167 ( var(A) -> true ; integer(A), A >= 0, A =< 255 ). 168 169current_predicate_body(P, M):- 170 illegal_unlocked_module(M, Err), 171 !, 172 error(Err, current_predicate(P), M). 173current_predicate_body(P, M):- 174 P = N/A, 175 matches_predspec(P), 176 !, 177 ( nonground(P) -> 178 current_functor(N, A, 2, 0) % functors with predicates only 179 ; 180 true 181 ), 182 get_flag_body(P, defined, on, M), 183 get_flag_body(P, type, user, M). 184current_predicate_body(P, M):- 185 error(5, current_predicate(P), M). 186 187 188current_built_in_body(P, M):- 189 illegal_unlocked_module(M, Err), 190 !, 191 error(Err, current_built_in(P), M). 192current_built_in_body(P, M):- 193 P = N/A, 194 matches_predspec(P), 195 !, 196 ( nonground(P) -> 197 current_functor(N, A, 2, 0) % functors with predicates only 198 ; 199 true 200 ), 201 get_flag_body(P, defined, on, M), 202 get_flag_body(P, type, built_in, M). 203current_built_in_body(P, M):- 204 error(5, current_built_in(P), M). 205 206 207is_built_in_body(Functor, Module) :- 208 ( check_predspec(Functor, Module) -> 209 is_built_in_(Functor, Module) 210 ; 211 bip_error(is_built_in(Functor), Module) 212 ). 213 214 215%---------------------------------------------------------------------- 216% meta_predicate declaration 217%---------------------------------------------------------------------- 218 219:- export meta_predicate/1. 220:- tool(meta_predicate/1, meta_predicate_/2). 221:- local store(meta_predicate). 222 223meta_predicate_((Decl,Decls), Module) ?- !, 224 meta_predicate_single(Decl, Module), 225 meta_predicate_(Decls, Module). 226meta_predicate_(Decl, Module) :- 227 meta_predicate_single(Decl, Module). 228 229meta_predicate_single(Decl, Module) :- 230 check_callable(Decl), 231 functor(Decl, F, N), 232 functor(Meta, F, N), 233 functor(NewMode, F, N), 234 ( get_flag(F/N, mode, OldMode)@Module -> true ; functor(OldMode, F, N) ), 235 ( for(I,1,arity(Decl)), param(Decl,Meta,OldMode,NewMode) do 236 arg(I, Decl, Spec), 237 arg(I, Meta, MetaArg), 238 arg(I, OldMode, OldModeArg), 239 arg(I, NewMode, NewModeArg), 240 ( var(OldModeArg) -> OldModeArg = (?) ; true ), 241 check_meta_arg(Spec, MetaArg, OldModeArg, NewModeArg) 242 ), 243 !, 244 % mode/1 also takes care of creating the predicate if necessary 245 ( NewMode = (_,_) -> 246 mode((NewMode,NewMode))@Module % comma ambiguity... 247 ; 248 mode(NewMode)@Module 249 ), 250 store_set(meta_predicate, Module:F/N, Meta). 251meta_predicate_single(Decl, Module) :- 252 bip_error(meta_predicate(Decl))@Module. 253 254 :- mode check_meta_arg(?,-,+,-). 255 check_meta_arg(Arg, _, _, _) :- var(Arg), !, set_bip_error(4). 256 check_meta_arg(Arg, Arg, M, M) :- integer(Arg), check_integer_ge(Arg, 0). 257 check_meta_arg(:, :, M, M) :- !. 258 check_meta_arg(:-, :-, M, M) :- !. 259 check_meta_arg(/, /, M, M) :- !. 260 check_meta_arg(*, *, M, M) :- !. 261 check_meta_arg(+, *, _, +) :- !. 262 check_meta_arg(-, *, _, -) :- !. 263 check_meta_arg(?, *, _, ?) :- !. 264 check_meta_arg(++, *, _, ++) :- !. 265 check_meta_arg(Arg, _, _, _) :- atom(Arg), !, set_bip_error(6). 266 check_meta_arg(_, _, _, _) :- set_bip_error(5). 267 268 269erase_meta_predicates(Module) :- 270 store_erase_qualified(meta_predicate, Module). 271 272 273%---------------------------------------------------------------------- 274% Print predicate information 275%---------------------------------------------------------------------- 276 277als(Proc, Module) :- 278 (var(Proc) -> 279 error(4, als(Proc)) 280 ; 281 atom(Proc) -> 282 (current_predicate_body(Proc/Arity, Module) 283 ; 284 current_built_in_body(Proc/Arity, Module)), 285 als_(Proc/Arity, Module) 286 ; 287 Proc = _/A, var(A) -> 288 (current_predicate_body(Proc, Module) 289 ; 290 current_built_in_body(Proc, Module)), 291 als_(Proc, Module) 292 ; 293 als_(Proc, Module) 294 ). 295 296 297pred_body(Proc, M) :- 298 var(Proc), !, 299 error(4, pred(Proc), M). 300pred_body(Proc, M) :- 301 atom(Proc), !, 302 ( 303 ( current_predicate_body(Proc/A, M) 304 ; current_built_in_body(Proc/A, M) ), 305 nl, 306 pred_body(Proc/A, M), 307 fail 308 ; 309 true 310 ). 311pred_body(Proc, M) :- 312 Proc = _/_, !, 313 get_flag_body(Proc, _, _, M), % so that it fails if none visible 314 !, 315 ( 316 get_flag_body(Proc, F, V, M), 317 printf('%-20s%w%n', [F, V]), 318 fail 319 ; 320 true 321 ). 322pred_body(Proc, M) :- 323 error(5, pred(Proc), M). 324 325 326trimcore :- 327 % We do a garbage collection first because trimcore0 unmaps unsed 328 % parts of the stacks. The gc removes trail entries which point above 329 % the stack tops. Such entries could lead to segfaults when untrailing 330 % after unmapping the former stack space they point to. 331 garbage_collect, 332 % Now unmap space above stack tops, free abolished code, etc. 333 trimcore0. 334 335 336:- skipped 337 abolish_op/2, 338 current_built_in/1, 339 current_op/3, 340 current_predicate/1, 341 is_built_in/1, 342 pred/1. 343 344:- untraceable 345 (als)/1, 346 (als)/2, 347 pred/1. 348 349