/* --- Copyright University of Sussex 1993. All rights reserved. ----------
 > File:			C.all/plog/src/prolog_prmishap.p
 > Purpose:			Prolog: mishap handler
 > Author:			Robert Duncan, Apr 27 1993
 > Documentation:
 > Related Files:
 */


section prolog;

constant
	procedure ( prolog_printq, prolog_writeq, predicate_isdefined, ),
;

;;; ========================================================================

;;; is_predicate_name:
;;;		tests (roughly) whether -name- is a word of the form fn/arity.

define lconstant is_predicate_name(name);
	lvars name, posn;
	isword(name)
	and (locchar(`/`, 1, name) ->> posn)
	and posn fi_< datalength(name)
	and isnumbercode(fast_subscrw(posn fi_+ 1, name));
enddefine;

;;; print_culprit:
;;;		prints an item in the INVOLVING line of a mishap message:
;;;		uses printq/1 to start with, but switches to writeq/1 if that
;;;		generates further errors,

define lvars print_culprit(item);
	lvars	item;
	dlocal	print_culprit = prolog_writeq;
	prolog_printq(item);
enddefine;

;;;	prolog_sysprmishap:
;;;		default Prolog error handler. Prints a standard format message,
;;;		then calls -interrupt-.

define prolog_sysprmishap(message, culprits);
	lvars	i, call_pdr, props, message, culprits, nprinted = 0,
			predicate_names_only = false;
	dlocal	cucharout = cucharerr, pr = syspr, pop_pr_quotes = false,
			prmishap = sysprmishap;

	;;; adapted from the version in errors.p
	define lconstant Conceal_call(props);
		lconstant
			conceal_names = [mishap setpop converter_to_contn error\/2 \;\/2],
			conceal_prefixes = [sys ved wved xved pop11_ prolog_];
		lvars props, prefix;
		if isword(props) then
			returnif(lmember(props, conceal_names))(true);
			for prefix in conceal_prefixes do
				returnif(isstartstring(prefix, props))(true);
			endfor;
		endif;
		false;
	enddefine;

	printf('\n;;; PROLOG ERROR - ');
	prolog_write(message);
	cucharout(`\n`);
	unless culprits == [] then
		printf(';;; INVOLVING:\s\s');
		for i in culprits do
			print_culprit(i);
			cucharout(`\s`);
		endfor;
		cucharout(`\n`);
	endunless;
	if popfilename then
		printf(poplinenum, popfilename,
			';;; FILE\s\s\s\s\s:\s\s%p\s\s\sLINE NUMBER:\s\s%p\n')
	endif;

	;;; print the calling stack
	printf(';;; DOING\s\s\s\s:\s\s');
	1 -> i;
	while (caller(i) ->> call_pdr) and nprinted /== pop_mishap_doing_lim do
		recursive_front(pdprops(call_pdr)) -> props;
		if popsyscall then
			if props or isinheap(call_pdr) then
				spr(props);
				nprinted fi_+ 1 -> nprinted;
			elseif isinteger(popsyscall) then
				printf(call_pdr, '%x ');
				nprinted fi_+ 1 -> nprinted;
			endif;
		elseif props and not(Conceal_call(props)) then
			if is_predicate_name(props) then
				spr(props);
				nprinted fi_+ 1 -> nprinted;
				;;; print only prolog predicate names after the first
				true -> predicate_names_only;
			elseif not(predicate_names_only) then
				spr(props);
				nprinted fi_+ 1 -> nprinted;
			endif;
		endif;
		i fi_+ 1 -> i;
	endwhile;
	if call_pdr and nprinted /== 0 then printf('...') endif;
	cucharout(`\n`);

	;;; abort
	interrupt();
enddefine;

constant procedure prolog_prmishap;		;;; forward

;;; set_error_handling:
;;;		enables/disables the handling of errors with the user predicate
;;;		prolog_error/2

define set_error_handling(status);
	lvars status;
	if status == "on" and prmishap == prolog_sysprmishap then
		prolog_prmishap -> prmishap;
	elseif status == "off" and prmishap == prolog_prmishap then
		prolog_sysprmishap -> prmishap;
	endif;
enddefine;

;;; prolog_error_handler:
;;;		calls prolog_error/2 with error handling disabled

define lconstant prolog_error_handler(message, culprits);
	lvars message, culprits;
	;;; disable error handling
	set_error_handling("off");
	;;; call the user predicate
	prolog_valof("prolog_error", 2)(
		message, culprits,
		procedure;
			;;; re-enable error handling
			set_error_handling("on");
			;;; do the continuation
			prolog_apply_continuation();
			;;; disable error handling on backtrack
			set_error_handling("off");
		endprocedure);
	;;; re-enable error handling on failure
	set_error_handling("on");
enddefine;

;;;	prolog_prmishap:
;;;     calls -prolog_error/2- if there's a matching clause for this
;;;     error, otherwise calls -prolog_sysprmishap-

define prolog_prmishap(message, culprits);
	lvars	message, culprits;
	dlocal	prmishap = prolog_sysprmishap;
	if predicate_isdefined("clause", 2) then
		lvars i = 1, props, last_pred;
		while caller(i) ->> last_pred do
			recursive_front(pdprops(last_pred)) -> props;
			quitif(is_predicate_name(props));
			i fi_+ 1 -> i;
		endwhile;
		if last_pred then
			;;; see if there's a matching clause for prolog_error/2:
			;;; if there is, chain back to -last_pred- and call it
			if isstring(message) then consword(message) -> message endif;
			prolog_valof("clause", 2)(
				prolog_maketerm(message, culprits, "prolog_error", 2),
				prolog_newvar(),
				procedure;
					chainto(
						message, culprits, last_pred,
						prolog_error_handler);
				endprocedure);
		endif;
	endif;
	prolog_sysprmishap(message, culprits);
enddefine;

endsection;		/* prolog */
