From a82b1fed6f7e3bf26f455c5f34c2445dac0fce75 Mon Sep 17 00:00:00 2001 From: Theofrastos Mantadelis Date: Tue, 1 Feb 2011 12:02:57 +0100 Subject: [PATCH 01/12] A new library, namely concurrent alarms --- library/c_alarms.yap | 389 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 389 insertions(+) create mode 100644 library/c_alarms.yap diff --git a/library/c_alarms.yap b/library/c_alarms.yap new file mode 100644 index 000000000..235e3cace --- /dev/null +++ b/library/c_alarms.yap @@ -0,0 +1,389 @@ +%%% -*- Mode: Prolog; -*- + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% +% Concurrent alarms was developed at Katholieke Universiteit Leuven +% +% Copyright 2010 +% Katholieke Universiteit Leuven +% +% Contributions to this file: +% Author: Theofrastos Mantadelis +% Version: 0.1 +% Date: 01/02/2011 +% Comments: The timer implementation is inspired by Bernd Gutmann timers +% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% +% Artistic License 2.0 +% +% Copyright (c) 2000-2006, The Perl Foundation. +% +% Everyone is permitted to copy and distribute verbatim copies of this +% license document, but changing it is not allowed. Preamble +% +% This license establishes the terms under which a given free software +% Package may be copied, modified, distributed, and/or +% redistributed. The intent is that the Copyright Holder maintains some +% artistic control over the development of that Package while still +% keeping the Package available as open source and free software. +% +% You are always permitted to make arrangements wholly outside of this +% license directly with the Copyright Holder of a given Package. If the +% terms of this license do not permit the full use that you propose to +% make of the Package, you should contact the Copyright Holder and seek +% a different licensing arrangement. Definitions +% +% "Copyright Holder" means the individual(s) or organization(s) named in +% the copyright notice for the entire Package. +% +% "Contributor" means any party that has contributed code or other +% material to the Package, in accordance with the Copyright Holder's +% procedures. +% +% "You" and "your" means any person who would like to copy, distribute, +% or modify the Package. +% +% "Package" means the collection of files distributed by the Copyright +% Holder, and derivatives of that collection and/or of those files. A +% given Package may consist of either the Standard Version, or a +% Modified Version. +% +% "Distribute" means providing a copy of the Package or making it +% accessible to anyone else, or in the case of a company or +% organization, to others outside of your company or organization. +% +% "Distributor Fee" means any fee that you charge for Distributing this +% Package or providing support for this Package to another party. It +% does not mean licensing fees. +% +% "Standard Version" refers to the Package if it has not been modified, +% or has been modified only in ways explicitly requested by the +% Copyright Holder. +% +% "Modified Version" means the Package, if it has been changed, and such +% changes were not explicitly requested by the Copyright Holder. +% +% "Original License" means this Artistic License as Distributed with the +% Standard Version of the Package, in its current version or as it may +% be modified by The Perl Foundation in the future. +% +% "Source" form means the source code, documentation source, and +% configuration files for the Package. +% +% "Compiled" form means the compiled bytecode, object code, binary, or +% any other form resulting from mechanical transformation or translation +% of the Source form. +% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% +% Permission for Use and Modification Without Distribution +% +% (1) You are permitted to use the Standard Version and create and use +% Modified Versions for any purpose without restriction, provided that +% you do not Distribute the Modified Version. +% +% Permissions for Redistribution of the Standard Version +% +% (2) You may Distribute verbatim copies of the Source form of the +% Standard Version of this Package in any medium without restriction, +% either gratis or for a Distributor Fee, provided that you duplicate +% all of the original copyright notices and associated disclaimers. At +% your discretion, such verbatim copies may or may not include a +% Compiled form of the Package. +% +% (3) You may apply any bug fixes, portability changes, and other +% modifications made available from the Copyright Holder. The resulting +% Package will still be considered the Standard Version, and as such +% will be subject to the Original License. +% +% Distribution of Modified Versions of the Package as Source +% +% (4) You may Distribute your Modified Version as Source (either gratis +% or for a Distributor Fee, and with or without a Compiled form of the +% Modified Version) provided that you clearly document how it differs +% from the Standard Version, including, but not limited to, documenting +% any non-standard features, executables, or modules, and provided that +% you do at least ONE of the following: +% +% (a) make the Modified Version available to the Copyright Holder of the +% Standard Version, under the Original License, so that the Copyright +% Holder may include your modifications in the Standard Version. (b) +% ensure that installation of your Modified Version does not prevent the +% user installing or running the Standard Version. In addition, the +% modified Version must bear a name that is different from the name of +% the Standard Version. (c) allow anyone who receives a copy of the +% Modified Version to make the Source form of the Modified Version +% available to others under (i) the Original License or (ii) a license +% that permits the licensee to freely copy, modify and redistribute the +% Modified Version using the same licensing terms that apply to the copy +% that the licensee received, and requires that the Source form of the +% Modified Version, and of any works derived from it, be made freely +% available in that license fees are prohibited but Distributor Fees are +% allowed. +% +% Distribution of Compiled Forms of the Standard Version or +% Modified Versions without the Source +% +% (5) You may Distribute Compiled forms of the Standard Version without +% the Source, provided that you include complete instructions on how to +% get the Source of the Standard Version. Such instructions must be +% valid at the time of your distribution. If these instructions, at any +% time while you are carrying out such distribution, become invalid, you +% must provide new instructions on demand or cease further +% distribution. If you provide valid instructions or cease distribution +% within thirty days after you become aware that the instructions are +% invalid, then you do not forfeit any of your rights under this +% license. +% +% (6) You may Distribute a Modified Version in Compiled form without the +% Source, provided that you comply with Section 4 with respect to the +% Source of the Modified Version. +% +% Aggregating or Linking the Package +% +% (7) You may aggregate the Package (either the Standard Version or +% Modified Version) with other packages and Distribute the resulting +% aggregation provided that you do not charge a licensing fee for the +% Package. Distributor Fees are permitted, and licensing fees for other +% components in the aggregation are permitted. The terms of this license +% apply to the use and Distribution of the Standard or Modified Versions +% as included in the aggregation. +% +% (8) You are permitted to link Modified and Standard Versions with +% other works, to embed the Package in a larger work of your own, or to +% build stand-alone binary or bytecode versions of applications that +% include the Package, and Distribute the result without restriction, +% provided the result does not expose a direct interface to the Package. +% +% Items That are Not Considered Part of a Modified Version +% +% (9) Works (including, but not limited to, modules and scripts) that +% merely extend or make use of the Package, do not, by themselves, cause +% the Package to be a Modified Version. In addition, such works are not +% considered parts of the Package itself, and are not subject to the +% terms of this license. +% +% General Provisions +% +% (10) Any use, modification, and distribution of the Standard or +% Modified Versions is governed by this Artistic License. By using, +% modifying or distributing the Package, you accept this license. Do not +% use, modify, or distribute the Package, if you do not accept this +% license. +% +% (11) If your Modified Version has been derived from a Modified Version +% made by someone other than you, you are nevertheless required to +% ensure that your Modified Version complies with the requirements of +% this license. +% +% (12) This license does not grant you the right to use any trademark, +% service mark, tradename, or logo of the Copyright Holder. +% +% (13) This license includes the non-exclusive, worldwide, +% free-of-charge patent license to make, have made, use, offer to sell, +% sell, import and otherwise transfer the Package with respect to any +% patent claims licensable by the Copyright Holder that are necessarily +% infringed by the Package. If you institute patent litigation +% (including a cross-claim or counterclaim) against any party alleging +% that the Package constitutes direct or contributory patent +% infringement, then this Artistic License to you shall terminate on the +% date that such litigation is filed. +% +% (14) Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT +% HOLDER AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED +% WARRANTIES. THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A +% PARTICULAR PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT +% PERMITTED BY YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT +% HOLDER OR CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, +% INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE +% OF THE PACKAGE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +:- module(c_alarms, [set_alarm/3, + unset_alarm/1, + time_out_call/3, + timer_start/1, + timer_restart/1, + timer_stop/2, + timer_elapsed/2, + timer_pause/2]). + +% set_alarm(+Seconds, +Execute, -ID) +% calls Executes after a time interval of Seconds +% ID is returned to be able to unset the alarm (the call will not be executed) +% set_alarm/3 supports multiple & nested settings of alarms. +% Known Bug: There is the case that an alarm might trigger +-1 second of the set time. +% +% unset_alarm(+ID) +% It will unschedule the alarm. +% It will not affect other concurrent alarms. +% +% time_out_call(+Seconds, +Goal, -Return) +% It will will execute the closure Goal and returns its success or failure at Return. +% If the goal times out in Seconds then Return = timeout. + +:- use_module(library(lists), [member/2, memberchk/2, delete/3]). +:- use_module(library(ordsets), [ord_add_element/3]). +:- use_module(library(apply_macros), [maplist/3]). +:- initialization(local_init). + +local_init:- + bb_put(alarms, []), + bb_put(identity, 0). + +:- meta_predicate(set_alarm(+, 0, -)). +:- meta_predicate(time_out_call(+, 0, -)). + +get_next_identity(ID):- + bb_get(identity, ID), + NID is ID + 1, + bb_put(identity, NID). + +set_alarm(Seconds, Execute, ID):- + bb_get(alarms, []), + get_next_identity(ID), !, + bb_put(alarms, [alarm(Seconds, ID, Execute)]), + alarm(Seconds, alarm_handler, _). +set_alarm(Seconds, Execute, ID):- + get_next_identity(ID), !, + bb_get(alarms, [alarm(CurrentSeconds, CurrentID, CurrentExecute)|Alarms]), + alarm(0, true, Remaining), + Elapsed is CurrentSeconds - Remaining - 1, + maplist(subtract(Elapsed), [alarm(CurrentSeconds, CurrentID, CurrentExecute)|Alarms], RemainingAlarms), + ord_add_element(RemainingAlarms, alarm(Seconds, ID, Execute), [alarm(NewSeconds, NewID, NewToExecute)|NewAlarms]), + bb_put(alarms, [alarm(NewSeconds, NewID, NewToExecute)|NewAlarms]), + alarm(NewSeconds, alarm_handler, _). +set_alarm(Seconds, Execute, ID):- + throw(error(permission_error(create, alarm, set_alarm(Seconds, Execute, ID)), 'Non permitted alarm identifier.')). + +subtract(Elapsed, alarm(Seconds, ID, Execute), alarm(NewSeconds, ID, Execute)):- + NewSeconds is Seconds - Elapsed. + +unset_alarm(ID):- + \+ ground(ID), + throw(error(instantiation_error, 'Alarm ID needs to be instantiated.')). +unset_alarm(ID):- + bb_get(alarms, Alarms), + memberchk(alarm(_Seconds, ID, _Execute), Alarms), + throw(error(existence_error(alarm, unset_alarm(ID)), 'Alarm does not exist.')). +unset_alarm(ID):- + alarm(0, true, Remaining), + bb_get(alarms, Alarms), + delete_alarm(Alarms, ID, NewAlarms), + bb_put(alarms, NewAlarms), + (NewAlarms = [alarm(Seconds, _, _)|_] -> + alarm(Seconds, alarm_handler, _) + ; + true + ). + +delete_alarm(Alarms, ID, NewAlarms):- + memberchk(alarm(Seconds, ID, Execute), Alarms), + delete(Alarms, alarm(Seconds, ID, Execute), NewAlarms). + +alarm_handler:- + bb_get(alarms, [alarm(_, _, CurrentExecute)|[]]), + bb_put(alarms, []), + call(CurrentExecute). +alarm_handler:- + bb_get(alarms, [alarm(Elapsed, CurrentID, CurrentExecute)|Alarms]), + maplist(subtract(Elapsed), Alarms, NewAlarms), + find_zeros(NewAlarms, ZeroAlarms), + findall(alarm(S, ID, E), (member(alarm(S, ID, E), NewAlarms), S > 0), NonZeroAlarms), + bb_put(alarms, NonZeroAlarms), + (NonZeroAlarms = [alarm(NewSeconds, _, _)|_] -> + alarm(NewSeconds, alarm_handler, _) + ; + true + ), + execute([alarm(0, CurrentID, CurrentExecute)|ZeroAlarms]). + +find_zeros([], []). +find_zeros([alarm(0, ID, E)|T], [alarm(0, ID, E)|R]):- + find_zeros(T, R). +find_zeros([alarm(S, _, _)|T], R):- + S > 0, + find_zeros(T, R). + +execute([]). +execute([alarm(_, _, Execute)|R]):- + call(Execute), + execute(R). + +time_out_call(Seconds, Goal, Return):- + bb_get(identity, ID), + catch(( + (set_alarm(Seconds, throw(timeout(ID)), ID) ; unset_alarm(ID), fail), + Goal, + unset_alarm(ID), + Return = success) + , Exception, ( + (Exception == timeout(ID) -> + Return = timeout + ; + unset_alarm(ID), + throw(Exception) + ))). + +:- dynamic('$timer'/3). + +timer_start(Name):- + \+ ground(Name), + throw(error(instantiation_error, 'Timer name needs to be instantiated.')). +timer_start(Name):- + '$timer'(Name, _, _), + throw(error(permission_error(create, timer, timer_start(Name)), 'Timer already exists.')). +timer_start(Name):- + statistics(walltime, [StartTime, _]), + assertz('$timer'(Name, running, StartTime)). + +timer_restart(Name):- + \+ ground(Name), + throw(error(instantiation_error, 'Timer name needs to be instantiated.')). +timer_restart(Name):- + \+ '$timer'(Name, _, _), !, + statistics(walltime, [StartTime, _]), + assertz('$timer'(Name, running, StartTime)). +timer_restart(Name):- + retract('$timer'(Name, running, _)), !, + statistics(walltime, [StartTime, _]), + assertz('$timer'(Name, running, StartTime)). +timer_restart(Name):- + retract('$timer'(Name, paused, Duration)), + statistics(walltime, [StartTime, _]), + Elapsed is StartTime - Duration, + assertz('$timer'(Name, running, Elapsed)). + +timer_stop(Name, Elapsed):- + \+ '$timer'(Name, _, _), + throw(error(existence_error(timer, timer_stop(Name, Elapsed)), 'Timer does not exist.')). +timer_stop(Name, Elapsed):- + retract('$timer'(Name, running, StartTime)), !, + statistics(walltime, [EndTime, _]), + Elapsed is EndTime - StartTime. +timer_stop(Name, Elapsed):- + retract('$timer'(Name, paused, Elapsed)). + +timer_elapsed(Name, Elapsed):- + \+ '$timer'(Name, _, _), + throw(error(existence_error(timer, timer_elapsed(Name, Elapsed)), 'Timer does not exist.')). +timer_elapsed(Name, Elapsed):- + '$timer'(Name, running, StartTime), !, + statistics(walltime, [EndTime, _]), + Elapsed is EndTime - StartTime. +timer_elapsed(Name, Elapsed):- + '$timer'(Name, paused, Elapsed). + +timer_pause(Name, Elapsed):- + \+ '$timer'(Name, _, _), + throw(error(existence_error(timer, timer_pause(Name, Elapsed)), 'Timer does not exist.')). +timer_pause(Name, Elapsed):- + '$timer'(Name, paused, _), + throw(error(permission_error(timer, timer_pause(Name, Elapsed)), 'Timer already paused.')). +timer_pause(Name, Elapsed):- + retract('$timer'(Name, _, StartTime)), + statistics(walltime, [EndTime, _]), + Elapsed is EndTime - StartTime, + assert('$timer'(Name, paused, Elapsed)). From b73a93f26adc99225cecc575dac1d0b224a819a9 Mon Sep 17 00:00:00 2001 From: Theofrastos Mantadelis Date: Tue, 1 Feb 2011 12:05:35 +0100 Subject: [PATCH 02/12] fixed the makefile... --- library/Makefile.in | 1 + 1 file changed, 1 insertion(+) diff --git a/library/Makefile.in b/library/Makefile.in index 6053c0ca3..442046a5f 100644 --- a/library/Makefile.in +++ b/library/Makefile.in @@ -77,6 +77,7 @@ PROGRAMS= \ $(srcdir)/wundgraphs.yap \ $(srcdir)/lam_mpi.yap \ $(srcdir)/ypp.yap \ + $(srcdir)/c_alarms.yap \ $(srcdir)/block_diagram.yap MYDDAS_PROGRAMS= $(srcdir)/MYDDAS/myddas.ypp \ From 73918e78aa2e8ab9e673166a3b83e4a7a1569b84 Mon Sep 17 00:00:00 2001 From: Theofrastos Mantadelis Date: Tue, 1 Feb 2011 12:13:42 +0100 Subject: [PATCH 03/12] Added flags library --- library/Makefile.in | 1 + library/flags.yap | 561 ++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 562 insertions(+) create mode 100644 library/flags.yap diff --git a/library/Makefile.in b/library/Makefile.in index 442046a5f..bab726884 100644 --- a/library/Makefile.in +++ b/library/Makefile.in @@ -78,6 +78,7 @@ PROGRAMS= \ $(srcdir)/lam_mpi.yap \ $(srcdir)/ypp.yap \ $(srcdir)/c_alarms.yap \ + $(srcdir)/flags.yap \ $(srcdir)/block_diagram.yap MYDDAS_PROGRAMS= $(srcdir)/MYDDAS/myddas.ypp \ diff --git a/library/flags.yap b/library/flags.yap new file mode 100644 index 000000000..9e4b047e8 --- /dev/null +++ b/library/flags.yap @@ -0,0 +1,561 @@ +%%% -*- Mode: Prolog; -*- + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% +% Flags was developed at Katholieke Universiteit Leuven +% +% Copyright 2010 +% Katholieke Universiteit Leuven +% +% Contributions to this file: +% Author: Theofrastos Mantadelis +% Sugestions: Bernd Gutmann, Paulo Moura +% Version: 0.1 +% Date: 19/11/2010 +% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% +% Artistic License 2.0 +% +% Copyright (c) 2000-2006, The Perl Foundation. +% +% Everyone is permitted to copy and distribute verbatim copies of this +% license document, but changing it is not allowed. Preamble +% +% This license establishes the terms under which a given free software +% Package may be copied, modified, distributed, and/or +% redistributed. The intent is that the Copyright Holder maintains some +% artistic control over the development of that Package while still +% keeping the Package available as open source and free software. +% +% You are always permitted to make arrangements wholly outside of this +% license directly with the Copyright Holder of a given Package. If the +% terms of this license do not permit the full use that you propose to +% make of the Package, you should contact the Copyright Holder and seek +% a different licensing arrangement. Definitions +% +% "Copyright Holder" means the individual(s) or organization(s) named in +% the copyright notice for the entire Package. +% +% "Contributor" means any party that has contributed code or other +% material to the Package, in accordance with the Copyright Holder's +% procedures. +% +% "You" and "your" means any person who would like to copy, distribute, +% or modify the Package. +% +% "Package" means the collection of files distributed by the Copyright +% Holder, and derivatives of that collection and/or of those files. A +% given Package may consist of either the Standard Version, or a +% Modified Version. +% +% "Distribute" means providing a copy of the Package or making it +% accessible to anyone else, or in the case of a company or +% organization, to others outside of your company or organization. +% +% "Distributor Fee" means any fee that you charge for Distributing this +% Package or providing support for this Package to another party. It +% does not mean licensing fees. +% +% "Standard Version" refers to the Package if it has not been modified, +% or has been modified only in ways explicitly requested by the +% Copyright Holder. +% +% "Modified Version" means the Package, if it has been changed, and such +% changes were not explicitly requested by the Copyright Holder. +% +% "Original License" means this Artistic License as Distributed with the +% Standard Version of the Package, in its current version or as it may +% be modified by The Perl Foundation in the future. +% +% "Source" form means the source code, documentation source, and +% configuration files for the Package. +% +% "Compiled" form means the compiled bytecode, object code, binary, or +% any other form resulting from mechanical transformation or translation +% of the Source form. +% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% +% Permission for Use and Modification Without Distribution +% +% (1) You are permitted to use the Standard Version and create and use +% Modified Versions for any purpose without restriction, provided that +% you do not Distribute the Modified Version. +% +% Permissions for Redistribution of the Standard Version +% +% (2) You may Distribute verbatim copies of the Source form of the +% Standard Version of this Package in any medium without restriction, +% either gratis or for a Distributor Fee, provided that you duplicate +% all of the original copyright notices and associated disclaimers. At +% your discretion, such verbatim copies may or may not include a +% Compiled form of the Package. +% +% (3) You may apply any bug fixes, portability changes, and other +% modifications made available from the Copyright Holder. The resulting +% Package will still be considered the Standard Version, and as such +% will be subject to the Original License. +% +% Distribution of Modified Versions of the Package as Source +% +% (4) You may Distribute your Modified Version as Source (either gratis +% or for a Distributor Fee, and with or without a Compiled form of the +% Modified Version) provided that you clearly document how it differs +% from the Standard Version, including, but not limited to, documenting +% any non-standard features, executables, or modules, and provided that +% you do at least ONE of the following: +% +% (a) make the Modified Version available to the Copyright Holder of the +% Standard Version, under the Original License, so that the Copyright +% Holder may include your modifications in the Standard Version. (b) +% ensure that installation of your Modified Version does not prevent the +% user installing or running the Standard Version. In addition, the +% modified Version must bear a name that is different from the name of +% the Standard Version. (c) allow anyone who receives a copy of the +% Modified Version to make the Source form of the Modified Version +% available to others under (i) the Original License or (ii) a license +% that permits the licensee to freely copy, modify and redistribute the +% Modified Version using the same licensing terms that apply to the copy +% that the licensee received, and requires that the Source form of the +% Modified Version, and of any works derived from it, be made freely +% available in that license fees are prohibited but Distributor Fees are +% allowed. +% +% Distribution of Compiled Forms of the Standard Version or +% Modified Versions without the Source +% +% (5) You may Distribute Compiled forms of the Standard Version without +% the Source, provided that you include complete instructions on how to +% get the Source of the Standard Version. Such instructions must be +% valid at the time of your distribution. If these instructions, at any +% time while you are carrying out such distribution, become invalid, you +% must provide new instructions on demand or cease further +% distribution. If you provide valid instructions or cease distribution +% within thirty days after you become aware that the instructions are +% invalid, then you do not forfeit any of your rights under this +% license. +% +% (6) You may Distribute a Modified Version in Compiled form without the +% Source, provided that you comply with Section 4 with respect to the +% Source of the Modified Version. +% +% Aggregating or Linking the Package +% +% (7) You may aggregate the Package (either the Standard Version or +% Modified Version) with other packages and Distribute the resulting +% aggregation provided that you do not charge a licensing fee for the +% Package. Distributor Fees are permitted, and licensing fees for other +% components in the aggregation are permitted. The terms of this license +% apply to the use and Distribution of the Standard or Modified Versions +% as included in the aggregation. +% +% (8) You are permitted to link Modified and Standard Versions with +% other works, to embed the Package in a larger work of your own, or to +% build stand-alone binary or bytecode versions of applications that +% include the Package, and Distribute the result without restriction, +% provided the result does not expose a direct interface to the Package. +% +% Items That are Not Considered Part of a Modified Version +% +% (9) Works (including, but not limited to, modules and scripts) that +% merely extend or make use of the Package, do not, by themselves, cause +% the Package to be a Modified Version. In addition, such works are not +% considered parts of the Package itself, and are not subject to the +% terms of this license. +% +% General Provisions +% +% (10) Any use, modification, and distribution of the Standard or +% Modified Versions is governed by this Artistic License. By using, +% modifying or distributing the Package, you accept this license. Do not +% use, modify, or distribute the Package, if you do not accept this +% license. +% +% (11) If your Modified Version has been derived from a Modified Version +% made by someone other than you, you are nevertheless required to +% ensure that your Modified Version complies with the requirements of +% this license. +% +% (12) This license does not grant you the right to use any trademark, +% service mark, tradename, or logo of the Copyright Holder. +% +% (13) This license includes the non-exclusive, worldwide, +% free-of-charge patent license to make, have made, use, offer to sell, +% sell, import and otherwise transfer the Package with respect to any +% patent claims licensable by the Copyright Holder that are necessarily +% infringed by the Package. If you institute patent litigation +% (including a cross-claim or counterclaim) against any party alleging +% that the Package constitutes direct or contributory patent +% infringement, then this Artistic License to you shall terminate on the +% date that such litigation is filed. +% +% (14) Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT +% HOLDER AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED +% WARRANTIES. THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A +% PARTICULAR PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT +% PERMITTED BY YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT +% HOLDER OR CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, +% INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE +% OF THE PACKAGE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + +:- module(flags, [flag_define/2, + flag_define/5, + flag_define/7, + flag_set/2, + flag_set/3, + flag_unsafe_set/2, + flag_get/2, + flags_reset/0, + flags_reset/1, + flags_save/1, + flags_load/1, + flag_groups/1, + flag_group_chk/1, + flag_help/0, + flags_print/0, + defined_flag/7]). + +:- use_module(library(lists), [append/3, memberchk/2, member/2]). + +:- style_check(all). +:- yap_flag(unknown, error). + +:- dynamic(['$defined_flag$'/7, '$store_flag_value$'/2]). +:- meta_predicate(flag_define(+, +, +, ?, ?, ?, :)). +:- meta_predicate(flag_define(+, :)). +:- meta_predicate(validate(+, :, ?, +)). +:- multifile(flags_type_definition/3). + +flag_define(FlagName, InputOptions):- + strip_module(InputOptions, Module, UserOptions), + Defaults = [flag_group(general), flag_type(nonvar), default_value(true), description(FlagName), access(read_write), handler(true)], + append(UserOptions, Defaults, Options), + memberchk(flag_group(FlagGroup), Options), + memberchk(flag_type(FlagType), Options), + memberchk(default_value(DefaultValue), Options), + memberchk(description(Description), Options), + memberchk(access(Access), Options), + memberchk(handler(Handler), Options), + flag_define(FlagName, FlagGroup, FlagType, DefaultValue, Description, Access, Module:Handler). + +flag_define(FlagName, FlagGroup, FlagType, DefaultValue, Description):- + flag_define(FlagName, FlagGroup, FlagType, DefaultValue, Description, read_write, true). + +flag_define(FlagName, FlagGroup, FlagType, DefaultValue, Description, Access, MHandler):- + strip_module(MHandler, Module, Handler), + nonvar(FlagName), + nonvar(FlagGroup), + nonvar(FlagType), + nonvar(Access), + nonvar(Handler), !, + (\+ atom(FlagName) -> + throw(error(type_error(atom, FlagName), message('Flag name needs to be an atom.', flag_define(FlagName, FlagGroup, FlagType, DefaultValue, Description, Access, Module:Handler)))) + ; \+ atom(FlagGroup) -> + throw(error(type_error(atom, FlagGroup), message('Flag group needs to be an atom.', flag_define(FlagName, FlagGroup, FlagType, DefaultValue, Description, Access, Module:Handler)))) + ; \+ flag_type(FlagType) -> + throw(error(domain_error(flag_type, FlagType), message('Unknown flag type.', flag_define(FlagName, FlagGroup, FlagType, DefaultValue, Description, Module:Handler)))) + ; \+ validate_type(FlagType) -> + throw(error(evaluation_error(type_validation), message('Validation of flag type failed, check custom domain.', flag_define(FlagName, FlagGroup, FlagType, DefaultValue, Description, Access, Module:Handler)))) + ; '$defined_flag$'(FlagName, _FlagGroup, _FlagType, _DefaultValue, _Description, _Access, _Handler) -> + throw(error(permission_error(create, flag, FlagName), message('Re-defining a flag is not allowed.', flag_define(FlagName, FlagGroup, FlagType, DefaultValue, Description, Access, Module:Handler)))) + ; \+ memberchk(Access, [read_write, read_only, hidden, hidden_read_only]), + throw(error(domain_error(access, Access), message('Wrong access attribute, available are: read_write, read_only, hidden, hidden_read_only.', flag_define(FlagName, FlagGroup, FlagType, DefaultValue, Description, Access, Module:Handler)))) + ; \+ callable(Handler) -> + throw(error(type_error(callable, Handler), message('Flag handler needs to be callable.', flag_define(FlagName, FlagGroup, FlagType, DefaultValue, Description, Access, Module:Handler)))) + ; + validate(FlagType, Module:Handler, DefaultValue, FlagName), + assertz('$defined_flag$'(FlagName, FlagGroup, FlagType, DefaultValue, Description, Access, Module:Handler)), + assertz('$store_flag_value$'(FlagName, DefaultValue)), + (Handler == true -> + true + ; + call(Module:Handler, stored, DefaultValue) + ) + ). +flag_define(FlagName, FlagGroup, FlagType, DefaultValue, Description, Access, Handler):- + throw(error(instantiation_error, message('Flag name, group, type, access and handler need to be instantiated.', flag_define(FlagName, FlagGroup, FlagType, DefaultValue, Description, Access, Handler)))). + +flag_groups(FlagGroups):- + all(FlagGroup, ('$defined_flag$'(_FlagName, FlagGroup, _FlagType, _DefaultValue, _Description, Access, _Handler), Access \== hidden, Access \== hidden_read_only), FlagGroups). + +flag_group_chk(FlagGroup):- + nonvar(FlagGroup), + '$defined_flag$'(_FlagName, FlagGroup, _FlagType, _DefaultValue, _Description, _Access, _Handler), !. + +flag_type(Type):- + flags_type_definition(Type, _, _). + +% flags_type_definition(TypeName, TypeHandler, TypeValidator). +flags_type_definition(nonvar, nonvar, true). +flags_type_definition(atom, atom, true). +flags_type_definition(atomic, atomic, true). +flags_type_definition(integer, integer, true). +flags_type_definition(float, float, true). +flags_type_definition(number, number, true). +flags_type_definition(ground, ground, true). +flags_type_definition(compound, compound, true). +flags_type_definition(is_list, is_list, true). +flags_type_definition(callable, callable, true). +flags_type_definition(in_interval(Type, Interval), in_interval(Type, Interval), in_interval(Type, Interval)). +flags_type_definition(integer_in_interval(Interval), in_interval(integer, Interval), in_interval(integer, Interval)). +flags_type_definition(positive_integer, in_interval(integer, (0, (+inf))), true). +flags_type_definition(non_negative_integer, in_interval(integer, ([0], (+inf))), true). +flags_type_definition(negative_integer, in_interval(integer, ((-inf), 0)), true). +flags_type_definition(float_in_interval(Interval), in_interval(float, Interval), in_interval(float, Interval)). +flags_type_definition(positive_float, in_interval(float, (0.0, (+inf))), true). +flags_type_definition(non_negative_float, in_interval(float, ([0.0], (+inf))), true). +flags_type_definition(negative_float, in_interval(float, ((-inf), 0.0)), true). +flags_type_definition(number_in_interval(Interval), in_interval(number, Interval), in_interval(number, Interval)). +flags_type_definition(positive_number, in_interval(number, (0.0, (+inf))), true). +flags_type_definition(non_negative_number, in_interval(number, ([0.0], (+inf))), true). +flags_type_definition(negative_number, in_interval(number, ((-inf), 0.0)), true). +flags_type_definition(in_domain(Domain), in_domain(Domain), in_domain(Domain)). +flags_type_definition(boolean, in_domain([true, false]), true). +flags_type_definition(switch, in_domain([on, off]), true). + +in_domain(Domain):- + ground(Domain), + is_list(Domain). +in_domain(Domain, Value):- + ground(Value), + memberchk(Value, Domain). + +in_interval(Type, Interval):- + is_list(Interval), !, + Interval \== [], + in_interval_conj(Type, Interval). +in_interval(Type, Interval):- + in_interval_single(Type, Interval). + +in_interval_conj(_Type, []). +in_interval_conj(Type, [Interval|Rest]):- + in_interval_single(Type, Interval), + in_interval_conj(Type, Rest). + +in_interval_single(Type, ([Min], [Max])):- + !, call(Type, Min), + call(Type, Max), + Min =< Max. + +in_interval_single(Type, ([Min], Max)):- + !, call(Type, Min), + call(Type, Max), + Min < Max. + +in_interval_single(Type, (Min, [Max])):- + !, call(Type, Min), + call(Type, Max), + Min < Max. + +in_interval_single(Type, (Min, Max)):- + call(Type, Min), + call(Type, Max), + Min < Max, + Max - Min > 0.0. + +in_interval(Type, [Interval|_Rest], Value):- + in_interval(Type, Interval, Value), !. +in_interval(Type, [_Interval|Rest], Value):- + in_interval(Type, Rest, Value). + +in_interval(Type, ([Min], [Max]), Value):- + !, call(Type, Value), + Value >= Min, + Value =< Max. + +in_interval(Type, ([Min], Max), Value):- + !, call(Type, Value), + Value >= Min, + Value < Max. + +in_interval(Type, (Min, [Max]), Value):- + !, call(Type, Value), + Value > Min, + Value =< Max. + +in_interval(Type, (Min, Max), Value):- + call(Type, Value), + Value > Min, + Value < Max. + +validate_type(Type):- + flags_type_definition(Type, _, TypeValidater), + call(TypeValidater). + +validate(FlagType, Handler, Value, FlagName):- + strip_module(Handler, _Module, true), + !, flags_type_definition(FlagType, FlagValidator, _), + (call(FlagValidator, Value) -> + true + ; + throw(error(validation_error(FlagType, Value), message('Validation of value fails.', validate(FlagType, Value, FlagName)))) + ). +validate(FlagType, Handler, Value, FlagName):- + flags_type_definition(FlagType, FlagValidator, _), + ((call(Handler, validating, Value), (call(FlagValidator, Value); call(Handler, validate, Value))) -> + call(Handler, validated, Value) + ; + throw(error(validation_error(FlagType, Value), message('Validation of value fails.', validate(FlagType, Handler, Value, FlagName)))) + ). + +flag_set(FlagName, FlagValue):- + flag_set(FlagName, _OldValue, FlagValue). +flag_set(FlagName, OldValue, FlagValue):- + atom(FlagName), + '$defined_flag$'(FlagName, _FlagGroup, FlagType, _DefaultValue, _Description, Access, Module:Handler), !, + (Access \== read_only, Access \== hidden_read_only -> + validate(FlagType, Module:Handler, FlagValue, FlagName), + retract('$store_flag_value$'(FlagName, OldValue)), + assertz('$store_flag_value$'(FlagName, FlagValue)), + (Handler == true -> + true + ; + call(Module:Handler, stored, FlagValue) + ) + ; + throw(error(permission_error(set, flag, FlagName), message('Setting the flag value is not allowed.',flag_set(FlagName, OldValue, FlagValue)))) + ). +flag_set(FlagName, OldValue, FlagValue):- + throw(error(existence_error(flag, FlagName), message('The flag is not defined.', flag_set(FlagName, OldValue, FlagValue)))). + +flag_unsafe_set(FlagName, FlagValue):- + retract('$store_flag_value$'(FlagName, _)), + assertz('$store_flag_value$'(FlagName, FlagValue)). + +flag_get(FlagName, FlagValue):- + '$store_flag_value$'(FlagName, FlagValue). +flag_get(FlagName, FlagValue):- + \+ '$store_flag_value$'(FlagName, _), + throw(error(existence_error(flag, FlagName), message('The flag is not defined.', flag_get(FlagName, FlagValue)))). + +flags_reset:- + retractall('$store_flag_value$'(_, _)), + '$defined_flag$'(FlagName, _FlagGroup, _FlagType, DefaultValue, _Description, _Access, Module:Handler), + assertz('$store_flag_value$'(FlagName, DefaultValue)), + (Handler == true -> + true + ; + call(Module:Handler, stored, DefaultValue) + ), + fail. +flags_reset. + +flags_reset(FlagGroup):- + '$defined_flag$'(FlagName, FlagGroup, _FlagType, DefaultValue, _Description, _Access, Module:Handler), + retractall('$store_flag_value$'(FlagName, _)), + assertz('$store_flag_value$'(FlagName, DefaultValue)), + (Handler == true -> + true + ; + call(Module:Handler, stored, DefaultValue) + ), + fail. +flags_reset(_). + +flags_save(FileName):- + tell(FileName), + catch(('$store_flag_value$'(FlagName, Value), + write_canonical('$store_flag_value$'(FlagName, Value)), + write('.'), nl), + Exception, clean_and_throw(told, Exception)), + fail. +flags_save(_FileName):- + told. + +flags_load(FileName):- + see(FileName), + catch((read('$store_flag_value$'(FlagName, Value)), + flag_set(FlagName, Value)), + Exception, clean_and_throw(seen, Exception)), + fail. +flags_load(_FileName):- + seen. + +clean_and_throw(Action, Exception):- + Action, + throw(Exception). + +flag_help:- + format('This is a short tutorial for the flags library.~nExported predicates:~n'), + format(' flag_define/5 : defines a new flag without a handler~n'), + format(' flag_define(FlagName, FlagGroup, FlagType, DefaultValue, Description)~n'), + format(' flag_define/6 : defines a new flag with a handler~n'), + format(' flag_define(FlagName, FlagGroup, FlagType, DefaultValue, Description, Handler)~n'), + format(' FlagName : the name of the flag~n'), + format(' FlagGroup : the name of the flag group~n'), + format(' FlagType : the type of the flag available types are:~n'), + flag_help_types, + format(' DefaultValue : the default value for the flag~n'), + format(' Description : a flag description~n'), + format(' Handler : a handler~n'), + flags:flag_help_handler, + format(' flag_groups/1 : returns all the flag groups in a list~n'), + format(' flag_group_chk/1 : checks if a group exists~n'), + format(' flag_set/2 : sets the value of a flag~n'), + format(' flag_get/2 : gets the value of a flag~n'), + format(' flag_store/2 : sets the value of a flag ignoring all tests and handlers~n'), + format(' flag_reset/0 : resets all flags to their default value~n'), + format(' flag_reset/1 : resets all flags of a group to their default value~n'), + format(' flag_help/0 : this screen~n'), + format(' flags_print/0 : shows the current flags/values~n'). +flag_help_types:- + flag_type(FlagType), + format(' ~w~n', [FlagType]), + fail. +flag_help_types. + +flag_help_handler:- + format(' Handler important notes:~n'), + format(' Conjuction: external_handler(validating, Value):-...~n'), + format(' Disjunction: external_handler(validate, Value):-...~n'), + format(' After: external_handler(validated, Value):-...~n'), + format(' After set: external_handler(stored, Value):-...~n'), + format(' this is implemented as (validating,(original;validated))~n'), + format(' validating|original|validate|result~n'), + format(' true | true | true | true~n'), + format(' true | true | fail | true~n'), + format(' true | fail | true | true~n'), + format(' true | fail | fail | fail~n'), + format(' fail | true | true | fail~n'), + format(' fail | true | fail | fail~n'), + format(' fail | fail | true | fail~n'), + format(' fail | fail | fail | fail~n'), + format(' Default behaviour is validating->true, validate->fail~n'), + format(' To completly replace original set validate->true~n'), + format(' To add new values to original set validating->true~n'), + format(' To remove values from original set validate->fail~n'), + format(' Example definition with a handler:~n'), + format(' flag_define(myflag, mygroup, in_interval(integer, [(-5, 5),([15],[25])]), 0, description, my_handler).~n'), + format(' my_handler(validate, Value):-Value is 10.~n'), + format(' my_handler(validating, Value).~n'), + format(' my_handler(validated, Value).~n'), + format(' my_handler(stored, Value).~n'), + format(' This has defined a flag that accepts integers (-5,5)v[15,25].~n'), + format(' The handler adds the value 10 in those.~n'). + +flags_print:- + flag_groups(Groups), + forall(member(Group, Groups), flags_print(Group)). +flags_print(Group):- + format(' ~w:~n~w~38+ ~w~19+ ~w~10+ ~w~10+~n', [Group, 'Description', 'Domain', 'Flag', 'Value']), + fail. +flags_print(FlagGroup):- + '$defined_flag$'(FlagName, FlagGroup, FlagType, _DefaultValue, Description, Access, _Handler), + Access \== hidden, Access \== hidden_read_only, + flag_get(FlagName, Value), + format('~w~38+ ~w~19+ ~w~10+ ~q~10+~n', [Description, FlagType, FlagName, Value]), + fail. +flags_print(_). + +defined_flag(FlagName, FlagGroup, FlagType, DefaultValue, Description, Access, Handler):- + '$defined_flag$'(FlagName, FlagGroup, FlagType, DefaultValue, Description, Access, Handler), + Access \== hidden, Access \== hidden_read_only. +defined_flag(FlagName, FlagGroup, FlagType, DefaultValue, Description, Access, Handler):- + nonvar(FlagName), nonvar(FlagGroup), + '$defined_flag$'(FlagName, FlagGroup, FlagType, DefaultValue, Description, Access, Handler). + + From f0c7c76966dd06dc7b0bb4343be884222cbacf7e Mon Sep 17 00:00:00 2001 From: Theofrastos Mantadelis Date: Tue, 1 Feb 2011 17:36:34 +0100 Subject: [PATCH 04/12] fixed some minor issues in c_alarms --- library/c_alarms.yap | 29 +++++++++++++++++------------ 1 file changed, 17 insertions(+), 12 deletions(-) diff --git a/library/c_alarms.yap b/library/c_alarms.yap index 235e3cace..5e3b0785a 100644 --- a/library/c_alarms.yap +++ b/library/c_alarms.yap @@ -9,9 +9,9 @@ % % Contributions to this file: % Author: Theofrastos Mantadelis -% Version: 0.1 +% Version: 1.0 % Date: 01/02/2011 -% Comments: The timer implementation is inspired by Bernd Gutmann timers +% Contributions: The timer implementation is inspired by Bernd Gutmann's timers % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % @@ -203,7 +203,7 @@ :- module(c_alarms, [set_alarm/3, unset_alarm/1, - time_out_call/3, + time_out_call_once/3, timer_start/1, timer_restart/1, timer_stop/2, @@ -227,15 +227,19 @@ :- use_module(library(lists), [member/2, memberchk/2, delete/3]). :- use_module(library(ordsets), [ord_add_element/3]). :- use_module(library(apply_macros), [maplist/3]). + +:- dynamic('$timer'/3). + +:- meta_predicate(set_alarm(+, 0, -)). +:- meta_predicate(time_out_call_once(+, 0, -)). +:- meta_predicate(prove_once(0)). + :- initialization(local_init). local_init:- bb_put(alarms, []), bb_put(identity, 0). -:- meta_predicate(set_alarm(+, 0, -)). -:- meta_predicate(time_out_call(+, 0, -)). - get_next_identity(ID):- bb_get(identity, ID), NID is ID + 1, @@ -312,13 +316,12 @@ execute([alarm(_, _, Execute)|R]):- call(Execute), execute(R). -time_out_call(Seconds, Goal, Return):- +time_out_call_once(Seconds, Goal, Return):- bb_get(identity, ID), + set_alarm(Seconds, throw(timeout(ID)), ID), catch(( - (set_alarm(Seconds, throw(timeout(ID)), ID) ; unset_alarm(ID), fail), - Goal, - unset_alarm(ID), - Return = success) + prove_once(Goal, Return), + unset_alarm(ID)) , Exception, ( (Exception == timeout(ID) -> Return = timeout @@ -327,7 +330,9 @@ time_out_call(Seconds, Goal, Return):- throw(Exception) ))). -:- dynamic('$timer'/3). +prove_once(Goal, success):- + once(Goal). +prove_once(_Goal, failure). timer_start(Name):- \+ ground(Name), From ab241751454ee5a58ad7f3ef4ffa99c2a6d37aa1 Mon Sep 17 00:00:00 2001 From: Theofrastos Mantadelis Date: Tue, 1 Feb 2011 17:51:54 +0100 Subject: [PATCH 05/12] hopefully the bug is now fixed... --- library/c_alarms.yap | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/library/c_alarms.yap b/library/c_alarms.yap index 5e3b0785a..5c442aa7b 100644 --- a/library/c_alarms.yap +++ b/library/c_alarms.yap @@ -9,8 +9,8 @@ % % Contributions to this file: % Author: Theofrastos Mantadelis -% Version: 1.0 -% Date: 01/02/2011 +% $Date: 2011-02-01 17:48:23 +0100 (Tue, 01 Feb 2011) $ +% $Revision: 6 $ % Contributions: The timer implementation is inspired by Bernd Gutmann's timers % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -270,7 +270,7 @@ unset_alarm(ID):- throw(error(instantiation_error, 'Alarm ID needs to be instantiated.')). unset_alarm(ID):- bb_get(alarms, Alarms), - memberchk(alarm(_Seconds, ID, _Execute), Alarms), + \+ memberchk(alarm(_Seconds, ID, _Execute), Alarms), throw(error(existence_error(alarm, unset_alarm(ID)), 'Alarm does not exist.')). unset_alarm(ID):- alarm(0, true, Remaining), @@ -331,7 +331,7 @@ time_out_call_once(Seconds, Goal, Return):- ))). prove_once(Goal, success):- - once(Goal). + once(Goal), !. prove_once(_Goal, failure). timer_start(Name):- From 95427488d6ef4a3d1512a8fd8f79e0314a6b1c26 Mon Sep 17 00:00:00 2001 From: Theofrastos Mantadelis Date: Tue, 1 Feb 2011 18:11:36 +0100 Subject: [PATCH 06/12] ... --- library/c_alarms.yap | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/library/c_alarms.yap b/library/c_alarms.yap index 5c442aa7b..e34dd9eaf 100644 --- a/library/c_alarms.yap +++ b/library/c_alarms.yap @@ -275,10 +275,13 @@ unset_alarm(ID):- unset_alarm(ID):- alarm(0, true, Remaining), bb_get(alarms, Alarms), + [alarm(Seconds, _, _)|_] = Alarms, + Elapsed is Seconds - Remaining - 1, delete_alarm(Alarms, ID, NewAlarms), bb_put(alarms, NewAlarms), - (NewAlarms = [alarm(Seconds, _, _)|_] -> - alarm(Seconds, alarm_handler, _) + (NewAlarms = [alarm(NewSeconds, _, _)|_] -> + RemainingSeconds is NewSeconds - Elapsed, + alarm(RemainingSeconds, alarm_handler, _) ; true ). From 857c8c042eeb9fe97c088ddb7df8bd2081161e4f Mon Sep 17 00:00:00 2001 From: Theofrastos Mantadelis Date: Tue, 1 Feb 2011 18:37:32 +0100 Subject: [PATCH 07/12] Final version for today --- library/c_alarms.yap | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/library/c_alarms.yap b/library/c_alarms.yap index e34dd9eaf..e238f1dae 100644 --- a/library/c_alarms.yap +++ b/library/c_alarms.yap @@ -9,8 +9,8 @@ % % Contributions to this file: % Author: Theofrastos Mantadelis -% $Date: 2011-02-01 17:48:23 +0100 (Tue, 01 Feb 2011) $ -% $Revision: 6 $ +% $Date: 2011-02-01 18:36:41 +0100 (Tue, 01 Feb 2011) $ +% $Revision: 7 $ % Contributions: The timer implementation is inspired by Bernd Gutmann's timers % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% From 83e918ac68973d697239ee2129b4e64ad15207b4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Wed, 2 Feb 2011 19:00:52 +0000 Subject: [PATCH 08/12] improve comparison of terms. --- C/gmp_support.c | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/C/gmp_support.c b/C/gmp_support.c index d8f2afc0e..c28159da8 100755 --- a/C/gmp_support.c +++ b/C/gmp_support.c @@ -1299,13 +1299,19 @@ Yap_gmp_tcmp_big_big(Term t1, Term t2) if (pt1[1] == BIG_INT) { return 1; - } else { + } else if (pt1[1] == BIG_RATIONAL) { b1 = Yap_BigRatOfTerm(t1); + } else if (pt1[1] == BIG_RATIONAL) { + b1 = Yap_BigRatOfTerm(t1); + } else { + return pt1-pt2; } if (pt2[1] == BIG_INT) { return -1; - } else { + } else if (pt2[1] == BIG_RATIONAL) { b2 = Yap_BigRatOfTerm(t2); + } else { + return pt1-pt2; } return mpq_cmp(b1, b2); } From cbf6caddbdaea52a2aebe11255bfbc281bd49018 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Wed, 2 Feb 2011 19:37:11 +0000 Subject: [PATCH 09/12] fix support for comparing weird terms. --- C/c_interface.c | 2 +- C/cmppreds.c | 2 +- C/gmp_support.c | 47 ++++++++++++++++++++++++++++++++++++++++++++++- packages/jpl | 2 +- 4 files changed, 49 insertions(+), 4 deletions(-) diff --git a/C/c_interface.c b/C/c_interface.c index eac1cb109..1ecb74f92 100755 --- a/C/c_interface.c +++ b/C/c_interface.c @@ -708,7 +708,7 @@ YAP_MkBlobTerm(unsigned int sz) } I = AbsAppl(H); H[0] = (CELL)FunctorBigInt; - H[1] = BIG_INT; + H[1] = ARRAY_INT; dst = (MP_INT *)(H+2); dst->_mp_size = 0L; dst->_mp_alloc = sz; diff --git a/C/cmppreds.c b/C/cmppreds.c index 757c64329..cc3bc49db 100644 --- a/C/cmppreds.c +++ b/C/cmppreds.c @@ -165,7 +165,7 @@ static int compare_complex(register CELL *pt0, register CELL *pt0_end, register } else if (IsLongIntTerm(d1)) { out = Yap_gmp_tcmp_int_big(d0, LongIntOfTerm(d1)); } else if (IsBigIntTerm(d1)) { - out = Yap_gmp_tcmp_big_big(d1, d1); + out = Yap_gmp_tcmp_big_big(d0, d1); } else if (IsRefTerm(d1)) out = 1 ; else out = -1; diff --git a/C/gmp_support.c b/C/gmp_support.c index c28159da8..7304b0244 100755 --- a/C/gmp_support.c +++ b/C/gmp_support.c @@ -22,6 +22,7 @@ #if HAVE_STRING_H #include #endif +#include #if USE_GMP @@ -1289,6 +1290,7 @@ Yap_gmp_tcmp_big_big(Term t1, Term t2) { CELL *pt1 = RepAppl(t1); CELL *pt2 = RepAppl(t2); + if (pt1[1] == BIG_INT && pt2[1] == BIG_INT) { MP_INT *b1 = Yap_BigIntOfTerm(t1); MP_INT *b2 = Yap_BigIntOfTerm(t2); @@ -1301,7 +1303,50 @@ Yap_gmp_tcmp_big_big(Term t1, Term t2) return 1; } else if (pt1[1] == BIG_RATIONAL) { b1 = Yap_BigRatOfTerm(t1); - } else if (pt1[1] == BIG_RATIONAL) { + } else if (pt1[1] == BLOB_STRING) { + char *s1 = Yap_BlobStringOfTerm(t1); + if (pt2[1] == BLOB_STRING) { + char *s2 = Yap_BlobStringOfTerm(t2); + return strcmp(s1,s2); + } else if (pt2[1] == BLOB_WIDE_STRING) { + wchar_t *wcs2 = Yap_BlobWideStringOfTerm(t2), *wcs1, *tmp1; + int out; + size_t n = strlen(s1); + if (!(wcs1 = (wchar_t *)malloc((n+1)*sizeof(wchar_t)))) { + Yap_Error(OUT_OF_HEAP_ERROR, t1, "compare/3"); + return 0; + } + tmp1 = wcs1; + while (*s1) { + *tmp1++ = *s1++; + } + out = wcscmp(wcs1, wcs2); + free(wcs1); + return out; + } + b1 = Yap_BigRatOfTerm(t1); + } else if (pt1[1] == BLOB_WIDE_STRING) { + wchar_t *wcs1 = Yap_BlobWideStringOfTerm(t1); + if (pt2[1] == BLOB_STRING) { + char *s2 = Yap_BlobStringOfTerm(t2); + wchar_t *wcs2, *tmp2; + int out; + size_t n = strlen(s2); + if (!(wcs2 = (wchar_t *)malloc((n+1)*sizeof(wchar_t)))) { + Yap_Error(OUT_OF_HEAP_ERROR, t2, "compare/3"); + return 0; + } + tmp2 = wcs2; + while (*s2) { + *tmp2++ = *s2++; + } + out = wcscmp(wcs1, wcs2); + free(wcs2); + return out; + } else if (pt2[1] == BLOB_WIDE_STRING) { + wchar_t *wcs2 = Yap_BlobWideStringOfTerm(t2); + return wcscmp(wcs1,wcs2); + } b1 = Yap_BigRatOfTerm(t1); } else { return pt1-pt2; diff --git a/packages/jpl b/packages/jpl index 29151b2fe..73e4e086d 160000 --- a/packages/jpl +++ b/packages/jpl @@ -1 +1 @@ -Subproject commit 29151b2fe68f2dc727cdc07040e1fa1ad4fcca20 +Subproject commit 73e4e086d06c54210100f0faaeccbea276c707eb From 51a5fdfbd723dd1dd4f240565c0abe420ce98a0d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Wed, 2 Feb 2011 20:14:36 +0000 Subject: [PATCH 10/12] fix handling of SICStus style attributes (obs from Denys Duchier). --- C/attvar.c | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/C/attvar.c b/C/attvar.c index fb0249ce3..a27f4b925 100644 --- a/C/attvar.c +++ b/C/attvar.c @@ -569,6 +569,13 @@ p_put_atts(void) { } /* we may have a stack shift meanwhile!! */ tatts = Deref(ARG2); + if (IsVarTerm(tatts)) { + Yap_Error(INSTANTIATION_ERROR,tatts,"second argument of put_att/2"); + return FALSE; + } else if (!IsApplTerm(tatts)) { + Yap_Error(TYPE_ERROR_COMPOUND,tatts,"second argument of put_att/2"); + return FALSE; + } if (IsVarTerm(otatts = SearchAttsForModule(attv->Atts,mfun))) { AddNewModule(attv,tatts,new,FALSE); } else { From 8ab12ec680e07c1c763afbe58e64cac9daf220a4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Wed, 2 Feb 2011 20:45:29 +0000 Subject: [PATCH 11/12] fix mix swi/sicstus --- library/atts.yap | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/library/atts.yap b/library/atts.yap index eccd31aa6..07e361e3f 100644 --- a/library/atts.yap +++ b/library/atts.yap @@ -49,8 +49,6 @@ new_attribute(Na/Ar) :- store_new_module(Mod,Ar,Position), assertz(existing_attribute(S,Mod,Ar,Position)). -existing_attribute(delay(_),prolog,1,2). - store_new_module(Mod,Ar,ArgPosition) :- ( retract(attributed_module(Mod,Position,_)) @@ -58,7 +56,7 @@ store_new_module(Mod,Ar,ArgPosition) :- true ; retract(modules_with_attributes(Mods)), - assert(modules_with_attributes([Mod|Mods])), Position = 1 + assert(modules_with_attributes([Mod|Mods])), Position = 2 ), ArgPosition is Position+1, ( Ar == 0 -> NOfAtts is Position+1 ; NOfAtts is Position+Ar), From 3efb549e0209332c1db812d5e283e58911f5fcf8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Wed, 2 Feb 2011 20:45:42 +0000 Subject: [PATCH 12/12] fix occur-check unification (obs from Jason Filippou). --- C/unify.c | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/C/unify.c b/C/unify.c index eb639ff69..4e4b7b81d 100644 --- a/C/unify.c +++ b/C/unify.c @@ -56,7 +56,7 @@ rtree_loop: } to_visit[0] = pt0; to_visit[1] = pt0_end; - to_visit[2] = (CELL *)d0; + to_visit[2] = (CELL *)*pt0; *pt0 = TermFoundVar; pt0_end = (pt0 = RepPair(d0) - 1) + 2; continue; @@ -78,7 +78,7 @@ rtree_loop: } to_visit[0] = pt0; to_visit[1] = pt0_end; - to_visit[2] = (CELL *)d0; + to_visit[2] = (CELL *)*pt0; *pt0 = TermFoundVar; d0 = ArityOfFunctor(f); pt0 = ap2; @@ -102,14 +102,13 @@ rtree_loop: cufail: /* we found an infinite term */ - while (to_visit < to_visit_max) { + while (to_visit < (CELL **)to_visit_base) { CELL *pt0; pt0 = to_visit[0]; *pt0 = (CELL)to_visit[2]; to_visit += 3; } return TRUE; - } static inline int