Insert Christian patches:

- uncutable predicates;
  - call_cleanup/2.


git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@615 b08c6af1-5177-4d33-ba66-4b1c6b8b522a

library/cleanup.yap

@@ -0,0 +1,120 @@
+:- module( cleanup, [
+		call_cleanup/2,
+		call_cleanup/1,
+		on_cleanup/1,
+		cleanup_all/0
+	]).
+
+/*
+public interface:
+
+call_cleanup(Goal).
+call_cleanup(Goal,CleanUpGoal).
+	Goal will be called in a cleanup-context, where any registered
+	CleanUpGoal inside of that context will be called when Goal is left,
+	either by a fail, cut or exeption.
+	It is possible to nest cleanup contexts.
+
+on_cleanup(CleanUpGoal).
+	registers CleanUpGoal to the current cleanup context.
+	CleanUpGoal's are executed in reverse order of their registration.
+	throws an exception if called outside of any cleanup-context.
+
+cleanup_all.
+	calls all pending CleanUpGoals and resets the cleanup-system to an initial state.
+	should only be used as one of the last calls in the main program.
+
+
+hidden predicates:
+most private predicates could also be used in special cases, such as manually setting up cleanup-contexts.
+Read the Source.
+*/
+
+
+:- meta_predicate 
+	call_cleanup(:,:),
+	call_cleanup(:),
+	on_cleanup(:),
+	on_cleanup(?,:),
+	on_cleanupz(:),
+	on_cleanupz(?,:).
+
+
+:- initialization(init_cleanup).
+init_cleanup :-
+	get_value('cleanup:level',[]),
+	set_value('cleanup:level',0).
+init_cleanup.
+
+
+% call goal G  with a cleanup CL in a cleanup context
+call_cleanup(G,CL) :-
+	needs_cleanup(L),
+	on_cleanup(L,CL),
+	(
+		catch(G,X,(do_cleanup(L),throw(X)))
+	;
+		do_cleanup(L)
+	).
+
+
+% call a goal G in a cleanup context
+call_cleanup(G) :-
+	needs_cleanup(L),
+	(
+		catch(G,X,(do_cleanup(L),throw(X)))
+	;
+		do_cleanup(L)
+	).
+
+
+% begin cleanup level
+needs_cleanup(CL) :-
+	get_value('cleanup:level',L),
+	CL is L + 1,
+	set_value('cleanup:level',CL).
+
+
+% leave cleanup level, call all registred cleanup predicates within
+do_cleanup(CL) :-
+	CN is CL - 1,
+	set_value('cleanup:level',CN),
+	next_cleanup(CL).
+
+next_cleanup(CL) :-
+	!,recorded(cleanup:handle,(L,G),R),
+	CL =< L,
+	erase(R),
+	(call(G);true),
+	next_cleanup(CL).
+
+
+% clean up all remaining stuff / reinitialize cleanup-module
+cleanup_all :- do_cleanup(1).
+
+
+% register a cleanup predicate (normal reverse-order cleanup)
+on_cleanup(G) :-
+	get_value('cleanup:level',L),
+	on_cleanup(L,G).
+
+on_cleanup(L,G) :-
+	L =< 0,
+	throw(no_cleanup_context(G)).
+on_cleanup(L,G) :-
+	callable(G),
+	recorda(cleanup:handle,(L,G),_).
+
+
+% register a cleanup predicate (reverse-reverse-order cleanup)
+on_cleanupz(G) :-
+	get_value('cleanup:level',L),
+	on_cleanupz(L,G).
+
+on_cleanupz(L,G) :-
+	L =< 0,
+	throw(no_cleanup_context(G)).
+on_cleanupz(L,G) :-
+	callable(G),
+	recordz(cleanup:handle,(L,G),_).
+