From 26c80b06242bd6fc396a6c016f3b6db92ff4610d Mon Sep 17 00:00:00 2001
From: Vitor Santos Costa <vsc@dcc.fc.up.pt>
Date: Mon, 6 Jan 2014 22:17:42 +0000
Subject: [PATCH] use singletons option of read_term to implement singleton
 test

---
 pl/boot.yap     | 12 ++++++++-
 pl/checker.yap  | 68 +++++++++++++------------------------------------
 pl/messages.yap |  6 ++---
 3 files changed, 32 insertions(+), 54 deletions(-)

diff --git a/pl/boot.yap b/pl/boot.yap
index 68ffa6837..b826f57be 100755
--- a/pl/boot.yap
+++ b/pl/boot.yap
@@ -1069,7 +1069,17 @@ bootstrap(F) :-
 	!.
 
 '$enter_command'(Stream,Mod,Status) :-
-	read_term(Stream, Command, [module(Mod), variable_names(Vars), term_position(Pos), syntax_errors(dec10), process_comment(true) ]),
+	read_term(Stream, Command, [module(Mod), variable_names(Vars), term_position(Pos), syntax_errors(dec10), process_comment(true), singletons( Singletons ) ]),
+	( Singletons == []
+         -> 
+	 true
+        ;
+	  get_value('$syntaxchecksinglevar',on)
+        ->
+	 '$sv_warning'(Singletons, Command )
+        ;
+	  true
+        ),
 	'$command'(Command,Vars,Pos,Status).
 
 '$abort_loop'(Stream) :-
diff --git a/pl/checker.yap b/pl/checker.yap
index 0ac0eeab1..54a0ea46c 100644
--- a/pl/checker.yap
+++ b/pl/checker.yap
@@ -141,22 +141,18 @@ no_style_check([H|T]) :- no_style_check(H), no_style_check(T).
 '$init_style_check'(_).
 
 % style checker proper..
-'$check_term'(T, _, VL,P,_) :-
-	get_value('$syntaxchecksinglevar',on),
-	'$singletons_in_clause'(T, VL, Sv),
-	Sv = [_|_],
-	'$sv_warning'(Sv,T),
-         fail.
 '$check_term'(_, T, _,P,M) :-
 	get_value('$syntaxcheckdiscontiguous',on),
-	'$xtract_head'(T,M,NM,_,F,A),
+	strip_module(T, M, T1),
+	'$pred_arity'( T1, Name, Arity ),
 	% should always fail
-	'$handle_discontiguous'(F,A,NM),
+	'$handle_discontiguous'(Name, Arity, M),
 	fail.
 '$check_term'(_, T,_,P,M) :-
 	get_value('$syntaxcheckmultiple',on),
-	'$xtract_head'(T,M,NM,_,F,A),
-	'$handle_multiple'(F,A,NM), 
+	strip_module(T, M, T1),
+	'$pred_arity'( T1, Name, Arity ),
+	'$handle_multiple'( Name , Arity, M), 
 	fail.
 '$check_term'(_, T,_,_,M) :-
 	( 
@@ -167,7 +163,8 @@ no_style_check([H|T]) :- no_style_check(H), no_style_check(T).
 	    get_value('$syntaxcheckmultiple',on)
 	),
 	source_location( File, _ ),
-	'$xtract_head'(T,M,NM,_,F,A),
+	strip_module(T, M, T1),
+	'$pred_arity'( T1, Name, Arity ),
 	\+ (
 	    % allow duplicates if we are not the last predicate to have
 	    % been asserted.
@@ -178,48 +175,19 @@ no_style_check([H|T]) :- no_style_check(H), no_style_check(T).
 	fail.
 '$check_term'(_,_,_,_,_).
 
-%
-% output a list of singleton variables...
-%
-'$singletons_in_clause'(T, VL, Sv) :-
-        % first check which variables are not singleton
-	'$non_singletons_in_term'(T, [], V2L),
-        % bound them
-	'$ground_vars'(V2L),
-        % the remainder which do not start by _ are our target! 
-	'$sv_list'(VL, Sv).
-
-'$ground_vars'([]).
-'$ground_vars'([ground|V2L]) :-
-	'$ground_vars'(V2L).
-
-'$sv_list'([],[]).
-'$sv_list'([(_=V)|T],L) :- nonvar(V), !,
-	'$sv_list'(T,L).
-'$sv_list'([(X=_)|T], L) :-
-	atom_concat('_',_,X), !,
-	'$sv_list'(T,L).
-'$sv_list'([(Name=_)|T], [Name|L]) :-
-	'$sv_list'(T,L).
-
 '$sv_warning'([], _) :- !.
-'$sv_warning'(SVs, T) :-
-	'$current_module'(OM),
-	'$xtract_head'(T, OM, M, H, Name, Arity),
+'$sv_warning'(SVs,  T) :-
+	strip_module(T, M, T1),
+	'$pred_arity'( T1, Name, Arity ),
 	print_message(warning,singletons(SVs,(M:Name/Arity))).
 
-'$xtract_head'(V,M,M,V,call,1) :- var(V), !.
-'$xtract_head'((H:-_),OM,M,NH,Name,Arity) :- !,
-        '$xtract_head'(H,OM,M,NH,Name,Arity).
-'$xtract_head'((H,_),OM,M,H1,Name,Arity) :- !,
-	'$xtract_head'(H,OM,M,H1,Name,Arity).
-'$xtract_head'((H-->_),OM,M,HL,Name,Arity) :- !,
-	'$xtract_head'(H,M,OM,_,Name,A1),
-	Arity is A1+2,
-	functor(HL,Name,Arity).
-'$xtract_head'(M:H,_,NM,NH,Name,Arity) :- !,
-	'$xtract_head'(H,M,NM,NH,Name,Arity).
-'$xtract_head'(H,M,M,H,Name,Arity) :-
+'$pred_arity'(V,M,M,V,call,1) :- var(V), !.
+'$pred_arity'((H:-_),Name,Arity) :- !,
+	functor(H,Name,Arity).
+'$pred_arity'((H-->_),Name,Arity) :- !,
+	functor(HL,Name,1).
+	Arity is A1+2.
+'$pred_arity'(H,Name,Arity) :-
 	functor(H,Name,Arity).
 
 % check if a predicate is discontiguous.
diff --git a/pl/messages.yap b/pl/messages.yap
index a80309dee..fe65fc038 100644
--- a/pl/messages.yap
+++ b/pl/messages.yap
@@ -155,7 +155,7 @@ system_message(no_match(P)) -->
 	[ 'No matching predicate for ~w.' - [P] ].
 system_message(leash([A|B])) -->
 	[ 'Leashing set to ~w.' - [[A|B]] ].
-system_message(singletons([SV],P)) -->
+system_message(singletons([SV=_],P)) -->
 	[ 'Singleton variable ~s in ~q.' - [SV,P] ].
 system_message(singletons(SVs,P)) -->
 	[  'Singleton variables ~s in ~q.' - [SVsL, P] ],
@@ -443,8 +443,8 @@ object_name(unsigned_byte, 'unsigned byte').
 object_name(unsigned_char, 'unsigned char').
 object_name(variable, 'unbound variable').
 
-svs([A]) --> !, { atom_codes(A, H) }, H.
-svs([A|L]) -->
+svs([A=_]) --> !, { atom_codes(A, H) }, H.
+svs([A=_|L]) -->
 	{ atom_codes(A, H) },
 	H,
 	", ",