%%
% g-prolog-1.1.2
%%

/* this file is automatically generated by make_bip_list.pl */

% defined in /home/lima/diaz/GNU-Prolog/src/BipsPl/call_args.pl

bip(call_with_args,1).
bip(call_with_args,2).
bip(call_with_args,3).
bip(call_with_args,4).
bip(call_with_args,5).
bip(call_with_args,6).
bip(call_with_args,7).
bip(call_with_args,8).
bip(call_with_args,9).
bip(call_with_args,10).
bip(call_with_args,11).

% defined in /home/lima/diaz/GNU-Prolog/src/BipsPl/os_interf.pl

bip(host_name,1).
bip(directory_files,2).
bip(exec,5).
bip(exec,4).
bip(working_directory,1).
bip(file_exists,1).
bip(temporary_file,3).
bip(architecture,1).
bip(wait,2).
bip(delete_file,1).
bip(change_directory,1).
bip(date_time,1).
bip(select,5).
bip(popen,3).
bip(make_directory,1).
bip(system,1).
bip(system,2).
bip(unlink,1).
bip(os_version,1).
bip(file_property,2).
bip(delete_directory,1).
bip(spawn,2).
bip(spawn,3).
bip(sleep,1).
bip(prolog_pid,1).
bip(temporary_name,2).
bip(shell,0).
bip(shell,1).
bip(shell,2).
bip(rename_file,2).
bip(file_permission,2).
bip(send_signal,2).

% defined in /home/loews/loco/diaz/GNU-Prolog/src/BipsPl/all_solut.pl

bip(bagof,3).
bip(setof,3).
bip(findall,3).

% defined in /home/loews/loco/diaz/GNU-Prolog/src/BipsPl/arith_inl.pl

bip(>=,2).
bip(<,2).
bip(>,2).
bip(=\=,2).
bip(=:=,2).
bip(is,2).
bip(=<,2).

% defined in /home/loews/loco/diaz/GNU-Prolog/src/BipsPl/assert.pl

bip(retractall,1).
bip(assertz,1).
bip(asserta,1).
bip(retract,1).
bip(abolish,1).
bip(clause,2).

% defined in /home/loews/loco/diaz/GNU-Prolog/src/BipsPl/atom.pl

bip(char_code,2).
bip(lower_upper,2).
bip(current_atom,1).
bip(name,2).
bip(number_codes,2).
bip(atom_codes,2).
bip(atom_length,2).
bip(atom_property,2).
bip(number_chars,2).
bip(new_atom,1).
bip(new_atom,2).
bip(new_atom,3).
bip(number_atom,2).
bip(atom_chars,2).
bip(atom_concat,3).
bip(atom_hash,2).
bip(sub_atom,5).

% defined in /home/loews/loco/diaz/GNU-Prolog/src/BipsPl/call.pl

bip(call,2).
bip(once,1).
bip(\+,1).

% defined in /home/loews/loco/diaz/GNU-Prolog/src/BipsPl/char_io.pl

bip(get_char,1).
bip(get_char,2).
bip(get_code,1).
bip(get_code,2).
bip(unget_byte,1).
bip(unget_byte,2).
bip(put_char,1).
bip(put_char,2).
bip(peek_code,1).
bip(peek_code,2).
bip(put_code,1).
bip(put_code,2).
bip(peek_char,1).
bip(peek_char,2).
bip(get_byte,1).
bip(get_byte,2).
bip(get_code_no_echo,1).
bip(get_code_no_echo,2).
bip(unget_char,1).
bip(unget_char,2).
bip(unget_code,1).
bip(unget_code,2).
bip(peek_byte,1).
bip(peek_byte,2).
bip(put_byte,1).
bip(put_byte,2).

% defined in /home/loews/loco/diaz/GNU-Prolog/src/BipsPl/const_io.pl

bip(write_canonical_to_atom,2).
bip(write_term_to_chars,3).
bip(write_term_to_codes,3).
bip(write_to_atom,2).
bip(display_to_atom,2).
bip(display_to_codes,2).
bip(read_term_from_atom,3).
bip(print_to_atom,2).
bip(read_term_from_codes,3).
bip(write_term_to_atom,3).
bip(write_to_codes,2).
bip(display_to_chars,2).
bip(print_to_codes,2).
bip(read_token_from_atom,2).
bip(read_token_from_chars,2).
bip(read_from_atom,2).
bip(read_from_codes,2).
bip(read_from_chars,2).
bip(write_canonical_to_codes,2).
bip(write_to_chars,2).
bip(print_to_chars,2).
bip(read_token_from_codes,2).
bip(write_canonical_to_chars,2).
bip(writeq_to_atom,2).
bip(writeq_to_codes,2).
bip(writeq_to_chars,2).
bip(read_term_from_chars,3).
bip(format_to_atom,3).
bip(format_to_codes,3).
bip(format_to_chars,3).

% defined in /home/loews/loco/diaz/GNU-Prolog/src/BipsPl/consult.pl

bip('.',2).
bip(consult,1).
bip(listing,0).
bip(listing,1).
bip(load,1).

% defined in /home/loews/loco/diaz/GNU-Prolog/src/BipsPl/control.pl

bip(abort,0).
bip(repeat,0).
bip(stop,0).
bip(halt,0).
bip(halt,1).
bip(for,3).

% defined in /home/loews/loco/diaz/GNU-Prolog/src/BipsPl/dec10io.pl

bip(told,0).
bip(tab,1).
bip(put,1).
bip(seeing,1).
bip(tell,1).
bip(seen,0).
bip(see,1).
bip(append,1).
bip(telling,1).
bip(skip,1).
bip(get,1).
bip(get0,1).

% defined in /home/loews/loco/diaz/GNU-Prolog/src/BipsPl/expand.pl

bip(expand_term,2).
bip(phrase,2).
bip(phrase,3).

% defined in /home/loews/loco/diaz/GNU-Prolog/src/BipsPl/file.pl

bip(decompose_file_name,4).
bip(absolute_file_name,2).
bip(prolog_file_name,2).

% defined in /home/loews/loco/diaz/GNU-Prolog/src/BipsPl/flag.pl

bip(read_pl_state_file,1).
bip(argument_counter,1).
bip(write_pl_state_file,1).
bip(argument_value,2).
bip(set_prolog_flag,2).
bip(current_prolog_flag,2).
bip(argument_list,1).
bip(environ,2).

% defined in /home/loews/loco/diaz/GNU-Prolog/src/BipsPl/format.pl

bip(format,2).
bip(format,3).

% defined in /home/loews/loco/diaz/GNU-Prolog/src/BipsPl/g_var_inl.pl

bip(g_assign,2).
bip(g_assignb,2).
bip(g_array_size,2).
bip(g_read,2).
bip(g_link,2).

% defined in /home/loews/loco/diaz/GNU-Prolog/src/BipsPl/le_interf.pl

bip(add_linedit_completion,1).
bip(find_linedit_completion,2).
bip(get_linedit_prompt,1).
bip(set_linedit_prompt,1).

% defined in /home/loews/loco/diaz/GNU-Prolog/src/BipsPl/list.pl

bip(reverse,2).
bip(nth,3).
bip(min_list,2).
bip(permutation,2).
bip(sum_list,2).
bip(prefix,2).
bip(last,2).
bip(suffix,2).
bip(sublist,2).
bip(select,3).
bip(append,3).
bip(delete,3).
bip(memberchk,2).
bip(length,2).
bip(member,2).
bip(max_list,2).

% defined in /home/loews/loco/diaz/GNU-Prolog/src/BipsPl/oper.pl

bip(current_op,3).
bip(op,3).

% defined in /home/loews/loco/diaz/GNU-Prolog/src/BipsPl/pl_error.pl

bip(current_bip_name,2).
bip(set_bip_name,2).
bip(syntax_error_info,4).

% defined in /home/loews/loco/diaz/GNU-Prolog/src/BipsPl/pred.pl

bip(current_predicate,1).
bip(predicate_property,2).

% defined in /home/loews/loco/diaz/GNU-Prolog/src/BipsPl/pretty.pl

bip(name_query_vars,2).
bip(name_singleton_vars,1).
bip(bind_variables,2).
bip(numbervars,1).
bip(numbervars,3).
bip(portray_clause,1).
bip(portray_clause,2).

% defined in /home/loews/loco/diaz/GNU-Prolog/src/BipsPl/print.pl

bip(get_print_stream,1).
bip(print,1).
bip(print,2).

% defined in /home/loews/loco/diaz/GNU-Prolog/src/BipsPl/random.pl

bip(get_seed,1).
bip(set_seed,1).
bip(randomize,0).
bip(random,1).
bip(random,3).

% defined in /home/loews/loco/diaz/GNU-Prolog/src/BipsPl/read.pl

bip(char_conversion,2).
bip(read_number,1).
bip(read_number,2).
bip(read_token,1).
bip(read_token,2).
bip(read_integer,1).
bip(read_integer,2).
bip(read_term,2).
bip(read_term,3).
bip(current_char_conversion,2).
bip(read_atom,1).
bip(read_atom,2).
bip(read,1).
bip(read,2).
bip(last_read_start_line_column,2).

% defined in /home/loews/loco/diaz/GNU-Prolog/src/BipsPl/sockets.pl

bip(socket_close,1).
bip(socket_bind,2).
bip(socket_connect,4).
bip(socket,2).
bip(socket_accept,3).
bip(socket_accept,4).
bip(hostname_address,2).
bip(socket_listen,2).

% defined in /home/loews/loco/diaz/GNU-Prolog/src/BipsPl/sort.pl

bip(keysort,2).
bip(keysort,1).
bip(sort,2).
bip(sort,1).
bip(sort0,2).
bip(sort0,1).

% defined in /home/loews/loco/diaz/GNU-Prolog/src/BipsPl/stat.pl

bip(system_time,1).
bip(real_time,1).
bip(statistics,0).
bip(statistics,2).
bip(cpu_time,1).
bip(user_time,1).

% defined in /home/loews/loco/diaz/GNU-Prolog/src/BipsPl/stream.pl

bip(close,1).
bip(close,2).
bip(stream_line_column,3).
bip(stream_property,2).
bip(open_input_codes_stream,2).
bip(flush_output,0).
bip(flush_output,1).
bip(current_input,1).
bip(seek,4).
bip(set_stream_buffering,2).
bip(open_input_chars_stream,2).
bip(open_output_chars_stream,1).
bip(close_input_chars_stream,1).
bip(stream_position,2).
bip(open_output_atom_stream,1).
bip(close_input_atom_stream,1).
bip(at_end_of_stream,0).
bip(at_end_of_stream,1).
bip(character_count,2).
bip(open_input_atom_stream,2).
bip(set_stream_type,2).
bip(set_output,1).
bip(add_stream_alias,2).
bip(current_stream,1).
bip(set_stream_eof_action,2).
bip(set_input,1).
bip(current_alias,2).
bip(open_output_codes_stream,1).
bip(line_position,2).
bip(current_output,1).
bip(line_count,2).
bip(close_input_codes_stream,1).
bip(open,3).
bip(open,4).
bip(close_output_chars_stream,2).
bip(close_output_codes_stream,2).
bip(set_stream_line_column,3).
bip(set_stream_position,2).
bip(close_output_atom_stream,2).

% defined in /home/loews/loco/diaz/GNU-Prolog/src/BipsPl/term_inl.pl

bip(==,2).
bip(functor,3).
bip(@>,2).
bip(setarg,3).
bip(setarg,4).
bip(=..,2).
bip(copy_term,2).
bip(term_ref,2).
bip(compare,3).
bip(@=<,2).
bip(\==,2).
bip(@>=,2).
bip(arg,3).
bip(@<,2).

% defined in /home/loews/loco/diaz/GNU-Prolog/src/BipsPl/type_inl.pl

bip(list_or_partial_list,1).
bip(atomic,1).
bip(number,1).
bip(integer,1).
bip(atom,1).
bip(partial_list,1).
bip(list,1).
bip(var,1).
bip(compound,1).
bip(callable,1).
bip(float,1).
bip(nonvar,1).

% defined in /home/loews/loco/diaz/GNU-Prolog/src/BipsPl/unify.pl

bip(\=,2).
bip(=,2).
bip(unify_with_occurs_check,2).

% defined in /home/loews/loco/diaz/GNU-Prolog/src/BipsPl/write.pl

bip(writeq,1).
bip(writeq,2).
bip(write_canonical,1).
bip(write_canonical,2).
bip(display,1).
bip(display,2).
bip(nl,0).
bip(nl,1).
bip(write_term,2).
bip(write_term,3).
bip(write,1).
bip(write,2).

% defined in /home/loews/loco/diaz/GNU-Prolog/src/BipsFD/fd_bool.pl

bip(##,2).
bip(fd_at_least_one,1).
bip(#\<=>,2).
bip(#/\,2).
bip(#\==>,2).
bip(fd_only_one,1).
bip(#<=>,2).
bip(#\,1).
bip(#==>,2).
bip(#\/\,2).
bip(fd_at_most_one,1).
bip(fd_cardinality,2).
bip(fd_cardinality,3).
bip(#\/,2).
bip(#\\/,2).

% defined in /home/loews/loco/diaz/GNU-Prolog/src/BipsFD/fd_infos.pl

bip(fd_vector_max,1).
bip(fd_size,2).
bip(fd_has_extra_cstr,1).
bip(fd_set_vector_max,1).
bip(fd_min,2).
bip(fd_dom,2).
bip(fd_use_vector,1).
bip(fd_max_integer,1).
bip(fd_has_vector,1).
bip(fd_max,2).

% defined in /home/loews/loco/diaz/GNU-Prolog/src/BipsFD/fd_math.pl

bip(#=,2).
bip(#>,2).
bip(#\=,2).
bip(#=<#,2).
bip(#>=#,2).
bip(#=<,2).
bip(#\=#,2).
bip(#>=,2).
bip(#<#,2).
bip(#=#,2).
bip(#>#,2).
bip(#<,2).

% defined in /home/loews/loco/diaz/GNU-Prolog/src/BipsFD/fd_optim.pl

bip(fd_minimize,2).
bip(fd_maximize,2).

% defined in /home/loews/loco/diaz/GNU-Prolog/src/BipsFD/fd_prime.pl

bip(fd_prime,1).
bip(fd_not_prime,1).

% defined in /home/loews/loco/diaz/GNU-Prolog/src/BipsFD/fd_symbolic.pl

bip(fd_relation,2).
bip(fd_relationc,2).
bip(fd_all_different,1).
bip(fd_exactly,3).
bip(fd_element_var,3).
bip(fd_atleast,3).
bip(fd_element,3).
bip(fd_atmost,3).

% defined in /home/loews/loco/diaz/GNU-Prolog/src/BipsFD/fd_values.pl

bip(fd_labelingff,1).
bip(fd_domain_bool,1).
bip(fd_domain,2).
bip(fd_domain,3).
bip(fd_labeling,1).
bip(fd_labeling,2).

% defined in /home/loews/loco/diaz/GNU-Prolog/src/BipsPl/type_inl.pl

bip(fd_var,1).
bip(generic_var,1).
bip(non_generic_var,1).
bip(non_fd_var,1).
/*-------------------------------------------------------------------------*/
/* GNU Prolog                                                              */
/*                                                                         */
/* Part  : Prolog to WAM compiler                                          */
/* File  : code_gen.pl                                                     */
/* Descr.: pass 3: code generation                                         */
/* Author: Daniel Diaz                                                     */
/*                                                                         */
/* Copyright (C) 1999 Daniel Diaz                                          */
/*                                                                         */
/* GNU Prolog is free software; you can redistribute it and/or modify it   */
/* under the terms of the GNU General Public License as published by the   */
/* Free Software Foundation; either version 2, or any later version.       */
/*                                                                         */
/* GNU Prolog is distributed in the hope that it will be useful, but       */
/* WITHOUT ANY WARRANTY; without even the implied warranty of              */
/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU        */
/* General Public License for more details.                                */
/*                                                                         */
/* You should have received a copy of the GNU General Public License along */
/* with this program; if not, write to the Free Software Foundation, Inc.  */
/* 59 Temple Place - Suite 330, Boston, MA 02111, USA.                     */
/*-------------------------------------------------------------------------*/

code_generation(Head,Body,NbChunk,NbY,WamHead):-
	g_assign(last_pred,f),
	generate_head(Head,NbChunk,NbY,WamBody,WamHead),
	generate_body(Body,NbChunk,WamBody).




generate_head(p(_,_/N,LArg),NbChunk,NbY,WamNext,WamHead):-
	gen_list_integers(0,N,LReg),
	(g_read(reorder,t) 
            -> reorder_head_arg_lst(LArg,LReg,LArg1,LReg1)
            ;  LArg1=LArg, LReg1=LReg),
	gen_unif_arg_lst(LArg1,LReg1,WamNext,WamLArg),
	(NbChunk > 1 -> WamHead=[allocate(NbY)|WamLArg]
	             ;  WamHead=WamLArg).




reorder_head_arg_lst(LArg,LReg,LArg1,LReg1):-
	split_arg_lst(LArg,LReg,LArgK,LRegK,LArgS,LRegS,LArgT,LRegT),
	reverse(LArgT,LArgT1),
	reverse(LRegT,LRegT1),
	append(LArgK,LArgT1,LArgKT),
	append(LArgKT,LArgS,LArg1),
	append(LRegK,LRegT1,LRegKT),
	append(LRegKT,LRegS,LReg1).




generate_body([],_,[proceed]).

generate_body([p(NoPred,Pred/N,LArg)|Body],NbChunk,WamPred):-
	(NoPred=NbChunk -> g_assign(last_pred,t)
                        ;  true),
	generate_body1(Pred,N,LArg,NoPred,Body,NbChunk,WamPred).


generate_body1(fail,0,_,_,_,_,[fail]):-
	!.

generate_body1(Pred,N,LArg,NoPred,Body,NbChunk,WamPred):-
	inline_predicate(Pred,N),
	gen_inline_pred(Pred,N,LArg,WamBody,WamPred),
	!,
	(Body=[] -> (NoPred>1 -> WamBody=[deallocate,proceed]
	                      ;  WamBody=[proceed])
	         ;
		    generate_body(Body,NbChunk,WamBody)).

generate_body1(Pred,N,LArg,NoPred,Body,NbChunk,WamLArg):-
	gen_list_integers(0,N,LReg),
	(g_read(reorder,t) 
            -> reorder_body_arg_lst(LArg,LReg,LArg1,LReg1)
            ;  LArg1=LArg, LReg1=LReg),
	gen_load_arg_lst(LArg1,LReg1,WamCallExecute,WamLArg),
	(Body=[] -> (NoPred>1 -> WamCallExecute=[deallocate,execute(Pred/N)]
	                      ;  WamCallExecute=[execute(Pred/N)])
	         ;
		    WamCallExecute=[call(Pred/N)|WamBody],
                    generate_body(Body,NbChunk,WamBody)).




reorder_body_arg_lst(LArg,LReg,LArg1,LReg1):-
	split_arg_lst(LArg,LReg,LArgK,LRegK,LArgS,LRegS,LArgT,LRegT),
	append(LArgS,LArgT,LArgST),
	append(LArgST,LArgK,LArg1),
	append(LRegS,LRegT,LRegST),
	append(LRegST,LRegK,LReg1).




          /* split LArg/LReg in:                                     */
          /*       LArgK/LRegK: known elements (without temporaries) */
          /*       LArgS/LRegS: structures containing temporaries    */
          /*       LArgT/LRegT: temporaries                          */

split_arg_lst([],[],[],[],[],[],[],[]).

split_arg_lst([Arg|LArg],[Reg|LReg],LArgK,LRegK,LArgS,LRegS,LArgT,LRegT):-
	(Arg=var(x(No),_), No\==void,
         LArgK=LArgK1,       LRegK=LRegK1,
         LArgS=LArgS1,       LRegS=LRegS1,
	 LArgT=[Arg|LArgT1], LRegT=[Reg|LRegT1]
               ;
         Arg=stc(_,_,LStcArg), has_temporaries(LStcArg),
         LArgK=LArgK1,       LRegK=LRegK1,
	 LArgS=[Arg|LArgS1], LRegS=[Reg|LRegS1],
         LArgT=LArgT1,       LRegT=LRegT1
               ;
	 LArgK=[Arg|LArgK1], LRegK=[Reg|LRegK1],
         LArgS=LArgS1,       LRegS=LRegS1,
         LArgT=LArgT1,       LRegT=LRegT1),
	!,
	split_arg_lst(LArg,LReg,LArgK1,LRegK1,LArgS1,LRegS1,LArgT1,LRegT1).




has_temporaries([Arg|LArg]):-
	(Arg=var(x(No),_), No\==void
            ;
         Arg=stc(_,_,LStcArg), has_temporaries(LStcArg)
            ;
         has_temporaries(LArg)),
	!.




	/* gen_unif_arg_lst(LArg,LReg,WamNext,WamLArg) */

gen_unif_arg_lst([],[],WamNext,WamNext).

gen_unif_arg_lst([Arg|LArg],[Reg|LReg],WamNext,WamArg):-
	gen_unif_arg(Arg,Reg,WamLArg,WamArg),
	gen_unif_arg_lst(LArg,LReg,WamNext,WamLArg).




	/* gen_unif_arg(Arg,Reg,WamNext,WamArg) */

gen_unif_arg(var(VarName,Info),Reg,WamNext,WamArg):-
	(var(Info) -> (VarName==x(void)
                          -> WamArg=WamNext
	                  ;  Info=not_in_cur_env,
			     WamArg=[get_variable(VarName,Reg)|WamNext])
 	           ;  
  		      WamArg=[get_value(VarName,Reg)|WamNext]).

gen_unif_arg(atm(A),Reg,WamNext,[get_atom(A,Reg)|WamNext]).

gen_unif_arg(int(N),Reg,WamNext,[get_integer(N,Reg)|WamNext]).

gen_unif_arg(flt(N),Reg,WamNext,[get_float(N,Reg)|WamNext]).

gen_unif_arg(nil,Reg,WamNext,[get_nil(Reg)|WamNext]).

gen_unif_arg(stc(F,N,LStcArg),Reg,WamNext,[WamInst|WamStcArg]):-
	(F='.', N=2 -> WamInst=get_list(Reg)
                    ;  WamInst=get_structure(F/N,Reg)),
	flat_stc_arg_lst(LStcArg,head,LStcArg1,LArgAux,LRegAux),
	gen_subterm_arg_lst(LStcArg1,WamArgAux,WamStcArg),
	gen_unif_arg_lst(LArgAux,LRegAux,WamNext,WamArgAux).




	/* gen_load_arg_lst(LArg,LReg,WamNext,WamLArg) */

gen_load_arg_lst([],[],WamNext,WamNext).

gen_load_arg_lst([Arg|LArg],[Reg|LReg],WamNext,WamArg):-
	gen_load_arg(Arg,Reg,WamLArg,WamArg),
	gen_load_arg_lst(LArg,LReg,WamNext,WamLArg).




	/* gen_load_arg(Arg,Reg,WamNext,WamArg) */

gen_load_arg(var(VarName,Info),Reg,WamNext,[WamInst|WamNext]):-
	(var(Info) -> (VarName==x(void)
                          -> WamInst=put_void(Reg)
	                  ;  (VarName=x(_) -> Info=in_heap
                                           ;  Info=unsafe),
                             WamInst=put_variable(VarName,Reg))
	           ;  
                      (Info=unsafe, g_read(last_pred,t)
	                     -> WamInst=put_unsafe_value(VarName,Reg)
	                     ;  WamInst=put_value(VarName,Reg))).

gen_load_arg(atm(A),Reg,WamNext,[put_atom(A,Reg)|WamNext]).

gen_load_arg(int(N),Reg,WamNext,[put_integer(N,Reg)|WamNext]).

gen_load_arg(flt(N),Reg,WamNext,[put_float(N,Reg)|WamNext]).

gen_load_arg(nil,Reg,WamNext,[put_nil(Reg)|WamNext]).

gen_load_arg(stc(F,N,LStcArg),Reg,WamNext,WamArgAux):-
	(F='.', N=2 -> WamInst=put_list(Reg)
                    ;  WamInst=put_structure(F/N,Reg)),
        flat_stc_arg_lst(LStcArg,body,LStcArg1,LArgAux,LRegAux),
	gen_load_arg_lst(LArgAux,LRegAux,[WamInst|WamStcArg],WamArgAux),
	gen_subterm_arg_lst(LStcArg1,WamNext,WamStcArg).




          /* flat_stc_arg_lst(LStcArg,HB,LStcArg1,LArgAux,LRegAux) */

flat_stc_arg_lst([],_,[],[],[]).

flat_stc_arg_lst([StcArg|LStcArg],HB,[StcArg|LStcArg1],LArgAux,LRegAux):-
	simple_stc_arg(StcArg),
	!,
	flat_stc_arg_lst(LStcArg,HB,LStcArg1,LArgAux,LRegAux).

flat_stc_arg_lst([StcArg],HB,[stc(F,N,LStcArg1)],LArgAux,LRegAux):-
	g_read(opt_last_subterm,t),      % last subterm unif stc optimization
	StcArg=stc(F,N,LStcArg),
	!,
	flat_stc_arg_lst(LStcArg,HB,LStcArg1,LArgAux,LRegAux).

flat_stc_arg_lst([StcArg|LStcArg],HB,[V|LStcArg1],[StcArg|LArgAux],[X|LRegAux]):-
	(HB=head -> V=var(x(X),_)
                 ;  V=var(x(X),in_heap)),
	flat_stc_arg_lst(LStcArg,HB,LStcArg1,LArgAux,LRegAux).



simple_stc_arg(var(_,_)).

simple_stc_arg(atm(_)).

simple_stc_arg(int(_)).

simple_stc_arg(nil).




           /* gen_subterm_arg_lst(LStcArg,WamNext,WamLStcArg) */

gen_subterm_arg_lst([],WamNext,WamNext).

gen_subterm_arg_lst([Arg|LArg],WamNext,WamArg):-
	gen_compte_void([Arg|LArg],0,N,LArg1),
	(N=0 -> gen_subterm_arg(Arg,WamLArg,WamArg),
	        gen_subterm_arg_lst(LArg,WamNext,WamLArg)
	     ;
	        WamArg=[unify_void(N)|WamLArg1],
	        gen_subterm_arg_lst(LArg1,WamNext,WamLArg1)).




gen_compte_void([var(x(No),_)|LArg],N,N2,LArg1):-
	No==void,
	!,
	N1 is N+1,
	gen_compte_void(LArg,N1,N2,LArg1).

gen_compte_void(LArg,N,N,LArg).




gen_subterm_arg(var(VarName,Info),WamNext,[WamInst|WamNext]):-
	(var(Info) -> Info=in_heap,
                      WamInst=unify_variable(VarName)
	          ;   (Info=in_heap -> WamInst=unify_value(VarName)
                                    ;  WamInst=unify_local_value(VarName))).

gen_subterm_arg(atm(A),WamNext,[unify_atom(A)|WamNext]).

gen_subterm_arg(int(N),WamNext,[unify_integer(N)|WamNext]).

gen_subterm_arg(nil,WamNext,[unify_nil|WamNext]).

gen_subterm_arg(stc(F,N,LStcArg),WamNext,[WamInst|WamLStcArg]):-
	(F='.', N=2 -> WamInst=unify_list
                    ;  WamInst=unify_structure(F/N)),
        gen_subterm_arg_lst(LStcArg,WamNext,WamLStcArg).




gen_list_integers(I,N,L):-
	(I<N -> L=[I|L1],
	        I1 is I+1,
		gen_list_integers(I1,N,L1)
             ;  
                L=[]).




          /* called at code emission */

special_form(put_variable(x(X),X),put_void(X)).




dummy_instruction(get_variable(x(X),X)).
dummy_instruction(put_value(x(X),X)).




	% Inline predicate code generation:
	%      gen_inline_pred(Pred,Arite,LArg,WamNext,WamPred)
        %
	% the predicates defined here must have a corresponding clause
	% inline_predicate/2 (in pass 2).

:- discontiguous(gen_inline_pred/5).


	/* Cut inline ('$get_cut_level'/1,'$cut'/1) */

gen_inline_pred('$get_cut_level',1,[Arg],WamNext,WamArg):-
	cur_pred(Pred,N),
        set_pred_info(cut,Pred,N),
	gen_unif_arg(Arg,N,WamNext,WamArg).

gen_inline_pred('$cut',1,[var(VarName,_)],WamNext,[WamInst|WamNext]):-
	WamInst=cut(VarName).




	/* Unification inline (=/2) */

gen_inline_pred((=),2,[Arg1,Arg2],WamNext,WamEqual):-
	equal(Arg1,Arg2,WamNext,WamEqual),
	!.




equal(Arg1,Arg2,WamNext,WamNext):-
	Arg1==Arg2.

equal(var(VarName,Info),var(VarName,Info),WamNext,WamNext):-
	var(Info).  % true if initial Info1 and Info2 were unbound variables

equal(var(VarName1,Info1),Arg2,WamNext,WamEqual):-
	(VarName1=x(Reg1) 
            -> (Reg1==void
                   -> WamNext=WamEqual
                   ;  inline_unif_reg_term(Info1,Reg1,Arg2,WamNext,WamEqual))
            ;
               gen_load_arg(var(VarName1,Info1),IReg,WamEqual1,WamEqual),
	       gen_unif_arg(Arg2,IReg,WamNext,WamEqual1)).

equal(Arg1,var(VarName2,Info2),WamNext,WamEqual):-
	(VarName2=x(Reg2) 
            -> (Reg2==void
                   -> WamNext=WamEqual
                   ;  inline_unif_reg_term(Info2,Reg2,Arg1,WamNext,WamEqual))
            ;
               gen_load_arg(var(VarName2,Info2),IReg,WamEqual1,WamEqual),
	       gen_unif_arg(Arg1,IReg,WamNext,WamEqual1)).

equal(Arg1,var(x(Reg2),Info2),WamNext,WamEqual):-
	inline_unif_reg_term(Info2,Reg2,Arg1,WamNext,WamEqual).

equal(stc(F,N,LStcArg1),stc(F,N,LStcArg2),WamNext,WamEqual):-
	equal_lst(LStcArg1,LStcArg2,WamNext,WamEqual).

equal(_,_,WamNext,[fail|WamNext]):-
	warn('explicit unification will fail',[]).




equal_lst([],[],WamNext,WamNext).

equal_lst([Arg1|LArg1],[Arg2|LArg2],WamNext,WamEqual):-
	equal(Arg1,Arg2,WamLArg,WamEqual),
	equal_lst(LArg1,LArg2,WamNext,WamLArg).




inline_unif_reg_term(Info,Reg,Arg,WamNext,WamUnif):-
	(var(Info) -> Info=in_heap,
                      gen_load_arg(Arg,Reg,WamNext,WamUnif)
                   ;
                      gen_unif_arg(Arg,Reg,WamNext,WamUnif)).




	/* Mathematical inlines (is/2 =:=/2 ...) */

gen_inline_pred(is,2,[Arg1,Arg2],WamNext,WamMath):-
        load_math_expr(Arg2,Reg,WamUnif,WamMath),
        !,
        gen_unif_arg(Arg1,Reg,WamNext,WamUnif).



load_math_expr(var(VarName,Info),Reg,WamNext,WamMath):-
	(var(Info) 
	    -> error('unbound variable in arithmetic expression',[])
            ;  true),
	(g_read(fast_math,t) 
            -> WamMath=[math_fast_load_value(VarName,Reg)|WamNext]
            ;  WamMath=[math_load_value(VarName,Reg)|WamNext]).

load_math_expr(int(N),Reg,WamNext,WamMath):-
	gen_load_arg(int(N),Reg,WamNext,WamMath).

load_math_expr(flt(N),Reg,WamNext,WamMath):-
	gen_load_arg(flt(N),Reg,WamNext,WamMath).

load_math_expr(stc(F,N,LArg),Reg,WamNext,WamMath):-
	load_math_expr1(F,N,LArg,Reg,WamNext,WamMath).

load_math_expr(X,_,_,_):-
	error('unknown expression in arithmetic expression (~q)',[X]).


load_math_expr1('.',2,[Arg,nil],Reg,WamNext,WamMath):-
	load_math_expr(Arg,Reg,WamNext,WamMath).

load_math_expr1((+),1,[Arg],Reg,WamNext,WamMath):-
	load_math_expr(Arg,Reg,WamNext,WamMath).

load_math_expr1((+),2,[Arg1,int(1)],Reg,WamNext,WamMath):-
	load_math_expr1(inc,1,[Arg1],Reg,WamNext,WamMath).

load_math_expr1((-),2,[Arg1,int(1)],Reg,WamNext,WamMath):-
	load_math_expr1(dec,1,[Arg1],Reg,WamNext,WamMath).

load_math_expr1(F,1,[Arg],Reg,WamNext,WamMath):-
	(g_read(fast_math,t) -> fast_exp_functor_name(F,1,Name)
                             ;  math_exp_functor_name(F,1,Name)),
	load_math_expr(Arg,Reg1,WamInst,WamMath),
	WamInst=[function(Name,Reg,[Reg1])|WamNext].

load_math_expr1(F,N,LArg,Reg,WamNext,WamMath):-
	(g_read(fast_math,t) -> fast_exp_functor_name(F,N,Name)
                             ;  math_exp_functor_name(F,N,Name)),
	load_math_arg_lst(LArg,LReg,WamInst,WamMath),
	WamInst=[function(Name,Reg,LReg)|WamNext].

load_math_expr1(F,N,_,_,_,_):-
	math_exp_functor_name(F,N,_),
	error('arithmetic operation not allowed in fast math (~q)',
                 [F/N]).

load_math_expr1(F,N,_,_,_,_):-
	error('unknown operation in arithmetic expression (~q)',[F/N]).




load_math_arg_lst([],[],WamNext,WamNext).

load_math_arg_lst([Arg|LArg],[Reg|LReg],WamNext,WamMath):-
	load_math_expr(Arg,Reg,WamLArg,WamMath),
	load_math_arg_lst(LArg,LReg,WamNext,WamLArg).




fast_exp_functor_name(-,                    1,'Fct_Fast_Neg').
fast_exp_functor_name(inc,                  1,'Fct_Fast_Inc').
fast_exp_functor_name(dec,                  1,'Fct_Fast_Dec').
fast_exp_functor_name(+,                    2,'Fct_Fast_Add').
fast_exp_functor_name(-,                    2,'Fct_Fast_Sub').
fast_exp_functor_name(*,                    2,'Fct_Fast_Mul').
fast_exp_functor_name(//,                   2,'Fct_Fast_Div').
fast_exp_functor_name(rem,                  2,'Fct_Fast_Rem').
fast_exp_functor_name(mod,                  2,'Fct_Fast_Mod').
fast_exp_functor_name(/\,                   2,'Fct_Fast_And').
fast_exp_functor_name(\/,                   2,'Fct_Fast_Or').
fast_exp_functor_name(^,                    2,'Fct_Fast_Xor').
fast_exp_functor_name(\,                    1,'Fct_Fast_Not').
fast_exp_functor_name(<<,                   2,'Fct_Fast_Shl').
fast_exp_functor_name(>>,                   2,'Fct_Fast_Shr').
fast_exp_functor_name(abs,                  1,'Fct_Fast_Abs').
fast_exp_functor_name(sign,                 1,'Fct_Fast_Sign').




math_exp_functor_name(-,                    1,'Fct_Neg').
math_exp_functor_name(inc,                  1,'Fct_Inc').
math_exp_functor_name(dec,                  1,'Fct_Dec').
math_exp_functor_name(+,                    2,'Fct_Add').
math_exp_functor_name(-,                    2,'Fct_Sub').
math_exp_functor_name(*,                    2,'Fct_Mul').
math_exp_functor_name(//,                   2,'Fct_Div').
math_exp_functor_name(/,                    2,'Fct_Float_Div').
math_exp_functor_name(rem,                  2,'Fct_Rem').
math_exp_functor_name(mod,                  2,'Fct_Mod').
math_exp_functor_name(/\,                   2,'Fct_And').
math_exp_functor_name(\/,                   2,'Fct_Or').
math_exp_functor_name(^,                    2,'Fct_Xor').
math_exp_functor_name(\,                    1,'Fct_Not').
math_exp_functor_name(<<,                   2,'Fct_Shl').
math_exp_functor_name(>>,                   2,'Fct_Shr').
math_exp_functor_name(abs,                  1,'Fct_Abs').
math_exp_functor_name(sign,                 1,'Fct_Sign').
						    
math_exp_functor_name(**,                   2,'Fct_Pow').
math_exp_functor_name(sqrt,                 1,'Fct_Sqrt').
math_exp_functor_name(atan,                 1,'Fct_Atan').
math_exp_functor_name(cos,                  1,'Fct_Cos').
math_exp_functor_name(sin,                  1,'Fct_Sin').
math_exp_functor_name(exp,                  1,'Fct_Exp').
math_exp_functor_name(log,                  1,'Fct_Log').
math_exp_functor_name(float,                1,'Fct_Float').
math_exp_functor_name(ceiling,              1,'Fct_Ceiling').
math_exp_functor_name(floor,                1,'Fct_Floor').
math_exp_functor_name(round,                1,'Fct_Round').
math_exp_functor_name(truncate,             1,'Fct_Truncate').
math_exp_functor_name(float_fractional_part,1,'Fct_Float_Fract_Part').
math_exp_functor_name(float_integer_part,   1,'Fct_Float_Integ_Part').




gen_inline_pred(F,2,LArg,WamNext,WamMath):-
	(g_read(fast_math,t) -> fast_cmp_functor_name(F,Name)
                             ;  math_cmp_functor_name(F,Name)),
	load_math_arg_lst(LArg,LReg,WamInst,WamMath),
	WamInst=[call_c_test(Name,LReg)|WamNext].




fast_cmp_functor_name((=:=),'Blt_Fast_Eq').
fast_cmp_functor_name((=\=),'Blt_Fast_Neq').
fast_cmp_functor_name((<),  'Blt_Fast_Lt').
fast_cmp_functor_name((=<), 'Blt_Fast_Lte').
fast_cmp_functor_name((>),  'Blt_Fast_Gt').
fast_cmp_functor_name((>=), 'Blt_Fast_Gte').

math_cmp_functor_name((=:=),'Blt_Eq').
math_cmp_functor_name((=\=),'Blt_Neq').
math_cmp_functor_name((<),  'Blt_Lt').
math_cmp_functor_name((=<), 'Blt_Lte').
math_cmp_functor_name((>),  'Blt_Gt').
math_cmp_functor_name((>=), 'Blt_Gte').




	/* Low level C interface ('$call_c'/1) */

gen_inline_pred(CallC,1,[Arg],WamNext,WamCallC):-
	(CallC='$call_c', CallCType=simple
                  ;
	 CallC='$call_c_test', CallCType=test
	          ;
	 CallC='$call_c_jump', CallCType=jump),
	!,
	(Arg=atm(Name), LStcArg=[]
                  ;
         Arg=stc(Name,_,LStcArg)),
	gen_call_c(Name,LStcArg,CallCType,WamNext,WamCallC).




	/* foreign C call */

gen_inline_pred('$foreign_call_c',7,[X,Types,atm(FctName),
                atm(Return),atm(BipName),int(BipArity),int(ChcSize)],
                WamNext,WamCallC):-
	(X=stc(_,_,LArg) ; X=atm(_), LArg=[]),
	!,
	gen_load_arg_lst(LArg,LReg,WamInst,WamCallC),
	gen_foreign_types(Types,LType),
	WamInst=[foreign_call_c(FctName,Return,BipName,BipArity,ChcSize,
                                LType,LReg)|WamNext].


gen_foreign_types(nil,[]).

gen_foreign_types(stc('.',_,[stc(',',2,[atm(A),int(O)]),Types]),[(A,O)|LType]):-
	gen_foreign_types(Types,LType).





          /* Other inlines */

gen_inline_pred(F,N,LArg,WamNext,WamCallC):-
	c_fct_name(F,N,CallCType,Name),
	gen_call_c(Name,LArg,CallCType,WamNext,WamCallC).




gen_call_c(Name,LArg,CallCType,WamNext,WamCallC):-
	gen_load_arg_lst(LArg,LReg,WamInst,WamCallC),
	WamInst=[WamCallCInst|WamNext],
	(CallCType=simple
            -> WamCallCInst=call_c(Name,LReg)
            ;  (CallCType=test 
                     -> WamCallCInst=call_c_test(Name,LReg)
                     ;  WamCallCInst=call_c_jump(Name,LReg))).




c_fct_name(var,                 1,test,'Blt_Var').
c_fct_name(nonvar,              1,test,'Blt_Non_Var').
c_fct_name(atom,                1,test,'Blt_Atom').
c_fct_name(integer,             1,test,'Blt_Integer').
c_fct_name(float,               1,test,'Blt_Float').
c_fct_name(number,              1,test,'Blt_Number').
c_fct_name(atomic,              1,test,'Blt_Atomic').
c_fct_name(compound,            1,test,'Blt_Compound').
c_fct_name(callable,            1,test,'Blt_Callable').
c_fct_name(list,                1,test,'Blt_List').
c_fct_name(partial_list,        1,test,'Blt_Partial_List').
c_fct_name(list_or_partial_list,1,test,'Blt_List_Or_Partial_List').

c_fct_name(fd_var,              1,test,'Blt_Fd_Var').
c_fct_name(non_fd_var,          1,test,'Blt_Non_Fd_Var').
c_fct_name(generic_var,         1,test,'Blt_Generic_Var').
c_fct_name(non_generic_var,     1,test,'Blt_Non_Generic_Var').


c_fct_name(arg,                 3,test,'Blt_Arg').
c_fct_name(functor,             3,test,'Blt_Functor').
c_fct_name(compare,             3,test,'Blt_Compare').
c_fct_name((=..),               2,test,'Blt_Univ').    

c_fct_name((==),                2,test,'Blt_Term_Eq').
c_fct_name((\==),               2,test,'Blt_Term_Neq').
c_fct_name((@<),                2,test,'Blt_Term_Lt').
c_fct_name((@=<),               2,test,'Blt_Term_Lte').
c_fct_name((@>),                2,test,'Blt_Term_Gt').
c_fct_name((@>=),               2,test,'Blt_Term_Gte').

c_fct_name(g_assign,            2,test,'Blt_G_Assign').
c_fct_name(g_assignb,           2,test,'Blt_G_Assignb').
c_fct_name(g_link,              2,test,'Blt_G_Link').
c_fct_name(g_read,              2,test,'Blt_G_Read').
c_fct_name(g_array_size,        2,test,'Blt_G_Array_Size').



/*-------------------------------------------------------------------------*/
/* GNU Prolog                                                              */
/*                                                                         */
/* Part  : Prolog to WAM compiler                                          */
/* File  : first_arg.pl                                                    */
/* Descr.: first argument detection                                        */
/* Author: Daniel Diaz                                                     */
/*                                                                         */
/* Copyright (C) 1999 Daniel Diaz                                          */
/*                                                                         */
/* GNU Prolog is free software; you can redistribute it and/or modify it   */
/* under the terms of the GNU General Public License as published by the   */
/* Free Software Foundation; either version 2, or any later version.       */
/*                                                                         */
/* GNU Prolog is distributed in the hope that it will be useful, but       */
/* WITHOUT ANY WARRANTY; without even the implied warranty of              */
/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU        */
/* General Public License for more details.                                */
/*                                                                         */
/* You should have received a copy of the GNU General Public License along */
/* with this program; if not, write to the Free Software Foundation, Inc.  */
/* 59 Temple Place - Suite 330, Boston, MA 02111, USA.                     */
/*-------------------------------------------------------------------------*/


find_first_arg([],var).

find_first_arg([WamInst|WamCode],FirstArg):-
	(defines_first_arg(WamInst,FirstArg)
               ;
	stopping_inst(WamInst), FirstArg=var
               ;
	find_first_arg(WamCode,FirstArg)),
	!.




stopping_inst(call(_)).

stopping_inst(execute(_)).

stopping_inst(cut(_)).      % to avoid to fail in switch_on_term (before cut)

stopping_inst(WamInst):-
	codification(WamInst,LCode),
	assign_x0(LCode).




assign_x0([Code|LCode]):-
	(Code=w(0); Code=c(R1,R2), R1\==R2, R2=0 ; assign_x0(LCode)).




defines_first_arg(get_atom(A,0),atm(A)).

defines_first_arg(get_integer(N,0),int(N)).

%defines_first_arg(get_float(N,0),flt(N)).            % no indexing on floats

defines_first_arg(get_nil(0),atm([])).

defines_first_arg(get_list(0),lst).

defines_first_arg(get_structure(F/N,0),stc(F,N)).
/*-------------------------------------------------------------------------*/
/* GNU Prolog                                                              */
/*                                                                         */
/* Part  : Prolog to WAM compiler                                          */
/* File  : indexing.pl                                                     */
/* Descr.: indexing code generation                                        */
/* Author: Daniel Diaz                                                     */
/*                                                                         */
/* Copyright (C) 1999 Daniel Diaz                                          */
/*                                                                         */
/* GNU Prolog is free software; you can redistribute it and/or modify it   */
/* under the terms of the GNU General Public License as published by the   */
/* Free Software Foundation; either version 2, or any later version.       */
/*                                                                         */
/* GNU Prolog is distributed in the hope that it will be useful, but       */
/* WITHOUT ANY WARRANTY; without even the implied warranty of              */
/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU        */
/* General Public License for more details.                                */
/*                                                                         */
/* You should have received a copy of the GNU General Public License along */
/* with this program; if not, write to the Free Software Foundation, Inc.  */
/* 59 Temple Place - Suite 330, Boston, MA 02111, USA.                     */
/*-------------------------------------------------------------------------*/

/*-------------------------------------------------------------------------*/
/* Level 1:                                                                */
/*                                                                         */
/* The clauses C1,...,Cn of a predicate Pred are split into groups         */
/* G0,...,Gm so that each group Gi:                                        */
/*                                                                         */
/*   a) contains only one clause whose 1st arg is a variable.              */
/*   b) contains only clauses whose 1st arg is not a variable.             */
/*                                                                         */
/* The following code is then produced:                                    */
/*                                                                         */
/*   L0: try_me_else(L1)                                                   */
/*       <code for G0>                                                     */
/*                                                                         */
/*   L1: retry_me_else(L2)                                                 */
/*       <code for G1>                                                     */
/*            :                                                            */
/*            :                                                            */
/*   Lm: trust_me_else_fail                                                */
/*       <code for Gm>                                                     */
/*                                                                         */
/* Level 2:                                                                */
/*                                                                         */
/* For a group Gi whose type is a), the <code for Gi> only contains the    */
/* code produced for the associated Ck clause.                             */
/* For a group Gi whose type is b), the <code for Gi> contains indexing    */
/* instructions for the level 2 to discriminate between atoms, integers    */
/* lists and structures as follows:                                        */
/*                                                                         */
/*            switch_on_term(LabVar,LabAtm,LabInt,LabLst,LabStc)           */
/*                                                                         */
/*   LabFail: fail                 if there is a LabXxx = LabFail          */
/*                                                                         */
/*   LabAtm : switch_on_atom(N,[(atm1,LabAtm1),...(atmN,LabAtmN)])       \ */
/*                                                                       | */
/*   LabAtmj: try(Adj1)                  \  if more than 1 clause has    | */
/*            retry(Adj2) if more than 2 |  atmj as 1st arg,             | */
/*              :                        |  else LabAtmj = Adj1          | */
/*            trust(Adjk)                /                               | */
/*                                 if there are atms, else LabAtm=LabFail/ */
/*   idem for switch_on_integer                                            */
/*                                                                         */
/*   LabLst : try(Adj1)                  \  if more than 1 clause has    | */
/*            retry(Adj2) if more than 2 |  [_|_] as 1st arg,            | */
/*              :                        |  else LabLst = Adj1           | */
/*            trust(Adjk)                /                               | */
/*                                 if there are lsts, else LabLst=LabFail/ */
/*                                                                         */
/*   LabStc : switch_on_structure(N,[(stc1,LabStc1),...(stcN,LabStcN)])  \ */
/*                                                                       | */
/*   LabStcj: try(Adj1)                  \  if more than 1 clause has    | */
/*            retry(Adj2) if more than 2 |  stcj as 1st arg,             | */
/*              :                        |  else LabStcj = Adj1          | */
/*            trust(Adjk)                /                               | */
/*                                 if there are stcs, else LabStc=LabFail/ */
/*                                                                         */
/*   LabVar:  try_me_else(LabVar2) if there are more than 1 clause in Gi,  */
/*   Ad1:     <code for clause 1>  else LabVar = Ad1                       */
/*                                                                         */
/*   LabVar2: retry_me_else(LabVar3)                                       */
/*   Ad2:     <code for clause 2>                                          */
/*                :                                                        */
/*                :                                                        */
/*   LabVarp: trust_me_else_fail                                           */
/*   Adp:     <code for clause p>                                          */
/*                                                                         */
/* LCC: [cl(Ad,FirstArg,WamCl), ...] list of compiled clauses for Pred.    */
/*                                                                         */
/*       Ad      : will contain (in level 2) the label associated to WamCl */
/*                 (initially Ad is an unbound variable).                  */
/*       FirstArg: the first argument of the source clause.                */
/*       WamCl   : [wam_inst, ...] clause wam code.                        */
/*                                                                         */
/* look_for_var partitions LCC in LCCBefore, CCVar and LCCAfter and detects*/
/* the current case:                                                       */
/*                                                                         */
/*   1...) a variables has been found (thus level 1), sub-cases:           */
/*    11) LCCBefore<>[] and LCCAfter<>[]  12) LCCBefore<>[] and LCCAfter=[]*/
/*    13) LCCBefore= [] and LCCAfter<>[]  14) LCCBefore= [] and LCCAfter=[]*/
/*                                                                         */
/*   2) no variables (thus level 2).                                       */
/*                                                                         */
/* other used variables:                                                   */
/*                                                                         */
/* Lev1: has any try/retry/trust_me_else been generated for level 1 (t/f)? */
/* Atm : [a(atm,[Ad, ...]), ...]                                           */
/* Int : [a(int,[Ad, ...]), ...]                                           */
/* Lst : [Ad, ...]                                                         */
/* Stc : [a(f/n,[Ad, ...]), ...]                                           */
/* List: Atm, Int, or Stc for general processings                          */
/*                                                                         */
/* Note on labels:                                                         */
/*    Labels are consecutive integers from 1 to n without "holes".         */
/*    Each label is first referenced and later defined.                    */
/*-------------------------------------------------------------------------*/

indexing(LCC,WamCode1):-
	indexing1(LCC,f,_,[_|WamCode]),    % ignore the first unused label(0)
	cur_pred(Pred,N),
	(test_pred_info(cut,Pred,N)
            -> WamCode1=[load_cut_level(N)|WamCode]
            ;  WamCode1=WamCode),
	allocate_labels(WamCode1,1,_).




indexing1(LCC,Lev1,Lab,[label(Lab)|WamCode]):-
	look_for_var(LCC,Case,LCCBefore,CCVar,LCCAfter),
	mk_indexing(Case,LCCBefore,CCVar,LCCAfter,Lev1,WamCode),
	!.




look_for_var([],2,[],_,[]).

look_for_var([cl(Ad,var,WamCl)|LCC],Case,[],cl(Ad,var,WamCl),LCC):-
	!,
	(LCC=[] -> Case=14
	        ;  Case=13).

look_for_var([CC|LCC],Case1,[CC|LCCBefore],CCVar,LCCAfter):-
	look_for_var(LCC,Case,LCCBefore,CCVar,LCCAfter),
	(Case=13 -> Case1=11
 	         ;  (Case=14 -> Case1=12
	                     ;  Case1=Case)).




mk_indexing(11,LCCBefore,cl(_,_,WamCl),LCCAfter,Lev1,WamCode):-
	(Lev1=f -> TmRmTm=try_me_else(Lab)
	        ;  TmRmTm=retry_me_else(Lab)),
	mk_indexing(2,LCCBefore,_,_,f,WamBefore),
	indexing1(LCCAfter,t,Lab1,WamAfter),
	WamCode=[TmRmTm,WamBefore,label(Lab),retry_me_else(Lab1),WamCl|WamAfter].

mk_indexing(12,LCCBefore,cl(_,_,WamCl),_,Lev1,WamCode):-
	(Lev1=f -> TmRmTm=try_me_else(Lab)
	        ;  TmRmTm=retry_me_else(Lab)),
	mk_indexing(2,LCCBefore,_,_,f,WamBefore),
	WamCode=[TmRmTm,WamBefore,label(Lab),trust_me_else_fail|WamCl].

mk_indexing(13,_,cl(_,_,WamCl),LCCAfter,Lev1,WamCode):-
	(Lev1=f -> TmRmTm=try_me_else(Lab)
	        ;  TmRmTm=retry_me_else(Lab)),
	indexing1(LCCAfter,t,Lab,WamAfter),
	WamCode=[TmRmTm,WamCl|WamAfter].

mk_indexing(14,_,cl(_,_,WamCl),_,Lev1,WamCode):-
	(Lev1=f -> WamCode=WamCl 
	        ;  WamCode=[trust_me_else_fail|WamCl]).

mk_indexing(2,LCC,_,_,Lev1,WamCode):-
	(Lev1=f -> WamCode=[switch_on_term(LabVar,LabAtm,LabInt,
	                                   LabLst,LabStc)|WamCode1]
	        ;  WamCode=[trust_me_else_fail,
	                    switch_on_term(LabVar,LabAtm,LabInt,
	                                   LabLst,LabStc)|WamCode1]),
	split(LCC,Atm,Int,Lst,Stc),
	!,
	(Atm=[]  -> LabAtm=LabFail, Fail=t
	         ;  true),
	(Int=[]  -> LabInt=LabFail, Fail=t
	         ;  true),
	(Lst=[]  -> LabLst=LabFail, Fail=t
	         ;  true),
	(Stc=[]  -> LabStc=LabFail, Fail=t
	         ;  true),
	(Fail==t -> WamCode1=WamSwtAtm,  % or WamCode1=[label(LabFail),fail|
                    LabFail=fail         %              WamSwtAtm] 
	         ;
		    WamCode1=WamSwtAtm),
	gen_switch(Atm,switch_on_atom,LabAtm,WamSwtInt,WamSwtAtm),
	gen_switch(Int,switch_on_integer, LabInt,WamLst,WamSwtInt),   
	gen_list(Lst,LabLst,WamSwtStc,WamLst),                        
	gen_switch(Stc,switch_on_structure,LabStc,WamCode2,WamSwtStc),
	gen_insts(LCC,LabVar,WamCode2).




split(LCC,Atm1,Int1,Lst,Stc1):- 
	split1(LCC,[],[],a(End,End),[],Atm,Int,a([],Lst),Stc),
	terminate_list(Atm,Atm1),
	terminate_list(Int,Int1),
	terminate_list(Stc,Stc1).


split1([],Atm,Int,Lst,Stc,Atm,Int,Lst,Stc).

split1([cl(Ad,FirstArg,_)|LCC],Atm,Int,Lst,Stc,Atm2,Int2,Lst2,Stc2):-
	split2(FirstArg,Ad,Atm,Int,Lst,Stc,Atm1,Int1,Lst1,Stc1),
	split1(LCC,Atm1,Int1,Lst1,Stc1,Atm2,Int2,Lst2,Stc2).


split2(atm(A),Ad,Atm,Int,Lst,Stc,Atm1,Int,Lst,Stc):-
	add_to_list(Atm,A,Ad,Atm1).

split2(int(N),Ad,Atm,Int,Lst,Stc,Atm,Int1,Lst,Stc):-
	add_to_list(Int,N,Ad,Int1).

split2(lst,Ad,Atm,Int,a([Ad|End],LAd),Stc,Atm,Int,a(End,LAd),Stc).

split2(stc(F,N),Ad,Atm,Int,Lst,Stc,Atm,Int,Lst,Stc1):-
	add_to_list(Stc,F/N,Ad,Stc1).




add_to_list([],F,Ad,[a(F,End,[Ad|End])]).

add_to_list([a(F,[Ad|End],LAd)|List],F,Ad,[a(F,End,LAd)|List]):-
	!.

add_to_list([X|List],F,Ad,[X|List1]):-
	add_to_list(List,F,Ad,List1).




terminate_list([],[]).

terminate_list([a(F,[],LAd)|L],[a(F,LAd)|L1]):-
	terminate_list(L,L1).




gen_switch([],_,_,LNext,LNext):-
	!.

    % if only 1 element with only 1 clause, no switch (remove if needed)

gen_switch([a(_,[Ad])],_,Ad,LNext,LNext):-
	!.

    % if only 1 element with n clauses, no switch (remove if needed)
/*
gen_switch([a(_,LAd)],_,Lab,LNext,WamTRT):-
	!,
	gen_list(LAd,Lab,LNext,WamTRT).
*/
gen_switch(List,Ins,Lab,LNext,[label(Lab),SwtW|WamTRT]):-
	create_switch_list(List,LSwt,LNext,WamTRT),
	SwtW=..[Ins,LSwt].




create_switch_list([],[],LNext,LNext).

create_switch_list([a(F,LAd)|List],[(F,Lab)|LSwt],LNext,WamTRT):-
	gen_list(LAd,Lab,WamTRT1,WamTRT),
	create_switch_list(List,LSwt,LNext,WamTRT1).




gen_list([],_,LNext,LNext).

gen_list([Ad],Ad,LNext,LNext):-                   % only 1 Atmj, Lst or Stcj
	!.

gen_list([Ad|LAd],Lab,LNext,WamRT1):-             % 2..n
	WamRT1=[label(Lab),try(Ad)|WamRT],
	gen_list1(LAd,LNext,WamRT).


gen_list1([Ad],LNext,[trust(Ad)|LNext]).

gen_list1([Ad|LAd],LNext,WamRT1):-
	WamRT1=[retry(Ad)|WamRT],
	gen_list1(LAd,LNext,WamRT).




gen_insts([cl(Ad,_,WamCl)],Ad,[label(Ad)|WamCl]):-    % only 1 clause
	!.
	
gen_insts([cl(Ad,_,WamCl)|LCC],Lab,WamCode2):-        % 2..n
	gen_insts1(LCC,Lab1,WamCode),
	WamCode2=[label(Lab),try_me_else(Lab1),label(Ad),WamCl|WamCode].



gen_insts1([cl(Ad,_,WamCl)],Lab,[label(Lab),trust_me_else_fail,label(Ad)|WamCl]):-
	!.

gen_insts1([cl(Ad,_,WamCl)|LCC],Lab,WamCode2):-
	gen_insts1(LCC,Lab1,WamCode),
	WamCode2=[label(Lab),retry_me_else(Lab1),label(Ad),WamCl|WamCode].




allocate_labels([],N,N):-
	!.

allocate_labels([WamInst1|WamInst2],N,N2):-
	!,
	allocate_labels(WamInst1,N,N1),                % for nested lists
	allocate_labels(WamInst2,N1,N2).

allocate_labels(label(N),N,N1):-
	!,
	N1 is N+1.

allocate_labels(_,N,N).
/*-------------------------------------------------------------------------*/
/* GNU Prolog                                                              */
/*                                                                         */
/* Part  : Prolog to WAM compiler                                          */
/* File  : inst_codif.pl                                                   */
/* Descr.: instruction codification (needed for register allocation)       */
/* Author: Daniel Diaz                                                     */
/*                                                                         */
/* Copyright (C) 1999 Daniel Diaz                                          */
/*                                                                         */
/* GNU Prolog is free software; you can redistribute it and/or modify it   */
/* under the terms of the GNU General Public License as published by the   */
/* Free Software Foundation; either version 2, or any later version.       */
/*                                                                         */
/* GNU Prolog is distributed in the hope that it will be useful, but       */
/* WITHOUT ANY WARRANTY; without even the implied warranty of              */
/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU        */
/* General Public License for more details.                                */
/*                                                                         */
/* You should have received a copy of the GNU General Public License along */
/* with this program; if not, write to the Free Software Foundation, Inc.  */
/* 59 Temple Place - Suite 330, Boston, MA 02111, USA.                     */
/*-------------------------------------------------------------------------*/


          /* alias stopping instructions */

alias_stop_instruction(InstW):-
	functor(InstW,F,_),
	(F=call ; F=execute),
	!.




          /* instruction codification */

codification(WamInst,LCode):-
	codif(WamInst,LCode),
	!.


codif(get_variable(x(Tmp),Arg),         [c(Arg,Tmp)]).
	
codif(get_value(x(Tmp),Arg),            [r(Tmp), r(Arg)]).

codif(get_variable(y(_),Arg),           [r(Arg)]).

codif(get_value(y(_),Arg),              [r(Arg)]).

codif(get_atom(_,Arg),                  [r(Arg)]).

codif(get_integer(_,Arg),               [r(Arg)]).

codif(get_float(_,Arg),                 [r(Arg)]).

codif(get_nil(Arg),                     [r(Arg)]).

codif(get_list(Reg),                    [r(Reg)]).

codif(get_structure(_,Reg),             [r(Reg)]).

codif(put_variable(x(Tmp),Arg),         [w(Tmp), w(Arg)]).

codif(put_void(Arg),                    [w(Arg)]).

codif(put_value(x(Tmp),Arg),            [c(Tmp,Arg)]).

codif(put_variable(y(_),Arg),           [w(Arg)]).

codif(put_value(y(_),Arg),              [w(Arg)]).

codif(put_unsafe_value(y(_),Arg),       [w(Arg)]).

codif(put_atom(_,Arg),                  [w(Arg)]).

codif(put_integer(_,Arg),               [w(Arg)]).

codif(put_float(_,Arg),                 [w(Arg)]).

codif(put_nil(Arg),                     [w(Arg)]).

codif(put_list(Reg),                    [w(Reg)]).

codif(put_structure(_,Reg),             [w(Reg)]).

codif(math_load_value(x(Reg),Tmp),      [r(Reg), w(Tmp)]).

codif(math_load_value(y(_),Tmp),        [w(Tmp)]).

codif(math_fast_load_value(x(Reg),Tmp), [r(Reg), w(Tmp)]).

codif(math_fast_load_value(y(_),Tmp),   [w(Tmp)]).

codif(unify_variable(x(Tmp)),           [w(Tmp)]).

codif(unify_value(x(Tmp)),              [r(Tmp)]).

codif(unify_local_value(x(Tmp)),        [r(Tmp)]).

codif(call(_/N),                        LCode):-
	lst_r_for_call_execute(0,N,LCode).

codif(execute(_/N),                     LCode):-
	lst_r_for_call_execute(0,N,LCode).

codif(load_cut_level(Tmp),              [w(Tmp)]).

codif(cut(x(Tmp)),                      [r(Tmp)]).

codif(function(_,Reg,LReg),             LCode):-
	lst_r_for_function(LReg,Reg,LCode).

codif(call_c(_,LReg),                   LCode):-
	lst_rw_for_call_c(LReg,[],LCode).

codif(call_c_test(_,LReg),              LCode):-
	lst_rw_for_call_c(LReg,[],LCode).

codif(call_c_jump(_,LReg),              LCode):-
	lst_rw_for_call_c(LReg,[],LCode).

codif(foreign_call_c(_,_,LReg,_),       LCode):-
	lst_rw_for_call_c(LReg,[],LCode).

	% instructions which use no temporaries

codif(_,                                []).




lst_r_for_call_execute(N,N,[]).

lst_r_for_call_execute(I,N,[r(I)|L]):-
	I1 is I+1,
	lst_r_for_call_execute(I1,N,L).




lst_r_for_function([],WReg,[w(WReg)]).

lst_r_for_function([Reg|LReg],WReg,[r(Reg)|LCode]):-
	lst_r_for_function(LReg,WReg,LCode).




lst_rw_for_call_c([],End,End).

lst_rw_for_call_c([Reg|LReg],End,[r(Reg)|LCode]):-
	lst_rw_for_call_c(LReg,[w(Reg)|End],LCode).


/*-------------------------------------------------------------------------*/
/* GNU Prolog                                                              */
/*                                                                         */
/* Part  : Prolog to WAM compiler                                          */
/* File  : internal.pl                                                     */
/* Descr.: pass 2: internal format transformation                          */
/* Author: Daniel Diaz                                                     */
/*                                                                         */
/* Copyright (C) 1999 Daniel Diaz                                          */
/*                                                                         */
/* GNU Prolog is free software; you can redistribute it and/or modify it   */
/* under the terms of the GNU General Public License as published by the   */
/* Free Software Foundation; either version 2, or any later version.       */
/*                                                                         */
/* GNU Prolog is distributed in the hope that it will be useful, but       */
/* WITHOUT ANY WARRANTY; without even the implied warranty of              */
/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU        */
/* General Public License for more details.                                */
/*                                                                         */
/* You should have received a copy of the GNU General Public License along */
/* with this program; if not, write to the Free Software Foundation, Inc.  */
/* 59 Temple Place - Suite 330, Boston, MA 02111, USA.                     */
/*-------------------------------------------------------------------------*/

/*-------------------------------------------------------------------------*/
/* predicate internal format: (I(t)=internal format of t)                  */
/*                                                                         */
/* I(p(Arg1,...,ArgN))= p(NoPred,Pred/N,[I(Arg1),...,I(ArgN)])             */
/*                                                                         */
/* NoPred : predicate number = corresponding chunk number                  */
/*                                                                         */
/* Pred/N : predicate/arity                                                */
/*                                                                         */
/* I(Argi): internal format of the ith argument                            */
/*                                                                         */
/*    var          : var(VarName,Info) with:                               */
/*                                                                         */
/*                   VarName=x(NoX) temporary (in pass 2 NoX is unbound or */
/*                                  assigned to void if var is singleton)  */
/*                           y(NoY) permanent (in pass 2 NoY is assigned)  */
/*                   Info   =in_heap       : the var is stored in the heap */
/*                           unsafe        : the var refers cur env.       */
/*                           not_in_cur_env: the var doesn't reside in the */
/*                                           current environment           */
/*                           in pass 2 Info or remains unbound             */
/*                                                                         */
/*    atom []      : nil                                                   */
/*    atom (others): atm(atom)                                             */
/*    integer      : int(integer)                                          */
/*    float        : flt(float)                                            */
/*    f(A1,...,An) : stc(f,n,[I(A1),...,I(An)])  ([H|T] = '.'(H,T))        */
/*                                                                         */
/* NB: true/0 in the body of a clause is removed.                          */
/*     variables are classified and permanent variables are assigned       */
/*     (temporary=x(_), permanent=y(i))                                    */
/*-------------------------------------------------------------------------*/

internal_format(Head,Body,Head1,Body1,NbChunk,NbY):-         
	format_head(Head,DicoVar,Head1),
	format_body(Body,DicoVar,Body1,NbChunk),
	classif_vars(DicoVar,0,NbY).




format_head(Head,DicoVar,Head1):- 
	format_pred(Head,0,DicoVar,Head1,_).




format_body(Body,DicoVar,Body1,NbChunk):-
	format_body1(Body,0,DicoVar,t,[],Body1,NbChunk,_).

format_body1((P,Q),NoPred,DicoVar,StartChunk,LNext,P1,NoPred2,StartChunk2):-
	!,
	format_body1(P,NoPred,DicoVar,StartChunk,Q1,P1,NoPred1,StartChunk1),
	format_body1(Q,NoPred1,DicoVar,StartChunk1,LNext,Q1,NoPred2,StartChunk2).

format_body1(true,NoPred,_,StartChunk,LNext,LNext,NoPred,StartChunk):-
	!.

format_body1(Pred,NoPred,DicoVar,StartChunk,LNext,[Pred1|LNext],
	       NoPred1,StartChunk1):-
	(StartChunk=t -> NoPred1 is NoPred+1
	              ;  NoPred1=NoPred),
	format_pred(Pred,NoPred1,DicoVar,Pred1,InlinePred),
	(InlinePred=t -> StartChunk1=f
	              ;  StartChunk1=t).




format_pred(Pred,NoPred,DicoVar,p(NoPred,F/N,ArgLst1),InlinePred):-
	functor(Pred,F,N),
	Pred=..[_|ArgLst],
	format_arg_lst(ArgLst,NoPred,DicoVar,ArgLst1),
	(inline_predicate(F,N) -> InlinePred=t 
	                       ;  InlinePred=f).




format_arg_lst([],_,_,[]).

format_arg_lst([Arg|ArgLst],NoPred,DicoVar,[Arg1|ArgLst1]):-
	format_arg(Arg,NoPred,DicoVar,Arg1),
	!,
	format_arg_lst(ArgLst,NoPred,DicoVar,ArgLst1).




format_arg(Var,NoPred,DicoVar,V):-
	var(Var),
	add_var_to_dico(DicoVar,Var,NoPred,V).

format_arg([],_,_,nil).

format_arg(A,_,_,atm(A)):-
	atom(A).

format_arg(N,_,_,int(N)):-
	integer(N).

format_arg(N,_,_,flt(N)):-
	float(N).

format_arg(Fonc,NoPred,DicoVar,stc(F,N,ArgLst1)):-
	functor(Fonc,F,N),
	Fonc=..[_|ArgLst],
	format_arg_lst(ArgLst,NoPred,DicoVar,ArgLst1).




          % DicoVar=[ v(Var,NoPred1stOcc,Singleton,V), ... | EndVar ]
          %
          % Singleton = f or unbound variable
          % V=var(VarName,VarInfo)
          % VarName=x(_) or y(_)  
          % Info=unbound or singleton

add_var_to_dico(DicoVar,Var,NoPred1stOcc,V):-
	var(DicoVar),
	!,
	V=var(_,_),
	DicoVar=[v(Var,NoPred1stOcc,_,V)|_].

add_var_to_dico([v(Var1,NoPred1stOcc1,Singleton,V)|_],Var2,NoPred1stOcc2,V):-
	Var1==Var2,
	!,
	V=var(VarName,_),
	Singleton=f,
	(var(VarName), NoPred1stOcc1\==NoPred1stOcc2, NoPred1stOcc2>1
                -> VarName=y(_)
                ;  true).

add_var_to_dico([_|DicoVar],Var,NoPred1stOcc,V):-
	add_var_to_dico(DicoVar,Var,NoPred1stOcc,V).




classif_vars([],NbY,NbY):-
	!.

classif_vars([v(_,_,Singleton,var(VarName,_))|DicoVar],Y,NbY):-
	var(VarName),
	!,
	(var(Singleton) -> VarName=x(void)
                        ;  VarName=x(_)),
	classif_vars(DicoVar,Y,NbY).

classif_vars([v(_,_,_,var(y(Y),_))|DicoVar],Y,NbY):-
	Y1 is Y+1,
	classif_vars(DicoVar,Y1,NbY).




	% Inline predicates: inline_predicate(Pred,Arity)
	% all predicates defined here must have a corresponding clause 
	% gen_inline_pred/5 in pass 3 describing their associated code

inline_predicate(Pred,Arity):-
	g_read(inline,Inline),
	inline_predicate(Pred,Arity,Inline).




inline_predicate('$get_cut_level',1,_).         % must be an inline predicate
inline_predicate('$cut',1,_).                   % must be an inline predicate




inline_predicate(CallC,1,_):-                   % must be an inline predicate
	(CallC='$call_c' ; CallC='$call_c_test' ; CallC='$call_c_jump'),
	!,
	test_call_c_allowed(CallC/1).

inline_predicate((=),2,_).                      % must be an inline predicate

inline_predicate('$foreign_call_c',7,_).        % must be an inline predicate


inline_predicate(var,1,t).

inline_predicate(nonvar,1,t).

inline_predicate(atom,1,t).

inline_predicate(integer,1,t).

inline_predicate(float,1,t).

inline_predicate(number,1,t).

inline_predicate(atomic,1,t).

inline_predicate(compound,1,t).

inline_predicate(callable,1,t).

inline_predicate(list,1,t).

inline_predicate(partial_list,1,t).

inline_predicate(list_or_partial_list,1,t).


inline_predicate(fd_var,1,t).

inline_predicate(non_fd_var,1,t).

inline_predicate(generic_var,1,t).

inline_predicate(non_generic_var,1,t).




inline_predicate(functor,3,t).

inline_predicate(arg,3,t).

inline_predicate(compare,3,t).

inline_predicate((=..),2,t).



inline_predicate((==),2,t).

inline_predicate((\==),2,t).

inline_predicate((@<),2,t).

inline_predicate((@=<),2,t).

inline_predicate((@>),2,t).

inline_predicate((@>=),2,t).




inline_predicate(is,2,t).

inline_predicate((=:=),2,t).

inline_predicate((=\=),2,t).

inline_predicate((<),2,t).

inline_predicate((=<),2,t).

inline_predicate((>),2,t).

inline_predicate((>=),2,t).




inline_predicate(g_assign,2,t).

inline_predicate(g_assignb,2,t).

inline_predicate(g_link,2,t).

inline_predicate(g_read,2,t).

inline_predicate(g_array_size,2,t).
/*-------------------------------------------------------------------------*/
/* GNU Prolog                                                              */
/*                                                                         */
/* Part  : Prolog to WAM compiler                                          */
/* File  : make_bip_list.pl                                                */
/* Descr.: bip file generator                                              */
/* Author: Daniel Diaz                                                     */
/*                                                                         */
/* Copyright (C) 1999 Daniel Diaz                                          */
/*                                                                         */
/* GNU Prolog is free software; you can redistribute it and/or modify it   */
/* under the terms of the GNU General Public License as published by the   */
/* Free Software Foundation; either version 2, or any later version.       */
/*                                                                         */
/* GNU Prolog is distributed in the hope that it will be useful, but       */
/* WITHOUT ANY WARRANTY; without even the implied warranty of              */
/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU        */
/* General Public License for more details.                                */
/*                                                                         */
/* You should have received a copy of the GNU General Public License along */
/* with this program; if not, write to the Free Software Foundation, Inc.  */
/* 59 Temple Place - Suite 330, Boston, MA 02111, USA.                     */
/*-------------------------------------------------------------------------*/

q:-
	set_prolog_flag(strict_iso,off),
	write('/* this file is automatically generated by make_bip_list.pl */'),
	nl,
	pl_bips,
	fd_bips.

pl_bips:-
	findall(F-P,(predicate_property(P,built_in),
                    predicate_property(P,prolog_file(F))),
                L),
	keysort(L,L1),
	display_bips(L1,false).

fd_bips:-
	findall(F-P,(predicate_property(P,built_in_fd),
                    predicate_property(P,prolog_file(F))),
                L),
	keysort(L,L1),
	display_bips(L1,false).




display_bips([],_).

display_bips([F-P|L],F0):-
	treat_file(F,F0),
	P=Func/Arity,
	format('bip(~q,~d).~n',[Func,Arity]),
	display_bips(L,F).



treat_file(X,X):-
	!.

treat_file(New,_):-
	format('~n%% defined in ~a~n~n',[New]).

	

:- initialization(q).
/*-------------------------------------------------------------------------*/
/* GNU Prolog                                                              */
/*                                                                         */
/* Part  : Prolog to WAM compiler                                          */
/* File  : pl2wam.pl                                                       */
/* Descr.: main file                                                       */
/* Author: Daniel Diaz                                                     */
/*                                                                         */
/* Copyright (C) 1999 Daniel Diaz                                          */
/*                                                                         */
/* GNU Prolog is free software; you can redistribute it and/or modify it   */
/* under the terms of the GNU General Public License as published by the   */
/* Free Software Foundation; either version 2, or any later version.       */
/*                                                                         */
/* GNU Prolog is distributed in the hope that it will be useful, but       */
/* WITHOUT ANY WARRANTY; without even the implied warranty of              */
/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU        */
/* General Public License for more details.                                */
/*                                                                         */
/* You should have received a copy of the GNU General Public License along */
/* with this program; if not, write to the Free Software Foundation, Inc.  */
/* 59 Temple Place - Suite 330, Boston, MA 02111, USA.                     */
/*-------------------------------------------------------------------------*/

pl2wam(Args):-
	catch(pl2wam1(Args),Err,exception(Err)).




pl2wam1(Args):-
	cmd_line_args(Args,PlFile,WamFile),
	prolog_file_name(PlFile,PlFile1),
	read_file_init(PlFile),
	emit_code_init(WamFile,PlFile),
	g_read(native_code,NativeCode),
	compile_msg_start(PlFile1,NativeCode),
	init_counters,
	repeat,
	read_predicate(Pred,N,LSrcCl),
	add_counter(user_read_file,real_read_file),
	(LSrcCl=[]                                    /* [] at end of file */
              -> !
              ;
	         read_file_error_nb(0),
                 compile_and_emit_pred(NativeCode,Pred,N,LSrcCl),
	         fail),
	emit_ensure_linked,
	read_file_term(InBytes,InLines),
	emit_code_term(OutBytes,OutLines),
	read_file_error_nb(ErrNb),
	(ErrNb=0 -> display_counters,
                    compile_msg_end(PlFile1,InBytes,InLines,OutBytes,OutLines)
                 ;
                    format('~N\t~d error(s)~n',[ErrNb]),
                    abort).




compile_and_emit_pred(t,Pred,N,LSrcCl):-
	compile_emit_inits(Pred,N,LSrcCl,PlFile,PlLine),
	compile_lst_clause(LSrcCl,LCompCl),
	indexing(LCompCl,WamCode),
	add_counter(user_indexing,real_indexing),
	emit_code(Pred,N,PlFile,PlLine,WamCode),
	add_counter(user_wam_emit,real_wam_emit).

compile_and_emit_pred(f,Pred,N,LSrcCl):-
	compile_emit_inits(Pred,N,LSrcCl,PlFile,PlLine),
	bc_compile_lst_clause(LSrcCl,LCompCl),
	bc_emit_code(Pred,N,PlFile,PlLine,LCompCl),
	add_counter(user_wam_emit,real_wam_emit).




compile_emit_inits(Pred,N,LSrcCl,PlFile1,PlLine):-
	g_assign(cur_func,Pred),
	g_assign(cur_arity,N),
	syntactic_sugar_init_pred(Pred,N),
	LSrcCl=[[PlFile*_|_]+(PlLine-_) + _|_],
	absolute_file_name(PlFile,PlFile1).




compile_lst_clause([],[]).

compile_lst_clause([SrcCl|LSrcCl],[cl(_,FirstArg,WamCl)|LCC]):-
	compile_clause(SrcCl,FirstArg,WamCl),
	compile_lst_clause(LSrcCl,LCC).




compile_clause(Where+Cl,FirstArg,WamCl):-
	g_assign(where,Where),
	syntactic_sugar(Cl,Head,Body),
	add_counter(user_syn_sugar,real_syn_sugar),
	internal_format(Head,Body,Head1,Body1,NbChunk,NbY),
	add_counter(user_internal,real_internal),
	code_generation(Head1,Body1,NbChunk,NbY,WamCl),
	add_counter(user_code_gen,real_code_gen),
	allocate_registers(WamCl),
	add_counter(user_reg_alloc,real_reg_alloc),
	find_first_arg(WamCl,FirstArg),
	add_counter(user_first_arg,real_first_arg).




bc_compile_lst_clause([],[]).

bc_compile_lst_clause([SrcCl|LSrcCl],[bc(Cl,WamCl)|LCC]):-
	SrcCl=_+Cl,
	compile_clause(SrcCl,_FirstArg,WamCl),
	bc_compile_lst_clause(LSrcCl,LCC).



compile_msg_start(_,_):-
	g_read(compile_msg,f),
	!.

compile_msg_start(PlFile,NativeCode):-
	(NativeCode=t -> Type='native code'
                      ;  Type='byte code'),
	format('compiling ~a for ~a...~n',[PlFile,Type]).




compile_msg_end(_,_,_,_,_):-
	g_read(compile_msg,f),
	!.

compile_msg_end(PlFile,_InBytes,InLines,OutBytes,_OutLines):-
	real_time(Time),
	format('~a compiled, ~d lines read - ~d bytes written, ~d ms~n',
               [PlFile,InLines,OutBytes,Time]).




cur_pred(Func,Arity):-
	g_read(cur_func,Func),
	g_read(cur_arity,Arity).


cur_pred_without_aux(Func1,Arity1):-
	cur_pred(Func,Arity),
	'$pred_without_aux'(Func,Arity,Func1,Arity1).




init_counters:-
	g_read(statistics,f),
	!.

init_counters:-
	g_assign(user_read_file,0), g_assign(real_read_file,0),
	g_assign(user_syn_sugar,0), g_assign(real_syn_sugar,0),
	g_assign(user_internal, 0), g_assign(real_internal, 0), 
	g_assign(user_code_gen, 0), g_assign(real_code_gen, 0), 
	g_assign(user_reg_alloc,0), g_assign(real_reg_alloc,0),
	g_assign(user_indexing, 0), g_assign(real_indexing, 0), 
	g_assign(user_first_arg,0), g_assign(real_first_arg,0), 
	g_assign(user_wam_emit, 0), g_assign(real_wam_emit, 0),
	last_times(_,_).




add_counter(_,_):-
	g_read(statistics,f),
	!.

add_counter(UserCounter,RealCounter):-
	last_times(User1,Real1),
	g_read(UserCounter,User2),
	g_read(RealCounter,Real2),
	User is User1+User2,
	Real is Real1+Real2,
	g_assign(UserCounter,User),
	g_assign(RealCounter,Real).




last_times(User,Real):-
	statistics(real_time,[_,Real]),
	statistics(runtime,  [_,User]).

	


display_counters:-
	g_read(statistics,f),
	!.

display_counters:-
	g_read(user_read_file,UReadFile), g_read(real_read_file,RReadFile),
	g_read(user_syn_sugar,USynSugar), g_read(real_syn_sugar,RSynSugar),
	g_read(user_internal, UInternal), g_read(real_internal, RInternal), 
	g_read(user_code_gen, UCodeGen),  g_read(real_code_gen, RCodeGen),  
	g_read(user_reg_alloc,URegAlloc), g_read(real_reg_alloc,RRegAlloc),
	g_read(user_indexing, UIndexing), g_read(real_indexing, RIndexing),
	g_read(user_first_arg,UFirstArg), g_read(real_first_arg,RFirstArg), 
	g_read(user_wam_emit, UWamEmit),  g_read(real_wam_emit, RWamEmit),
	U is UReadFile+USynSugar+UInternal+UCodeGen+URegAlloc+
             UIndexing+UIndexing+UWamEmit,
	R is RReadFile+RSynSugar+RInternal+RCodeGen+RRegAlloc+
             RIndexing+RIndexing+RWamEmit,
       	user_time(UTotal),
	real_time(RTotal),
	UMisc is UTotal-U,
        RMisc is RTotal-R,
	format('   Statistics (in ms)     user     real~n',[]),
	format('   source reading     : %6d   %6d~n',[UReadFile,RReadFile]),
	format('   syntactic sugar    : %6d   %6d~n',[USynSugar,RSynSugar]),
	format('   internal format    : %6d   %6d~n',[UInternal,RInternal]),
	format('   code generation    : %6d   %6d~n',[UCodeGen, RCodeGen ]),
	format('   register allocation: %6d   %6d~n',[URegAlloc,RRegAlloc]),
	format('   indexing           : %6d   %6d~n',[UIndexing,RIndexing]),
	format('   first arg computing: %6d   %6d~n',[UFirstArg,RFirstArg]),
	format('   code emission      : %6d   %6d~n',[UWamEmit, RWamEmit ]),
	format('   other              : %6d   %6d~n',[UMisc,    RMisc    ]),
	format('                Total : %6d   %6d~n',[UTotal,   RTotal   ]).




          /*--- command-line options reading ---*/

cmd_line_args(Args,PlFile,WamFile):-
	g_assign(plfile,''),
	g_assign(wamfile,''),
	g_assign(inline,t),
	g_assign(reorder,t),
	g_assign(reg_opt,2),
	g_assign(opt_last_subterm,t),
	g_assign(keep_void_inst,f),
	g_assign(susp_warn,t),
	g_assign(singl_warn,t),
	g_assign(redef_error,t),
	g_assign(fast_math,f),
	g_assign(native_code,t),
	g_assign(call_c,t),
	g_assign(statistics,f),
	g_assign(compile_msg,f),
	cmd_line_args(Args),
	g_read(plfile,PlFile),
	(PlFile='' -> format('no input file~n',[]), abort
                   ;  true),
	g_read(wamfile,WamFile).




cmd_line_args([]).

cmd_line_args([Arg|LArg]):-
	cmd_line_arg1(Arg,LArg,LArg1),
	!,
	cmd_line_args(LArg1).


cmd_line_arg1('-o',LArg,LArg1):-
	cmd_line_arg1('--output',LArg,LArg1).

cmd_line_arg1('--output',LArg,LArg1):-
	(LArg=[WamFile|LArg1], sub_atom(WamFile,0,1,_,Prefix), Prefix\==(-)
             ;
         format('FILE missing after --output option~n',[]), abort),
	g_read(wamfile,WamFile0),
	(WamFile0=''
           -> true
           ;  format('output file already specified (~a)~n',[WamFile0]),
              abort),
	g_assign(wamfile,WamFile).

cmd_line_arg1('--pl-state',[File|LArg],LArg):-
	read_pl_state_file(File),
	(current_prolog_flag(singleton_warning,off)
              -> g_assign(singl_warn,f)
              ;  true).

cmd_line_arg1('--no-inline',LArg,LArg):-
	g_assign(inline,f).

cmd_line_arg1('--no-reorder',LArg,LArg):-
	g_assign(reorder,f).

cmd_line_arg1('--no-reg-opt',LArg,LArg):-
	g_assign(reg_opt,0).

cmd_line_arg1('--min-reg-opt',LArg,LArg):-
	g_assign(reg_opt,1).

cmd_line_arg1('--no-opt-last-subterm',LArg,LArg):-
	g_assign(opt_last_subterm,f).

cmd_line_arg1('--fast-math',LArg,LArg):-
	g_assign(fast_math,t).

cmd_line_arg1('--keep-void-inst',LArg,LArg):-
	g_assign(keep_void_inst,t).

cmd_line_arg1('--no-susp-warn',LArg,LArg):-
	g_assign(susp_warn,f).

cmd_line_arg1('--no-singl-warn',LArg,LArg):-
	g_assign(singl_warn,f).

cmd_line_arg1('--no-redef-error',LArg,LArg):-
	g_assign(redef_error,f).

cmd_line_arg1('-W',LArg,LArg1):-
	cmd_line_arg1('--wam-for-native',LArg,LArg1).

cmd_line_arg1('--wam-for-native',LArg,LArg):-
	g_assign(native_code,t).

cmd_line_arg1('-w',LArg,LArg1):-
	cmd_line_arg1('--wam-for-byte-code',LArg,LArg1).

cmd_line_arg1('--wam-for-byte-code',LArg,LArg):-
	g_assign(native_code,f),
	g_assign(inline,f),                                % force -no-inline
	g_assign(call_c,f).                                % force -no-call-c

cmd_line_arg1('--no-call-c',LArg,LArg):-
	g_assign(call_c,f).

cmd_line_arg1('--statistics',LArg,LArg):-
	g_assign(statistics,t).

cmd_line_arg1('--compile-msg',LArg,LArg):-
	g_assign(compile_msg,t).

cmd_line_arg1('--version',LArg,LArg):-
	display_copying,
	stop.

cmd_line_arg1('-h',LArg,LArg1):-
	cmd_line_arg1('--help',LArg,LArg1).

cmd_line_arg1('--help',LArg,LArg):-
	(h(L), write(L), nl, fail
             ;
         nl, write('Report bugs to bug-prolog@gnu.org.'), nl, stop).

cmd_line_arg1(Arg,_,_):-
	sub_atom(Arg,0,1,_,'-'),
	format('unknown option ~a - try pl2wam --help~n',[Arg]),
	abort.

cmd_line_arg1(PlFile,LArg,LArg):-
	g_read(plfile,PlFile0),
	(PlFile0='' 
           -> true
           ;  format('input file already specified (~a)~n',[PlFile0]),
              abort),
	g_assign(plfile,PlFile).




          /*--- copying ---*/

display_copying:-
	current_prolog_flag(prolog_name,Name),
	current_prolog_flag(prolog_version,Version),
	current_prolog_flag(prolog_copyright,Copyright),
	format('Prolog to Wam Compiler (~a) ~a~n',[Name,Version]),
	format('By Daniel Diaz~n',[]),
	write(Copyright), nl,
	format('~a comes with ABSOLUTELY NO WARRANTY.~n',[Name]),
	format('You may redistribute copies of ~a~n',[Name]),
	format('under the terms of the GNU General Public License.~n',[]),
	format('For more information about these matters, see the files named COPYING.~n',[]).




          /*--- help ---*/

h('Usage: pl2wam [OPTION...] FILE').
h('').
h('Options:').
h('  -o FILE, --output FILE      set output file name').
h('  -W, --wam-for-native        produce a WAM file for native code').
h('  -w, --wam-for-byte-code     produce a WAM file for byte-code (force --no-call-c)').
h('  --pl-state FILE             read FILE to set the initial Prolog state').
h('  --no-inline                 do not inline predicates').
h('  --no-reorder                do not reorder predicate arguments').
h('  --no-reg-opt                do not optimize registers').
h('  --min-reg-opt               minimally optimize registers').
h('  --no-opt-last-subterm       do not optimize last subterm compilation').
h('  --fast-math                 fast mathematical mode (assume integer arithmetic)').
h('  --keep-void-inst            keep void instructions in the output file').
h('  --no-susp-warn              do not show warnings for suspicious predicates').
h('  --no-singl-warn             do not show warnings for named singleton variables').
h('  --no-redef-error            do not show errors for built-in redefinitions').
h('  --no-call-c                 do not allow the use of fd_tell, ''$call_c'',...').
h('  --compile-msg               print a compile message').
h('  --statistics                print statistics information').
h('  --help                      print this help and exit').
h('  --version                   print version number and exit').
h('').
h('''user'' can be given as FILE for the standard input/output').




          /*--- starting directive ---*/

go:- argument_list(L), pl2wam(L).

:- initialization(go).
/*-------------------------------------------------------------------------*/
/* GNU Prolog                                                              */
/*                                                                         */
/* Part  : Prolog to WAM compiler                                          */
/* File  : read_file.pl                                                    */
/* Descr.: source file reading                                             */
/* Author: Daniel Diaz                                                     */
/*                                                                         */
/* Copyright (C) 1999 Daniel Diaz                                          */
/*                                                                         */
/* GNU Prolog is free software; you can redistribute it and/or modify it   */
/* under the terms of the GNU General Public License as published by the   */
/* Free Software Foundation; either version 2, or any later version.       */
/*                                                                         */
/* GNU Prolog is distributed in the hope that it will be useful, but       */
/* WITHOUT ANY WARRANTY; without even the implied warranty of              */
/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU        */
/* General Public License for more details.                                */
/*                                                                         */
/* You should have received a copy of the GNU General Public License along */
/* with this program; if not, write to the Free Software Foundation, Inc.  */
/* 59 Temple Place - Suite 330, Boston, MA 02111, USA.                     */
/*-------------------------------------------------------------------------*/

/*-------------------------------------------------------------------------*/
/* Data structures:                                                        */
/*                                                                         */
/* the stack of opened files (for nested includes):                        */
/*    global variable open_file_stack = [PlFile*Stream,...]                */
/*    from last to first.                                                  */
/*                                                                         */
/* the context (where occurs an error):                                    */
/*    global variable where = OpenFileStack+(L1-L2)                        */
/*    L1 = first line of the current clause (resp. directive).             */
/*    L2 = last  line of the current clause (resp. directive).             */
/*                                                                         */
/* read_predicate(Pred,N,LSrcCl):                                          */
/*    the structure of the compiler is a repeat/fail loop on 1 predicate   */
/*    calling read_predicate(Pred,N,LSrcCl) to obtain next predicate.      */
/*    Pred   = predicate name (an atom).                                   */
/*    N      = arity (an integer >=0).                                     */
/*    LSrcCl = [SrcCl,...], list of source clauses, with                   */
/*     SrcCl = Where+Cl where Cl is the source clause read.                */
/*                                                                         */
/* Buffers for special predicate management (with assert/retract):         */
/*                                                                         */
/* buff_aux_pred(Pred,N,LSrcCl):                                           */
/*    records the clauses of an auxiliary predicate.                       */
/*    Asserted by Pass 1 (syntactic sugar removing) when splitting ;/2,etc.*/
/*    Retracted at the very next invocation of read_predicate/3 to         */
/*    ensure that aux. predicates always follow their "father" predicate.  */
/*                                                                         */
/* buff_discontig_clause(Pred,N,SrcCl):                                    */
/*    records a clause of a discontiguous predicate (:- discontiguous).    */
/*    Eacho clause of a discontiguous predicate is asserted when it is read*/
/*    When the end of file is reached all clauses of a discontiguous pred  */
/*    are grouped to return a list of source clauses LSrcCl.               */
/*    Thus discontiguous predicates are always compiled after other        */
/*    predicates.                                                          */
/*                                                                         */
/* buff_dyn_interf_clause(Pred,N,SrcCl):                                   */
/*    records the interface clause of a dynamic predicate (:- dynamic).    */
/*    This clause is of the form Head:- call(Head) and only ensures that   */
/*    an external invocation to this predicate will not need to know that  */
/*    it is dynamic (and should be called by call/1).                      */
/*    Asserted as soon as a :- dynamic directive is encountered.           */
/*    Retracted only when the end of file is reached. All other clauses of */
/*    a dynamic predicate give rise to a system executable directive to    */
/*    assert(z) it.                                                        */
/*                                                                         */
/* empty_dyn_pred(Pred,N,Where):                                           */
/*    asserted when the declaration of a dynamic predicate is encoutered   */
/*    (:- dynamic). Retracted when a clause of a dynamic predicate is read.*/
/*    At the end, only contains dynamic predicate with no clauses.         */
/*    Used then to define the interface clause.                            */
/*                                                                         */
/* ensure_linked(Pred,N):                                                  */
/*    asserted for each Pred/N occuring in a :- ensure_linked directive.   */
/*                                                                         */
/* Buffers for executable directive management (with assert/retract):      */
/*                                                                         */
/* buff_exe_system(SrcDirec)                                               */
/*     SrcDirec = Where+Body (i.e. source directive).                      */
/*     records a system directive.                                         */
/*     Asserted for dynamic clauses (to assertz it), and to execute, at    */
/*     run-time, op/3 set_prolog_flag/2, char_conversion/2.                */
/*     Retracted only when the end of file has been reached to provide a   */
/*     predicate '$exe_system':- Body.                                     */
/*                                                                         */
/* buff_exe_user(SrcDirec)                                                 */
/*     records user defined directives (:- initialization).                */
/*     Asserted when a :- initialization declaration is encountered.       */
/*     Retracted just after all '$buff_exe_system' to ensure that any user */
/*     directive has the needed environment.                               */
/*                                                                         */
/* Buffers for special clause management (with assert/retract):            */
/*                                                                         */
/* buff_clause(Pred,N,SrcCl):                                              */
/*    the reader needs a lookahead clause (to group clauses by predicates).*/
/*    For such a clause we assert/retract(buff_clause(Pred,N,SrcCl)).      */
/*    Read at the very next invocation of get_next_clause/3.               */
/*-------------------------------------------------------------------------*/

:- op(200,fx,?).

read_file_init(PlFile):-
	retractall(buff_clause(_,_,_)),
        retractall(buff_aux_pred(_,_,_)),
        retractall(buff_discontig_clause(_,_,_)),
	retractall(buff_dyn_interf_clause(_,_,_)),
	retractall(buff_exe_system(_)),
	retractall(buff_exe_user(_)),
	retractall(empty_dyn_pred(_,_,_)),
	retractall(ensure_linked(_,_)),
	retractall(pred_info(_,_,_)),
	g_assign(default_kind,user),
	g_assign(reading_dyn_pred,f),
	g_assign(eof_reached,f),
	g_assign(open_file_stack,[]),
	g_assign(where,0),
	g_assign(syn_error_nb,0),
	g_assign(in_lines,0),
	g_assign(in_bytes,0),
	open_new_prolog_file(PlFile).




read_file_term(Bytes,Lines):-
	g_read(in_bytes,Bytes),
	g_read(in_lines,Lines).




read_file_error_nb(SynErrNb):-
	g_read(syn_error_nb,SynErrNb).




open_new_prolog_file(PlFile0):-
	prolog_file_name(PlFile0,PlFile),
	(PlFile=user -> current_input(Stream)
                     ;  open(PlFile,read,Stream)),
	g_read(open_file_stack,OpenFileStack),
	g_assign(open_file_stack,[PlFile*Stream|OpenFileStack]).




close_last_prolog_file:-
	g_read(open_file_stack,[_*Stream|OpenFileStack]),
	g_assign(open_file_stack,OpenFileStack),
	g_read(in_bytes,Bytes1),
	g_read(in_lines,Lines1),
	character_count(Stream,Bytes2),
	line_count(Stream,Lines2),
	Bytes is Bytes1+Bytes2,
	Lines is Lines1+Lines2,
	g_assign(in_bytes,Bytes),
	g_assign(in_lines,Lines),
	close(Stream).




          /*------------------*/
          /* Read a predicate */
          /*------------------*/

read_predicate(Pred,N,LSrcCl):-
	repeat,
	read_predicate1(Pred,N,LSrcCl),              /* standard predicate */
%        !,
	(g_read(reading_dyn_pred,f), g_read(native_code,t)
             -> read_predicate_next(Pred,N,LSrcCl)
             ;  true).




read_predicate_next(Pred,N,LSrcCl):-
	test_pred_info(dyn,Pred,N),
	!,
	LSrcCl=[Where + _|_],
	add_dyn_interf_clause(Pred,N,Where),
	create_exe_clauses_for_dyn_pred(LSrcCl,Pred,N),
	fail.                          /* backtrack to repeat of main loop */

read_predicate_next(Pred,N,LSrcCl):-
	test_pred_info(pub,Pred,N),
	!,
	create_exe_clauses_for_pub_pred(LSrcCl).

read_predicate_next(_,_,_).




read_predicate1(Pred,N,LSrcCl):-
	retract(buff_aux_pred(Pred,N,LSrcCl)), /* aux. pred (cf syn_sugar) */
	!.

read_predicate1(Pred,N,LSrcCl):-
	g_read(eof_reached,f),
	!,
	repeat,
	get_next_clause(Pred,N,SrcCl),
	SrcCl=_+Cl,
	retractall(empty_dyn_pred(Pred,N,_)),
	(test_pred_info(discontig,Pred,N)
            -> assertz(buff_discontig_clause(Pred,N,SrcCl)),
	       define_predicate(Pred,N),
	       fail                        /* backtrack to read_predicate1 */
            ;
               true),
	(test_pred_info(def,Pred,N)
            -> warn('discontiguous predicate ~q - clause ignored',
                    [Pred/N]),
	       fail                        /* backtrack to read_predicate1 */
            ;
               true),
	!,
	Cl\==end_of_file,               /* if end_of_file is read, fail    */
                                        /* and backtrack to read_predicate */
        define_predicate(Pred,N),
	group_clauses_by_pred(Pred,N,SrcCl,LSrcCl).

read_predicate1(Pred,N,[SrcCl|LSrcCl]):-
	retract(buff_discontig_clause(Pred,N,SrcCl)),/* discontiguous pred */
        !,
	recover_discontig_clauses(Pred,N,LSrcCl).

read_predicate1(Pred,N,[SrcCl]):-
	g_assign(reading_dyn_pred,t),
	retract(buff_dyn_interf_clause(Pred,N,SrcCl)),    /* dyn predicate */
        !.

read_predicate1(Pred,N,[SrcCl]):-
	g_assign(reading_dyn_pred,t),
	retract(empty_dyn_pred(Pred,N,Where)),      /* empty dyn predicate */
        define_predicate(Pred,N),
        (g_read(native_code,t)
                -> create_dyn_interf_clause(Pred,N,Where,SrcCl)
                ;  SrcCl=Where+'$$empty$$predicate$$clause$$'),
        !.

read_predicate1(Pred,N,LSrcCl):-
	g_assign(reading_dyn_pred,f),
	retract(buff_exe_system(Where+Body)),     /* system exe directives */
        Pred='$exe_system', N=0, LSrcCl=[Where+(Pred:-Body)],
	!.

read_predicate1(Pred,N,LSrcCl):-
	retract(buff_exe_user(Where+Body)),         /* user exe directives */
        Pred='$exe_user', N=0, LSrcCl=[Where+(Pred:-Body)],
	!.

read_predicate1(Pred,N,LSrcCl):-
	Pred=end_of_file, N=0, LSrcCl=[],                   /* end of file */
	!.




group_clauses_by_pred(Pred,N,SrcCl,[SrcCl|LSrcCl1]):-
	get_next_clause(Pred1,N1,SrcCl1),
	(Pred=Pred1,N=N1
           -> group_clauses_by_pred(Pred1,N1,SrcCl1,LSrcCl1)
           ;
              LSrcCl1=[],
	      (Pred1=end_of_file, N1=0
                     -> true
                     ;  asserta(buff_clause(Pred1,N1,SrcCl1)))).




add_dyn_interf_clause(Pred,N,_):-
	clause(buff_dyn_interf_clause(Pred,N,_),true), /* already asserted */
	!.

add_dyn_interf_clause(Pred,N,Where):-
	create_dyn_interf_clause(Pred,N,Where,SrcCl),
	assertz(buff_dyn_interf_clause(Pred,N,SrcCl)).




create_dyn_interf_clause(Pred,N,Where,SrcCl):-
	length(LArgs,N),
	Head=..[Pred|LArgs],
	SrcCl=Where+(Head:- call(Head)).




recover_discontig_clauses(Pred,N,[SrcCl|LSrcCl]):-
	retract(buff_discontig_clause(Pred,N,SrcCl)),
	!,
	recover_discontig_clauses(Pred,N,LSrcCl).

recover_discontig_clauses(_,_,[]).




create_exe_clauses_for_dyn_pred([],_,_).

create_exe_clauses_for_dyn_pred([SrcCl|LSrcCl],Pred,N):-
	SrcCl=Where+Cl,
	add_wrapper_to_dyn_clause(Pred,N,Where+Cl,AuxName),
	handle_initialization(system,
                              '$add_clause_term_and_bc'(Cl,
                              [execute(AuxName/N)]),
                              Where),
	create_exe_clauses_for_dyn_pred(LSrcCl,Pred,N).




create_exe_clauses_for_pub_pred([]).

create_exe_clauses_for_pub_pred([Where+Cl|LSrcCl]):-
	handle_initialization(system,'$add_clause_term'(Cl),Where),
	create_exe_clauses_for_pub_pred(LSrcCl).




get_next_clause(Pred,N,SrcCl):-
	retract(buff_clause(Pred,N,SrcCl)),
	SrcCl=Where+_,
	g_assign(where,Where),
	!.

get_next_clause(Pred,N,SrcCl):-
	g_read(open_file_stack,OpenFileStack),
	OpenFileStack=[_*Stream|_],
	'$catch'(read_term(Stream,Cl,[singletons(SingNames)]),
	         error(syntax_error(Err),_),
	         after_syn_error,
	         any,0,false),
        (var(Err) 
                -> last_read_start_line_column(L1,_),
		   '$catch'(expand_term(Cl,Cl1),
	                    error(Err,_),
	                    dcg_error(Err),
	                    any,0,false),
		   stream_line_column(Stream,Line,Col),
		   (Col=1 -> L2 is Line-1
                          ;  L2=Line),
                   Where=OpenFileStack+(L1-L2),
		   g_assign(where,Where),
		   get_next_clause1(Cl1,Where,SingNames,Pred,N,SrcCl)
                ;
               	   get_next_clause(Pred,N,SrcCl)),

	!.

get_next_clause1(end_of_file,_,_,Pred,N,SrcCl):-
	close_last_prolog_file,
	g_read(open_file_stack,OpenFileStack),
	(OpenFileStack=[]
            -> Pred=end_of_file,
               N=0,
	       SrcCl=_+end_of_file,
	       g_assign(eof_reached,t)
             ;
	       get_next_clause(Pred,N,SrcCl)).

get_next_clause1((:- D),Where,SingNames,Pred,N,SrcCl):-
	display_singletons(SingNames,directive),
	(handle_directive(D,Where)
            ;
         error('invalid directive ~q',[D])),
        !,
        get_next_clause(Pred,N,SrcCl).

get_next_clause1(Cl,Where,SingNames,Pred,N,Where+Cl):-
	(Cl=(Head:-_) ; Cl=Head),
	(nonvar(Head)   -> true
                        ;  error('head is a variable',[])),
	(callable(Head) -> true
                        ;  error('head is not a callable (~q)',[Head])),
	functor(Head,Pred,N),
	check_predicate(Pred,N),
	display_singletons(SingNames,Pred/N).




after_syn_error:-
	g_read(syn_error_nb,SynErrNb),
	SynErrNb1 is SynErrNb+1,
	g_assign(syn_error_nb,SynErrNb1),
	syntax_error_info(_,Line,Char,Msg),
	g_read(open_file_stack,OpenFileStack),
	g_assign(where,OpenFileStack+(Line-Line)),
	disp_msg('syntax error: ~a (char:~d)',[Msg,Char],error).




dcg_error(Err):-
	last_read_start_line_column(Line,_),
	g_read(open_file_stack,OpenFileStack),
	g_assign(where,OpenFileStack+(Line-Line)),
	error('DCG error raised: ~w',[Err]).




display_singletons(SingNames,PI):-
	g_read(singl_warn,t),
	!,
	get_singletons(SingNames,Sing),
	(Sing=[]
             -> true
             ;  warn('singleton variables ~w for ~q',[Sing,PI])).

display_singletons(_,_).




get_singletons([],[]).

get_singletons([X=_|SingNames],Sing1):-
	(sub_atom(X,0,1,_,'_') -> Sing1=Sing
                               ;  Sing1=[X|Sing]),
	get_singletons(SingNames,Sing).




:- discontiguous(handle_directive/3).

handle_directive(D,Where):-
	D=..[DName|DLst],
	handle_directive(DName,DLst,Where).


handle_directive(public,DLst,_):-
	!,
	DLst\==[],
	set_flag_for_preds(DLst,pub).

handle_directive(dynamic,DLst,Where):-
	!,
	DLst\==[],
	set_flag_for_preds(DLst,dyn),
	set_flag_for_preds(DLst,pub),
	add_empty_dyn(DLst,Where).

handle_directive(discontiguous,DLst,_):-
	!,
	DLst\==[],
	set_flag_for_preds(DLst,discontig).

handle_directive(built_in,DLst,_):-
	!,
	(DLst==[], g_assign(default_kind,built_in)
                 ;
         DLst\==[], set_flag_for_preds(DLst,bpl)), !.

handle_directive(built_in_fd,DLst,_):-
	!,
	(DLst==[], g_assign(default_kind,built_in_fd)
                 ;
         DLst\==[], set_flag_for_preds(DLst,bfd)).

handle_directive(ensure_linked,DLst,_):-
	!,
	(g_read(native_code,f)
           -> warn('ensure_linked ignored in byte-code compilation mode',[])
           ;  
              DLst\==[],
	      add_ensure_linked(DLst)).

handle_directive(multifile,_,_):-
	!,
	warn('multifile directive not supported - directive ignored',[]).

handle_directive(ensure_loaded,_,_):-
	!,
	warn('ensure_loaded directive not supported - directive ignored',
        []).

handle_directive(include,[PlFile],_):-
	!,
	open_new_prolog_file(PlFile).

handle_directive(op,[X,Y,Z],Where):-
	!,
	exec_directive(op(X,Y,Z)),
	handle_initialization(system,op(X,Y,Z),Where).

handle_directive(char_conversion,[X,Y],Where):-
	!,
	exec_directive(char_conversion(X,Y)),
	handle_initialization(system,char_conversion(X,Y),Where).

handle_directive(set_prolog_flag,[X,Y],Where):-
	!,
	exec_directive(set_prolog_flag(X,Y)),
	(current_prolog_flag(singleton_warning,off)
              -> g_assign(singl_warn,f)
              ;  g_assign(singl_warn,t)),
	handle_initialization(system,set_prolog_flag(X,Y),Where).

handle_directive(initialization,[Body],Where):-
	!,
	handle_initialization(user,Body,Where).


handle_directive(foreign,[Template],Where):-
	!,
	handle_directive(foreign,[Template,[]],Where).

handle_directive(foreign,[Template,Options],Where):-
	!,
	callable(Template),
	list(Options),
	functor(Template,Pred,N),
	g_assign(foreign_fct_name,Pred),
	g_assign(foreign_return,boolean),
	g_assign(foreign_bip_name,Pred),
	g_assign(foreign_bip_arity,N),
	g_assign(foreign_choice_size,-1),
	foreign_get_options(Options),
	foreign_check_types(0,N,Template,LArgType),
	test_call_c_allowed(foreign/2),
	g_read(foreign_fct_name,FctName),
	g_read(foreign_return,Return),
	g_read(foreign_bip_name,BipName),
	g_read(foreign_bip_arity,BipArity),
	g_read(foreign_choice_size,ChcSize),
	functor(Head,Pred,N),
	SrcCl=Where+(Head:-'$foreign_call_c'(Head,LArgType,FctName,Return,
                                             BipName,BipArity,ChcSize)),
	assertz(buff_discontig_clause(Pred,N,SrcCl)),
	add_ensure_linked('$force_foreign_link'/0).
                     % to force the link of foreign.o and then foreign_supp.o




foreign_get_options([]).

foreign_get_options([X|Options]):-
	foreign_get_options1(X),
	foreign_get_options(Options).


foreign_get_options1(fct_name(FctName)):-
	atom(FctName),
	g_assign(foreign_fct_name,FctName).

foreign_get_options1(return(Return)):-
	atom(Return),
	(Return=none ; Return=boolean ; Return=jump),
	g_assign(foreign_return,Return).

foreign_get_options1(bip_name(X)):-
	nonvar(X),
	X=none,
	g_assign(foreign_bip_name,''),
	g_assign(foreign_bip_arity,-2).

foreign_get_options1(bip_name(BipName,BipArity)):-
	atom(BipName),
	integer(BipArity),
	g_assign(foreign_bip_name,BipName),
	g_assign(foreign_bip_arity,BipArity).

foreign_get_options1(choice_size(ChcSize)):-
	integer(ChcSize),
	g_assign(foreign_choice_size,ChcSize).




foreign_check_types(N,N,_,[]):-
	!.

foreign_check_types(I,N,Template,[(A,Mode)|LArgType]):-
	I1 is I+1,
	arg(I1,Template,Arg),
	nonvar(Arg),
	(Arg= +A, Mode=0
                ;
 	 Arg= -A, Mode=1
                ;
 	 Arg= ?A, Mode=2
                ;
         Arg=term, A=term, Mode=0),                            % term = +term
        nonvar(A),
	foreign_check_arg(A),
	foreign_check_types(I1,N,Template,LArgType).

foreign_check_arg(integer).
foreign_check_arg(positive).
foreign_check_arg(float).
foreign_check_arg(number).
foreign_check_arg(atom).
foreign_check_arg(boolean).
foreign_check_arg(char).
foreign_check_arg(in_char).
foreign_check_arg(code).
foreign_check_arg(in_code).
foreign_check_arg(byte).
foreign_check_arg(in_byte).
foreign_check_arg(string).
foreign_check_arg(chars).
foreign_check_arg(codes).
foreign_check_arg(term).




handle_directive(DName,LArgs,_):-
	length(LArgs,N),
	warn('unknown directive ~q - maybe use initialization/1 - directive ignored',[DName/N]).




handle_initialization(system,Body,Where):-
	assertz(buff_exe_system(Where+Body)).

handle_initialization(user,Body,Where):-
	assertz(buff_exe_user(Where+Body)).




exec_directive(Goal):-
        '$catch'(Goal,Err,exec_directive_exception(Goal,Err),any,0,false),
	!.

exec_directive(Goal):-
	warn('directive failed (~q)',[Goal]).

exec_directive_exception(Goal,Err):-
	warn('directive failed (~q) with exception (~q)',[Goal,Err]).



used_bips_via_call:-                      % to enforce the link of these bips
	op(_,_,_),
	char_conversion(_,_),
	set_prolog_flag(_,_),
	expand_term(_,_).




add_empty_dyn([],_):-
	!.

add_empty_dyn([P1|P2],Where):-
	!,
	add_empty_dyn(P1,Where),
	add_empty_dyn(P2,Where).

add_empty_dyn((P1,P2),Where):-
	!,
	add_empty_dyn(P1,Where),
	add_empty_dyn(P2,Where).

add_empty_dyn(Pred/N,Where):-
	assertz(empty_dyn_pred(Pred,N,Where)).




add_ensure_linked([]):-
	!.

add_ensure_linked([P1|P2]):-
	!,
	add_ensure_linked(P1),
	add_ensure_linked(P2).

add_ensure_linked((P1,P2)):-
	!,
	add_ensure_linked(P1),
	add_ensure_linked(P2).

add_ensure_linked(Pred/N):-
	clause(ensure_linked(Pred,N),true),
	!.

add_ensure_linked(Pred/N):-
	assertz(ensure_linked(Pred,N)).




set_flag_for_preds([],_):-
	!.

set_flag_for_preds([P1|P2],Flag):-
	!,
	set_flag_for_preds(P1,Flag),
	set_flag_for_preds(P2,Flag).

set_flag_for_preds((P1,P2),Flag):-
	!,
	set_flag_for_preds(P1,Flag),
	set_flag_for_preds(P2,Flag).

set_flag_for_preds(Pred/N,Flag):-
	atom(Pred),
	integer(N),
	(test_pred_info(def,Pred,N)
           -> warn('directive occurs after definition of ~q - directive ignored',[Pred/N])
           ;  (Flag=bpl, unset_pred_info(bfd,Pred,N)
                       ;
               Flag=bfd, unset_pred_info(bpl,Pred,N)
                       ;
               true), 
              !,
              set_pred_info(Flag,Pred,N)).
              



define_predicate(F,N):-
	set_pred_info(def,F,N),
	test_pred_info(bpl,F,N),
	!.

define_predicate(F,N):-
	test_pred_info(bfd,F,N),
	!.

define_predicate(F,N):-
	g_read(default_kind,built_in),
	!,
	set_pred_info(bpl,F,N).
	
define_predicate(F,N):-
	g_read(default_kind,built_in_fd),
	!,
	set_pred_info(bfd,F,N).
	
define_predicate(_,_).

	


flag_bit(def,0).        % defined ?
flag_bit(dyn,1).        % dynamic ?
flag_bit(pub,2).        % public ?
flag_bit(bpl,3).        % built_in ?
flag_bit(bfd,4).        % built_in_fd ?
flag_bit(discontig,5).  % discontiguous ?
flag_bit(cut,6).        % has cut(s) ?




set_pred_info(Flag,F,N):-
	flag_bit(Flag,Bit),
	(retract(pred_info(F,N,X)) ; X=0),
	!,
	X1 is (X \/(1<<Bit)),
	assertz(pred_info(F,N,X1)).




unset_pred_info(Flag,F,N):-
	flag_bit(Flag,Bit),
	retract(pred_info(F,N,X)),
	!,
	X1 is (X /\ \(1<<Bit)),
	assertz(pred_info(F,N,X1)).

unset_pred_info(_,_,_).




test_pred_info(Flag,F,N):-
	flag_bit(Flag,Bit),
	clause(pred_info(F,N,X),_),
        X/\(1<<Bit) > 0.




check_predicate(Pred,N):-
	g_read(redef_error,t), 
	bip(Pred,N),
	!,
        error('redefining built-in predicate ~q',[Pred/N]).

check_predicate(Pred,N):-
	g_read(redef_error,t),
	control_construct(Pred,N),
	!,
        error('redefining control construct ~q',[Pred/N]).

check_predicate(Pred,N):-
	g_read(susp_warn,t), 
	suspicious_predicate(Pred,N),
	!,
        warn('suspicious predicate ~q',[Pred/N]).

check_predicate(Pred,N):-
	'$aux_name'(Pred),
	!,
	warn('using system auxiliary predicate ~q',[Pred/N]).

check_predicate(_,_).




control_construct(',',2).
control_construct(;,2).
control_construct(->,2).
control_construct(!,0).
control_construct(fail,0).
control_construct(true,0).
control_construct(call,1).
control_construct(catch,3).
control_construct(throw,1).

suspicious_predicate(',',2).
suspicious_predicate(;,2).
suspicious_predicate(->,2).
suspicious_predicate(!,0).
suspicious_predicate(:-,1).
suspicious_predicate(:-,2).
suspicious_predicate(-->,2).
suspicious_predicate({},X):- X<2.
suspicious_predicate(+,2).
suspicious_predicate(-,2).
suspicious_predicate(*,2).
suspicious_predicate(/,2).
suspicious_predicate(//,2).




warn(Msg,LArg):-
	disp_msg(Msg,LArg,warning).




error(Msg,LArg):-
	disp_msg(Msg,LArg,'fatal error'),
	repeat,                                  /* close all opened files */
	(close_last_prolog_file 
              -> fail
              ;  !),
	abort.




disp_msg(Msg,LArg,MsgType):-
	numbervars(LArg),
	g_read(where,Where),
	(Where=OpenFileStack+L12, L12=_-_
              -> disp_file_name(OpenFileStack,_),
	         disp_lines(L12)
              ;  true),
	format('~a: ',[MsgType]),
	format(Msg,LArg),
	nl(user_output).




disp_file_name([],''):-
	!.

disp_file_name([FileName*_|OpenFileStack],' including '):-
	disp_file_name(OpenFileStack,Before),
	format('~a~a',[Before,FileName]).




disp_lines(L-L):-
	!,
	format(':~d ',[L]).

disp_lines(L1-L2):-
	format(':~d--~d ',[L1,L2]).




          /*--- exception recovery ---*/

exception(error(syntax_error(_),_)):-
	!,
	syntax_error_info(_,Line,Char,Msg),
	g_read(open_file_stack,OpenFileStack),
	g_assign(where,OpenFileStack+(Line-Line)),
	error('syntax error: ~a (char:~d)',[Msg,Char]).

exception(error(existence_error(source_sink,File),_)):-
	!,
	error('cannot open file ~a - does not exist',[File]).

exception(error(permission_error(open,source_sink,File),_)):-
	!,
	error('cannot open file ~a - permission error',[File]).

exception(Err):-
	error('exception raised: ~q',[Err]).

/*-------------------------------------------------------------------------*/
/* GNU Prolog                                                              */
/*                                                                         */
/* Part  : Prolog to WAM compiler                                          */
/* File  : reg_alloc.pl                                                    */
/* Descr.: pass 4: register allocation                                     */
/* Author: Daniel Diaz                                                     */
/*                                                                         */
/* Copyright (C) 1999 Daniel Diaz                                          */
/*                                                                         */
/* GNU Prolog is free software; you can redistribute it and/or modify it   */
/* under the terms of the GNU General Public License as published by the   */
/* Free Software Foundation; either version 2, or any later version.       */
/*                                                                         */
/* GNU Prolog is distributed in the hope that it will be useful, but       */
/* WITHOUT ANY WARRANTY; without even the implied warranty of              */
/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU        */
/* General Public License for more details.                                */
/*                                                                         */
/* You should have received a copy of the GNU General Public License along */
/* with this program; if not, write to the Free Software Foundation, Inc.  */
/* 59 Temple Place - Suite 330, Boston, MA 02111, USA.                     */
/*-------------------------------------------------------------------------*/

/*-------------------------------------------------------------------------*/
/* The main predicate is:                                                  */
/* allocate_registers(LInstW) ou allocate_registers(LInstW,MaxRegUsed):    */
/*    where LInstW is a list of instructions.                              */
/*    and MaxRegUsed is an integer corresponding to the greatest register  */
/*    used (-1 if none or n>=0 if reg0...regMaxRegUsed are used).          */
/*                                                                         */
/* Two predicates must be provided in addition to the allocater:           */
/*                                                                         */
/* codification(InstW,LCode):                                              */
/*    defines the action of InstW on the registers as a list LCode of codes*/
/*    c(R1,R2) (copy R1 into R2), r(R) (read R) or w(R) (write R).         */
/*                                                                         */
/* alias_stop_instruction(InstW):                                          */
/*     true if InstW stop aliasing propagation.                            */
/*                                                                         */
/* Terminology:                                                            */
/*     Arg: Arg is an argument iff integer(Arg)                            */
/*     Tmp: Tmp is a temporary iff var(Tmp)                                */
/*     Reg: Reg is a register if it is either an argument or a temporary.  */
/*                                                                         */
/* This allocation proceeds in 3 steps:                                    */
/*                                                                         */
/*  1) computing aliases (i.e. list of same values at entry of each inst): */
/*     LAlias is a list of aliases (one for each instruction)              */
/*     LAlias=[Alias,...]                                                  */
/*     The aliases (Alias) are represented as a set of same values (LSame) */
/*     Alias=[LSame,...].                                                  */
/*     each LSame is a set of Regs (integers or variables)                 */
/*     eg Alias=[ [1,2,X,Y],[3,Z,4] ] means 1,2,X,Y are aliased, 3,Z,4 also*/
/*                                                                         */
/*  2) computing the list of temporaries LTmp=[tmp(Tmp,Imposs,Wish),...]   */
/*     where Imposs is a set of impossible values and Wish a set of wanted */
/*     values (to give rise to useless copy instructions).                 */
/*     The code is traversed in reverse order, computing at each time the  */
/*     set of Regs in life (InLife) (see Mats Carlsson's PhD Thesis).      */
/*                                                                         */
/*  3) Each Tmp in LTmp is assigned wrt to Wish and Imposs in 2 steps:     */
/*                                                                         */
/*     a) from [tmp(Tmp,Imposs,Wish)|LTmp]:                                */
/*                                                                         */
/*        while there exists Tmpj in Wish and not in Imposs:               */
/*           let tmp(Tmpj,Impossj,Wishj) be the associated record in LTmp  */
/*           Imposs:=Imposs+Impossj and Wish:=Wish+Wishj,                  */
/*           LTmp:=LTmp - tmp(Tmpj,Impossj,Wishj) (remove Tmpj from LTmp)  */
/*           Tmpj=Tmp (unify them)                                         */
/*                                                                         */
/*        At the end of the loop:                                          */
/*        if there exists an integer k in Wish-Imposs then  (see comment *)*/
/*           Tmp=k else replace tmp(Tmp,Imposs,Wish) in LTmp               */
/*                                                                         */
/*     b) for each Tmp remaining in LTmp assign a value w.r.t to Imposs    */
/*        by chosing the first integer not present in Imposs (after sort)  */
/*                                                                         */
/* Comments:                                                               */
/*                                                                         */
/* It seems, from the construction, that, in Wish, only remains possible   */
/* so the compl(Wish,Imposs,AssignOK) would be useless, but I have to check*/
/* this correctly.                                                         */
/*                                                                         */
/* It would be possible to eliminate useless instructions. In codification */
/* we could add an argument specifying that when a w(Reg) code is handled  */
/* and Reg is not in InLife then the surrounding instruction is useless.   */
/* it is the case for get_variable(x(_),_)/put_value(x(_),_),              */
/* not for put_variable(x(_),_).  Is it useful ?                           */
/*-------------------------------------------------------------------------*/

allocate_registers(LInstW):-
	allocate_registers(LInstW,_).


allocate_registers(LInstW,MaxRegUsed):-
	g_read(reg_opt,OptReg),
	(OptReg>0 -> aliases(LInstW,[],LAlias)
                  ;  true),
	create_lst_tmp(LInstW,LAlias,_,LTmp),
	assign_lst_tmp(LTmp,MaxRegUsed).




          /* Aliasing information creation */

aliases([],_,[]).

aliases([InstW|LInstW],Alias,[Alias|LAlias]):-
	(alias_stop_instruction(InstW)
             -> Alias1=[]
             ;
		codification(InstW,LCode),
		aliases1(LCode,Alias,Alias1)),
	!,
	aliases(LInstW,Alias1,LAlias).


aliases1([],Alias,Alias).

aliases1([Code|LCode],Alias,Alias3):-
	(Code=r(Reg), Alias2=Alias
                    ;
	 Code=w(Reg), remove_aliases_of(Alias,Reg,Alias2)
                    ;
         Code=c(Reg,Reg1), remove_aliases_of(Alias,Reg1,Alias1),
	                   add_alias(Alias1,Reg,Reg1,Alias2)),
	!,
	aliases1(LCode,Alias2,Alias3).




add_alias([],Reg,Reg1,[[Reg,Reg1]]).

add_alias([LSame|Alias],Reg,Reg1,[LSame1|Alias1]):-
	(set_elt(LSame,Reg) -> set_add(LSame,Reg1,LSame1),
                               Alias1=Alias
                            ;
                               LSame1=LSame,
                               add_alias(Alias,Reg,Reg1,Alias1)).
	



find_aliases_of([LSame|Alias],Reg,LSame1):-
	(set_delete(LSame,Reg,LSame1)
               -> true
               ;
		  find_aliases_of(Alias,Reg,LSame1)).




remove_aliases_of([],_,[]).

remove_aliases_of([LSame|Alias],Reg,Alias1):-
	(set_delete(LSame,Reg,LSame1)
             -> ((LSame1=[];LSame1=[_]) -> Alias1=Alias
                                        ;  Alias1=[LSame1|Alias])
              ;
                Alias1=[LSame|Alias2],
                remove_aliases_of(Alias,Reg,Alias2)).




          /* Temporarie dictionnary creation (lifetime analysis) */

create_lst_tmp([],[],[],[]).

create_lst_tmp([InstW|LInstW],[Alias|LAlias],InLife1,LTmp1):-
	create_lst_tmp(LInstW,LAlias,InLife,LTmp),
	codification(InstW,LCode),
	!,
	handle_lst_code(LCode,Alias,InLife,InLife1,LTmp,LTmp1).




handle_lst_code([],_,InLife,InLife,LTmp,LTmp).

handle_lst_code([Code|LCode],Alias,InLife,InLife2,LTmp,LTmp2):-
	handle_lst_code(LCode,Alias,InLife,InLife1,LTmp,LTmp1),
	handle_one_code(Code,Alias,[],InLife1,InLife2,LTmp1,LTmp2).




handle_one_code(r(Reg),Alias,Wish,InLife,InLife1,LTmp,LTmp2):-
	(set_elt(InLife,Reg)
              -> InLife1=InLife,
                 (var(Reg), Wish\==[] -> update_tmp(LTmp,Reg,[],Wish,LTmp2)
	                              ;  LTmp2=LTmp)
              ;
	         InLife1=[Reg|InLife],
		 constraints(Reg,InLife,Alias,Cstr),
		 make_imposs(Cstr,[Reg],LTmp,LTmp1),
		 (var(Reg) -> update_tmp(LTmp1,Reg,Cstr,Wish,LTmp2)
			   ;  LTmp2=LTmp1)).

handle_one_code(w(Reg),Alias,Wish,InLife,InLife1,LTmp,LTmp2):-
	(set_delete(InLife,Reg,InLife1)
              -> (var(Reg), Wish\==[] -> update_tmp(LTmp,Reg,[],Wish,LTmp2)
	                              ;  LTmp2=LTmp)
              ;
	         InLife1=InLife,
	         (var(Reg) -> constraints(Reg,InLife1,Alias,Cstr),
		              (Wish\==[] -> set_diff(Cstr,Wish,Cstr1)
                                         ;  Cstr1=Cstr),
			      make_imposs(Cstr1,[Reg],LTmp,LTmp1),
	                      update_tmp(LTmp1,Reg,Cstr1,Wish,LTmp2)
			   ;
			      LTmp2=LTmp)).

handle_one_code(c(Reg,Reg1),Alias,_,InLife,InLife2,LTmp,LTmp2):-
	handle_one_code(w(Reg1),Alias,[Reg],InLife,InLife1,LTmp,LTmp1),
	handle_one_code(r(Reg),Alias,[Reg1],InLife1,InLife2,LTmp1,LTmp2).




constraints(Reg,InLife,Alias,Cstr):-
	(g_read(reg_opt,2), find_aliases_of(Alias,Reg,LSame)
                -> set_diff(InLife,LSame,Cstr)
                ;  Cstr=InLife).




update_tmp([],Reg,Imposs,Wish,[tmp(Reg,Imposs,Wish)]).

update_tmp([Tmp|LTmp],Reg,Imposs,Wish,[Tmp1|LTmp1]):-
	Tmp=tmp(Reg1,Imposs1,Wish1),
	(Reg==Reg1 -> set_union(Imposs,Imposs1,Imposs2),
	              set_union(Wish,Wish1,Wish2),
		      Tmp1=tmp(Reg,Imposs2,Wish2),
		      LTmp1=LTmp
                   ;
		      Tmp1=Tmp,
		      update_tmp(LTmp,Reg,Imposs,Wish,LTmp1)).




remove_tmp([T|LTmp],Reg,Imposs,Wish,LTmp2):-
	T=tmp(Reg1,Imposs1,Wish1),
	(Reg==Reg1 -> Imposs=Imposs1,
                      Wish=Wish1,
		      LTmp2=LTmp
                   ;
		      LTmp2=[T|LTmp1],
		      remove_tmp(LTmp,Reg,Imposs,Wish,LTmp1)).





make_imposs([],_,LTmp,LTmp).

make_imposs([Reg|Cstr],Imposs,LTmp,LTmp2):-
	(var(Reg) -> update_tmp(LTmp,Reg,Imposs,[],LTmp1)
	          ;  LTmp1=LTmp),
	make_imposs(Cstr,Imposs,LTmp1,LTmp2).




          /* Register assignment */

assign_lst_tmp(LTmp,MaxRegUsed):-
	g_read(reg_opt,OptReg),
	(OptReg=2 -> assign_wishes(LTmp,LTmp1)
                  ;  no_wish(LTmp,OptReg,LTmp1)),
	assign_values(LTmp1,-1,MaxRegUsed).




assign_wishes([],[]).

assign_wishes([tmp(Tmp,Imposs,Wish)|LTmp],LTmp3):-
	collapse_tmps(Wish,Imposs,LTmp,Tmp,Wish1,Imposs1,LTmp1),
	try_a_whish(Tmp,Imposs1,Wish1),
	(var(Tmp) -> LTmp3=[tmp(Tmp,Imposs1)|LTmp2] % no longer wish in tmp()
                  ;  LTmp3=LTmp2),
        assign_wishes(LTmp1,LTmp2).




collapse_tmps([],Imposs,LTmp,_,[],Imposs,LTmp).

collapse_tmps([Reg|Wish],Imposs,LTmp,Tmp,Wish1,Imposs1,LTmp1):-
	(Reg==Tmp ; set_elt(Imposs,Reg)),
        !,
	collapse_tmps(Wish,Imposs,LTmp,Tmp,Wish1,Imposs1,LTmp1).

collapse_tmps([Arg|Wish],Imposs,LTmp,Tmp,[Arg|Wish1],Imposs1,LTmp1):-
	integer(Arg),
	!,
	collapse_tmps(Wish,Imposs,LTmp,Tmp,Wish1,Imposs1,LTmp1).

collapse_tmps([Tmp1|Wish],Imposs,LTmp,Tmp,Wish3,Imposs3,LTmp2):-
	remove_tmp(LTmp,Tmp1,Imposs1,Wish1,LTmp1),
	set_union(Imposs,Imposs1,Imposs2),
	set_union(Wish,Wish1,Wish2),
	Tmp=Tmp1,
	collapse_tmps(Wish2,Imposs2,LTmp1,Tmp,Wish3,Imposs3,LTmp2).




try_a_whish(Tmp,Imposs,Wish):-
	set_diff(Wish,Imposs,[Tmp|_]),
	!.

try_a_whish(_,_,_).




no_wish([],_,[]).

no_wish([tmp(Tmp,Imposs,Wish)|LTmp],OptReg,[tmp(Tmp,Imposs1)|LTmp1]):-
	(OptReg=0 -> set_union(Imposs,Wish,Imposs1) % no optimizations at all
                  ;  Imposs1=Imposs),                % for some optimizations
        no_wish(LTmp,OptReg,LTmp1).




assign_values([],MaxRegUsed,MaxRegUsed).

assign_values([tmp(Tmp,Imposs)|LTmp],MaxRegUsed,MaxRegUsed2):-
	sort(Imposs,Imposs1),
	find_hole(Imposs1,0,Tmp),
	(Tmp>MaxRegUsed -> MaxRegUsed1=Tmp
                        ;  MaxRegUsed1=MaxRegUsed),
        assign_values(LTmp,MaxRegUsed1,MaxRegUsed2).




find_hole([],Nb,Nb).

find_hole([Reg|Imposs],Nb,Nb1):-
        var(Reg),
	!,
        find_hole(Imposs,Nb,Nb1).

find_hole([Reg|Imposs],Nb,Nb2):-
        (Reg>Nb -> Nb2=Nb                                        % hole found
                ;
                   (Reg==Nb -> Nb1 is Nb+1
                            ;  Nb1=Nb),
                   find_hole(Imposs,Nb1,Nb2)).




          /*--- set handling (without unification) ---*/

set_add([],X,[X]).

set_add([Y|L],X,[Y|L]):-
	X==Y, 
	!.

set_add([Y|L],X,[Y|L1]):- 
	set_add(L,X,L1).




set_delete([Y|L],X,L):-                 % set_delete(L,X,L1) fails if
        X==Y,                           % X does not belong to L
        !.

set_delete([Y|L],X,[Y|L1]):-
        set_delete(L,X,L1).




set_elt([Y|_],X):-
	X==Y, 
	!.

set_elt([_|L],X):-
	set_elt(L,X).




set_inter([],_,[]).

set_inter([X|L1],L2,[X|L3]):-
	set_elt(L2,X), 
	!, 
	set_inter(L1,L2,L3).

set_inter([_|L1],L2,L3):-
	set_inter(L1,L2,L3).




set_union([],L2,L2).

set_union([X|L1],L2,L3):-
	set_elt(L2,X),
	!,
	set_union(L1,L2,L3).

set_union([X|L1],L2,[X|L3]):-
	set_union(L1,L2,L3).




set_diff([],_,[]).

set_diff([X|L],L1,L3):-
	(set_elt(L1,X) -> L3=L2
                       ;  L3=[X|L2]),
        set_diff(L,L1,L2).
:- op(0,fx,dynamic).

include(X):-
	[X].


prolog_file_name(PlFile,PlFile1):-
        decompose_file_name(PlFile,_Dir,_Prefix,Suffix),
        ((PlFile=user ; Suffix\=='')
               -> PlFile1=PlFile
               ;  atom_concat(PlFile,'.pl',PlFile1)).


last_read_start_line_column(Line,Col):-
	g_read('$last_line',Line),
	g_read('$last_col',Col).

stream_line_column(Stream,Line,Col):-
	line_count(Stream,Count),
	line_position(Stream,Pos),
	Line is Count+1,
	Col is Pos+1,
	g_assign('$last_line',Line),
	g_assign('$last_col',Col).



peek_code(S,X):-
	peek_char(S,X).

get_code(S,X):-
	get0(S,X).




current_prolog_flag(prolog_name,'SICStus Prolog').
current_prolog_flag(prolog_version,'?').
current_prolog_flag(prolog_date,'1998').


date_time(dt(0,0,0,0,0,0)).



reverse([],[]).

reverse([H|T],L):-
        reverse1(T,L,[H]).


reverse1([],L,L).

reverse1([H|T],L,L1):-
        reverse1(T,L,[H|L1]).




append([],L,L).

append([X|L1],L2,[X|L3]):-
        append(L1,L2,L3).


atom_length(A,L):-
        name(A,S),
        length(S,L).



stop:-
	abort.


catch(Goal,_,_):-
	call(Goal).

discontiguous(_).



atom_concat(A1,A2,A3):-
	(nonvar(A1) -> atom_codes(A1,LCodeA1) ; true),
	(nonvar(A2) -> atom_codes(A2,LCodeA2) ; true),
	(nonvar(A3) -> atom_codes(A3,LCodeA3) ; true),
        append(LCodeA1,LCodeA2,LCodeA3),
        atom_codes(A1,LCodeA1),
        atom_codes(A2,LCodeA2),
        atom_codes(A3,LCodeA3).




sub_atom(A,Before,L,After,A1):-
        atom_codes(A,LCodeA),
        atom_length(A,N),
        (integer(Before) 
            -> true
            ;  list_i_j(1,N,SL), '$member'(S,SL), Before is S-1),
        (integer(L)
            -> true
            ;
               MaxL is N-Before,
               list_i_j(0,MaxL,LL), '$member'(L,LL)),
        After is N-L-Before,
        length(X0,Before),
        length(LCodeA1,L),
        length(X2,After),
        append(X1,X2,LCodeA),
        append(X0,LCodeA1,X1),
        atom_codes(A1,LCodeA1).




list_i_j(I,J,L):-
        (I>J -> L=[]
              ;
                 I1 is I+1,
                 L=[I|L1],
                 list_i_j(I1,J,L1)).






'$member'(X,[H|T]):-
        X=H ; '$member'(X,T).





char_code(Char,Code):-
        atom_char(Char,Code).




number_atom(N,A):-
	(number(N) -> number_chars(N,LCode),
	              atom_chars(A,LCode)
                   ;
                      atom_chars(A,LCode),
		      number_chars(N,LCode)).


atom_codes(A,LCode):-
	atom_chars(A,LCode).





chars_codes([],[]).

chars_codes([Char|LChar],[Code|LCode]):-
        char_code(Char,Code),
        chars_codes(LChar,LCode).




number_codes(N,LCode):-
	number_chars(N,LCode).





/* g_vars */

:- dynamic(gvar/2).

g_assign(Var,Value):-
	(retract(gvar(Var,_)) ; true),
	!,
	asserta(gvar(Var,Value)).

g_read(Var,Value):-
	(gvar(Var,Value1) ; Value1=0),
	!,
        Value=Value1.





decompose_file_name(Path,Dir,Prefix,Suffix):-
	atom_length(Path,L),
	Before is L-1,
	find_dir_and_file_name(Path,Before,Dir,FileName),
	(sub_atom(FileName,LgPrefix,1,_,'.') 
              -> sub_atom(FileName,0,LgPrefix,LgSuffix,Prefix),
		 sub_atom(FileName,LgPrefix,LgSuffix,0,Suffix)
              ;  
	         Prefix=FileName, Suffix=''),
	!.


find_dir_and_file_name(Path,Before,'',Path):-
	Before<0,
	!.

find_dir_and_file_name(Path,Before,Dir,FileName):-
	sub_atom(Path,Before,1,After,'/'),
	Before1 is Before+1,
	sub_atom(Path,0,Before1,_,Dir),
	sub_atom(Path,_,After,0,FileName),
	!.

find_dir_and_file_name(Path,Before,Dir,FileName):-
	Before1 is Before-1,
	find_dir_and_file_name(Path,Before1,Dir,FileName).






'$sys_var_write'(Var,N):-
        g_assign(Var,N).

'$sys_var_read'(Var,N):-
        g_read(Var,N).

'$sys_var_inc'(Var):-
        g_read(Var,N),
	N1 is N+1,
        g_assign(Var,N1).

'$sys_var_dec'(Var):-
        g_read(Var,N),
	N1 is N-1,
        g_assign(Var,N1).

'$sys_var_set_bit'(Var,Bit):-
        g_read(Var,N),
	N1 is (N\/(1<<Bit)),
        g_assign(Var,N1).

'$sys_var_reset_bit'(Var,Bit):-
        g_read(Var,N),
	N1 is N/\ \(1<<Bit),
        g_assign(Var,N1).



'$catch_internal'(Goal,_Catcher,_Recovery,_,_,_):-
	call(Goal).



'$aux_name'(Name):-
	sub_atom(Name,_,5,_,'_$aux'),
	!.



'$make_aux_name'(Pred,N,Aux,AuxName):-
        (sub_atom(Pred,LgBefore,5,_,'_$aux')
               -> sub_atom(Pred,0,LgBefore,_,Pred1)
               ;  
                  number_atom(N,AN),
                  atom_concat('$',Pred,Pred2),
                  atom_concat(Pred2,'/',Pred3),
                  atom_concat(Pred3,AN,Pred1)),
        number_atom(Aux,ANo),
        atom_concat('_$aux',ANo,AAux),
        atom_concat(Pred1,AAux,AuxName).




'$pred_without_aux'(Func,Arity,Func1,Arity1):-
        (sub_atom(Func,LgBefore,5,_,'_$aux')
              -> sub_atom(Func,B,1,_,'/'),
                 L is B-1,
                 sub_atom(Func,1,L,_,Func1),
                 B1 is B+1,
		 A is LgBefore-B-1,
                 sub_atom(Func,B1,A,_,SA1),
		 number_atom(Arity1,SA1), !
              ;  Func1=Func,
                 Arity1=Arity).
	

:- op(0,fx,dynamic).

include(X):-
	[X].


prolog_file_name(PlFile,PlFile1):-
        decompose_file_name(PlFile,_Dir,_Prefix,Suffix),
        ((PlFile=user ; Suffix\=='')
               -> PlFile1=PlFile
               ;  atom_concat(PlFile,'.pl',PlFile1)).


last_read_start_line_column(Line,Col):-
	g_read('$last_line',Line),
	g_read('$last_col',Col).

stream_line_column(Stream,Line,Col):-
	line_count(Stream,Count),
	line_position(Stream,Pos),
	Line is Count+1,
	Col is Pos+1,
	g_assign('$last_line',Line),
	g_assign('$last_col',Col).



peek_code(S,X):-
	peek_byte(S,X).                               % swi-pl


get_code(S,X):-
	get0(S,X).


callable(X):-
	atom(X),
	!.

callable(X):-
	compound(X).



current_prolog_flag(prolog_name,'SWI Prolog').
current_prolog_flag(prolog_version,'?').
current_prolog_flag(prolog_date,'1998').

date_time(dt(0,0,0,0,0,0)).




stop:-
	abort.




atom_concat(A1,A2,A3):-
	(nonvar(A1) -> atom_codes(A1,LCodeA1) ; true),
	(nonvar(A2) -> atom_codes(A2,LCodeA2) ; true),
	(nonvar(A3) -> atom_codes(A3,LCodeA3) ; true),
        append(LCodeA1,LCodeA2,LCodeA3),
        atom_codes(A1,LCodeA1),
        atom_codes(A2,LCodeA2),
        atom_codes(A3,LCodeA3).




sub_atom(A,Before,L,After,A1):-
        atom_codes(A,LCodeA),
        atom_length(A,N),
        (integer(Before) 
            -> true
            ;  list_i_j(1,N,SL), '$member'(S,SL), Before is S-1),
        (integer(L)
            -> true
            ;
               MaxL is N-Before,
               list_i_j(0,MaxL,LL), '$member'(L,LL)),
        After is N-L-Before,
        length(X0,Before),
        length(LCodeA1,L),
        length(X2,After),
        append(X1,X2,LCodeA),
        append(X0,LCodeA1,X1),
        atom_codes(A1,LCodeA1).




list_i_j(I,J,L):-
        (I>J -> L=[]
              ;
                 I1 is I+1,
                 L=[I|L1],
                 list_i_j(I1,J,L1)).






'$member'(X,[H|T]):-
        X=H ; '$member'(X,T).





char_code(Char,Code):-
        atom_char(Char,Code).




number_atom(N,A):-
	(number(N) -> number_chars(N,LCode),
	              atom_chars(A,LCode)
                   ;
                      atom_chars(A,LCode),
		      number_chars(N,LCode)).


atom_codes(A,LCode):-
	atom_chars(A,LCode).





chars_codes([],[]).

chars_codes([Char|LChar],[Code|LCode]):-
        char_code(Char,Code),
        chars_codes(LChar,LCode).




number_codes(N,LCode):-
	number_chars(N,LCode).





/* g_vars */

:- dynamic(gvar/2).

g_assign(Var,Value):-
	(retract(gvar(Var,_)) ; true),
	!,
	asserta(gvar(Var,Value)).

g_read(Var,Value):-
	(gvar(Var,Value1) ; Value1=0),
	!,
        Value=Value1.





decompose_file_name(Path,Dir,Prefix,Suffix):-
	atom_length(Path,L),
	Before is L-1,
	find_dir_and_file_name(Path,Before,Dir,FileName),
	(sub_atom(FileName,LgPrefix,1,_,'.') 
              -> sub_atom(FileName,0,LgPrefix,LgSuffix,Prefix),
		 sub_atom(FileName,LgPrefix,LgSuffix,0,Suffix)
              ;  
	         Prefix=FileName, Suffix=''),
	!.


find_dir_and_file_name(Path,Before,'',Path):-
	Before<0,
	!.

find_dir_and_file_name(Path,Before,Dir,FileName):-
	sub_atom(Path,Before,1,After,'/'),
	Before1 is Before+1,
	sub_atom(Path,0,Before1,_,Dir),
	sub_atom(Path,_,After,0,FileName),
	!.

find_dir_and_file_name(Path,Before,Dir,FileName):-
	Before1 is Before-1,
	find_dir_and_file_name(Path,Before1,Dir,FileName).






'$sys_var_write'(Var,N):-
        g_assign(Var,N).

'$sys_var_read'(Var,N):-
        g_read(Var,N).

'$sys_var_inc'(Var):-
        g_read(Var,N),
	N1 is N+1,
        g_assign(Var,N1).

'$sys_var_dec'(Var):-
        g_read(Var,N),
	N1 is N-1,
        g_assign(Var,N1).

'$sys_var_set_bit'(Var,Bit):-
        g_read(Var,N),
	N1 is (N\/(1<<Bit)),
        g_assign(Var,N1).

'$sys_var_reset_bit'(Var,Bit):-
        g_read(Var,N),
	N1 is N/\ \(1<<Bit),
        g_assign(Var,N1).



'$catch_internal'(Goal,Catcher,Recovery,_,_,_):-
	catch(Goal,Catcher,Recovery).


portray_clause(S,C):-
	current_output(O),
	flush_output(S),
	set_output(S),
	portray_clause(C),
	set_output(O),
	flush_output(S).


'$aux_name'(Name):-
	sub_atom(Name,_,5,_,'_$aux').



'$make_aux_name'(Pred,N,Aux,AuxName):-
        (sub_atom(Pred,LgBefore,5,_,'_$aux')
               -> sub_atom(Pred,0,LgBefore,_,Pred1)
               ;  
                  number_atom(N,AN),
                  atom_concat('$',Pred,Pred2),
                  atom_concat(Pred2,'/',Pred3),
                  atom_concat(Pred3,AN,Pred1)),
        number_atom(Aux,ANo),
        atom_concat('_$aux',ANo,AAux),
        atom_concat(Pred1,AAux,AuxName).


'$pred_without_aux'(Func,Arity,Func1,Arity1):-
        (sub_atom(Func,LgBefore,5,_,'_$aux')
              -> sub_atom(Func,B,1,_,'/'),
                 L is B-1,
                 sub_atom(Func,1,L,_,Func1),
                 B1 is B+1,
		 A is LgBefore-B-1,
                 sub_atom(Func,B1,A,_,SA1),
		 number_atom(Arity1,SA1), !
              ;  Func1=Func,
                 Arity1=Arity).



argument_list(LArgs):-
	unix(argv([_|L])),
	delete_swi(L,LArgs),
	!.


delete_swi([],[]).

delete_swi(['-x',_|L],L1):-
	delete_swi(L,L1).

delete_swi(['-t',_|L],L1):-
	delete_swi(L,L1).

delete_swi(['-g',_|L],L1):-
	delete_swi(L,L1).

delete_swi(['--'|L],L).



/*-------------------------------------------------------------------------*/
/* GNU Prolog                                                              */
/*                                                                         */
/* Part  : Prolog to WAM compiler                                          */
/* File  : syn_sugar.pl                                                    */
/* Descr.: pass 1: syntactic sugar removing                                */
/* Author: Daniel Diaz                                                     */
/*                                                                         */
/* Copyright (C) 1999 Daniel Diaz                                          */
/*                                                                         */
/* GNU Prolog is free software; you can redistribute it and/or modify it   */
/* under the terms of the GNU General Public License as published by the   */
/* Free Software Foundation; either version 2, or any later version.       */
/*                                                                         */
/* GNU Prolog is distributed in the hope that it will be useful, but       */
/* WITHOUT ANY WARRANTY; without even the implied warranty of              */
/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU        */
/* General Public License for more details.                                */
/*                                                                         */
/* You should have received a copy of the GNU General Public License along */
/* with this program; if not, write to the Free Software Foundation, Inc.  */
/* 59 Temple Place - Suite 330, Boston, MA 02111, USA.                     */
/*-------------------------------------------------------------------------*/

syntactic_sugar_init_pred(Pred,_):-
	'$aux_name'(Pred),
	!.

syntactic_sugar_init_pred(_,_):-
	g_assign(aux,1).




syntactic_sugar(SrcCl,Head,Body2):-
	(SrcCl=(Head:-Body) ; SrcCl=Head, Body=true),
        !,
	normalize_cuts(Body,Body1),
	normalize_alts(Body1,Head,Body2).



normalize_cuts(Body,Body2):-
	g_assign(has_cut,f),
        normalize_cuts1(Body,CutVar,Body1),
	!,
        (g_read(has_cut,t) 
             -> Body2=('$get_cut_level'(CutVar),Body1)
             ;  Body2=Body1).


normalize_cuts1(X,VarCut,P):-
	var(X),
	normalize_cuts1(call(X),VarCut,P).

normalize_cuts1((If;R),CutVar,Body):-
	nonvar(If),
	If=(P->Q),
	Body=('$get_cut_level'(CutVar1),P,'$cut'(CutVar1),Q1;R1),
	normalize_cuts1(Q,CutVar,Q1),
	normalize_cuts1(R,CutVar,R1).

normalize_cuts1((P->Q),CutVar,Body):-
	Body=('$get_cut_level'(CutVar1),P,'$cut'(CutVar1),Q1;fail),
	normalize_cuts1(Q,CutVar,Q1).

normalize_cuts1((!),CutVar,'$cut'(CutVar)):-
	g_assign(has_cut,t).

normalize_cuts1((P,Q),CutVar,(P1,Q1)):-
	normalize_cuts1(P,CutVar,P1),
	normalize_cuts1(Q,CutVar,Q1).

normalize_cuts1((P;Q),CutVar,(P1;Q1)):-
	normalize_cuts1(P,CutVar,P1),
	normalize_cuts1(Q,CutVar,Q1).

normalize_cuts1(call(G),_,'$call'(G,Func,Arity,true)):-
	cur_pred_without_aux(Func,Arity).

normalize_cuts1(catch(G,C,R),_,'$catch'(G,C,R,Func,Arity,true)):-
	cur_pred_without_aux(Func,Arity).

normalize_cuts1(throw(B),_,'$throw'(B,Func,Arity,true)):-
	cur_pred_without_aux(Func,Arity).

normalize_cuts1(P,_,P1):-
	(callable(P) -> true
                     ;  error('body goal is not callable (~q)',[P])),
	pred_rewriting(P,P1).




normalize_alts(Body,Head,Body1):-
	functor(Head,Pred,N),
	g_assign(head_functor,Pred),
	g_assign(head_arity,N),
	normalize_alts1(Body,Head,Body1),
	!.


normalize_alts1(X,_,call(X)):-
	var(X).

normalize_alts1((P,Q),RestC,(P1,Q1)):-
	normalize_alts1(P,(RestC,Q),P1),
	normalize_alts1(Q,(RestC,P),Q1).

normalize_alts1((P;Q),RestC,AuxPred):-
	lst_var(RestC,[],VarRestC),
	lst_var((P;Q),[],VarAlt),
	set_inter(VarAlt,VarRestC,V),
	length(V,N1),
	g_read(head_functor,Pred),
	g_read(head_arity,N),
	init_aux_pred_name(Pred,N,AuxName,N1),
	AuxPred=..[AuxName|V],
	g_read(where,Where),
	linearize((P;Q),AuxPred,Where,LAuxSrcCl),
	asserta(buff_aux_pred(AuxName,N1,LAuxSrcCl)).

normalize_alts1(P,_,P).




init_aux_pred_name(Pred,N,AuxName,N1):-
	g_read(aux,Aux),
	Aux1 is Aux+1,
	g_assign(aux,Aux1),
	'$make_aux_name'(Pred,N,Aux,AuxName),
	(test_pred_info(bpl,Pred,N), set_pred_info(bpl,AuxName,N1)
               ;
         test_pred_info(bfd,Pred,N), set_pred_info(bfd,AuxName,N1)
               ;
         true),
	!.




linearize(Body,AuxPred,Where,LAuxSrcCl):-
	(Body=(P;Q) -> linearize(Q,AuxPred,Where,LAuxSrcCl1),
	               linearize1(P,AuxPred,Where,LAuxSrcCl2),
		       append(LAuxSrcCl2,LAuxSrcCl1,LAuxSrcCl)
                    ;
                       linearize1(Body,AuxPred,Where,LAuxSrcCl)).


linearize1(fail,_,_,[]):-
	!.

linearize1(P,AuxPred,Where,[Where+AltP]):-
	copy_term((AuxPred:-P),AltP).




lst_var(X,V,V1):-
	var(X),
	!,
	set_add(V,X,V1).

lst_var(P,V,V1):-
	functor(P,_,N),
	lst_var_args(1,N,P,V,V1).



lst_var_args(I,N,P,V,V2):-
	(I=<N -> arg(I,P,ArgP),
                 lst_var(ArgP,V,V1),
		 I1 is I+1,
		 lst_var_args(I1,N,P,V1,V2)
              ;
                 V2=V).




        /* Other predicate rewriting */

pred_rewriting(fd_tell(X),'$call_c_test'(X)):-            % FD transformation
	test_call_c_allowed(fd_tell/1),
	!.

pred_rewriting(set_bip_name(Name,Arity),Pred1):-
	g_read(inline,t),             % also if -wbc since implies -no-inline
        nonvar(Name),
	nonvar(Arity),
	!,
	(atom(Name)
            ;
         error('set_bip_name/2 inline: atom expected instead of ~q',[Name])),
        (integer(Arity)
            ;
         error('set_bip_name/2 inline: integer expected instead of ~q',[Arity])),
	!,
	Pred1='$call_c'('Set_Bip_Name_2'(Name,Arity)).

pred_rewriting(Pred,Pred1):-                        % math define current bip
	g_read(inline,t),
	g_read(fast_math,f),
	functor(Pred,F,2),
	(F=(is) ; math_cmp_functor_name(F,_)),              % see code_gen.pl
	!,
	Pred1=('$call_c'('Set_Bip_Name_2'(F,2)),Pred).

pred_rewriting(P,P).




test_call_c_allowed(_):-
	g_read(call_c,t),
	!.

test_call_c_allowed(X):-
	error('~q not allowed in this mode',[X]).




add_wrapper_to_dyn_clause(Pred,N,Where+Cl,AuxName):-
	init_aux_pred_name(Pred,N,AuxName,N),
	(Cl=(Head:-Body)
             -> head_wrapper(Head,AuxName,Head1),
                Cl1=(Head1:-Body)
             ;
                head_wrapper(Cl,AuxName,Cl1)),
	assertz(buff_aux_pred(AuxName,N,[Where+Cl1])).


head_wrapper(Head,AuxName,Head1):-
	Head =..[_|LArgs],
	Head1=..[AuxName|LArgs].
/*-------------------------------------------------------------------------*/
/* GNU Prolog                                                              */
/*                                                                         */
/* Part  : Prolog to WAM compiler                                          */
/* File  : wam_emit.pl                                                     */
/* Descr.: code emission                                                   */
/* Author: Daniel Diaz                                                     */
/*                                                                         */
/* Copyright (C) 1999 Daniel Diaz                                          */
/*                                                                         */
/* GNU Prolog is free software; you can redistribute it and/or modify it   */
/* under the terms of the GNU General Public License as published by the   */
/* Free Software Foundation; either version 2, or any later version.       */
/*                                                                         */
/* GNU Prolog is distributed in the hope that it will be useful, but       */
/* WITHOUT ANY WARRANTY; without even the implied warranty of              */
/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU        */
/* General Public License for more details.                                */
/*                                                                         */
/* You should have received a copy of the GNU General Public License along */
/* with this program; if not, write to the Free Software Foundation, Inc.  */
/* 59 Temple Place - Suite 330, Boston, MA 02111, USA.                     */
/*-------------------------------------------------------------------------*/

/*-------------------------------------------------------------------------*/
/* WAM Instructions                                                        */
/*                                                                         */
/* get_variable(V,A)                        put_variable(V,A)              */
/*                                          put_void(A)                    */
/* get_value(V,A)                           put_value(V,A)                 */
/*                                          put_unsafe_value(y(Y),A)       */
/* get_atom(F,A)                            put_atom(F,A)                  */
/* get_integer(I,A)                         put_integer(N,A)               */
/* get_float(N,A)                           put_float(N,A)                 */
/* get_nil(A)                               put_nil(A)                     */
/* get_list(A)                              put_list(A)                    */
/* get_structure(F/N,A)                     put_structure(F/N,A)           */
/*                                                                         */
/*                                          math_load_value(V,A)           */
/*                                          math_fast_load_value(V,A)      */
/*                                                                         */
/* unify_variable(V)                        allocate(N)                    */
/* unify_void(N)                            deallocate                     */
/* unify_value(V)                                                          */
/* unify_local_value(V)                     call(F/N)                      */
/* unify_atom(F)                            execute(F/N)                   */
/* unify_integer(N)                         proceed                        */
/* unify_nil                                fail                           */
/* unify_list           (only for the last subterm if it is a list)        */
/* unify_structure(F/N) (only for the last subterm if it is a structure)   */
/*                                                                         */
/* label(L)                                                                */
/*                                                                         */
/* switch_on_term(Lvar,Latm,Lint,Llst,Lstc)                                */
/* switch_on_atom([(F,L),...])                                             */
/* switch_on_integer([(N,L),...])                                          */
/* switch_on_structure([(F/N,L),...])                                      */
/*                                                                         */
/* try_me_else(L)                           try(L)                         */
/* retry_me_else(L)                         retry(L)                       */
/* trust_me_else_fail                       trust(L)                       */
/*                                                                         */
/* load_cut_level(A)                                                       */
/* cut(V)                                                                  */
/*                                                                         */
/* function(F,X,[X,...])                                                   */
/* call_c(F,[X,...])                                                       */
/* call_c_test(F,[X1,...])                                                 */
/* call_c_jump(F,[X1,...])                                                 */
/* foreign_call_c(F,T0,F0,N0,K,[(T1,N1)...],[X1,...])                      */
/*                F=FctName, T0=ret type F0/N0=BipName/BipArity K=ChcSize  */
/*                Ti=type Ni=0:in 1:out 2:in/out                           */
/*                                                                         */
/* V  : x(X) or y(Y)                                                       */
/* X,Y: integer >= 0                                                       */
/* A  : integer                                                            */
/* N,K: integer                                                            */
/* F,T: atom                                                               */
/* L  : integer >= 1                                                       */
/*-------------------------------------------------------------------------*/

emit_code_init(WamFile0,PlFile0):-
	prolog_file_name(PlFile0,PlFile),
	emit_code_files(WamFile0,PlFile,WamFile),
	(WamFile=user -> current_output(Stream)
                      ;  open(WamFile,write,Stream)),
	g_assign(streamwamfile,Stream),
	g_assign(cur_pl_file,''),
	current_prolog_flag(prolog_name,Name),
	current_prolog_flag(prolog_version,Version),
	current_prolog_flag(prolog_date,Date),
	date_time(dt(Yr,Mh,Dy,Hr,Me,Sd)),
	format(Stream,'%% compiler: ~a ~a (~a)~n',[Name,Version,Date]),
	format(Stream,'%% file    : ~a~n',[PlFile]),
	format(Stream,'%% date    : ~d ~d ~d~n',[Mh,Dy,Yr]),
	format(Stream,'%% time    : ~d:~d:~d~n',[Hr,Me,Sd]).




emit_code_files('',user,user):-
	!.

emit_code_files('',PlFile,WamFile):-
	!,
	decompose_file_name(PlFile,_,Prefix,Suffix),
	(g_read(native_code,t) -> WamSuffix='.wam'
                               ;  WamSuffix='.wbc'),
	(Suffix='.pl'
              -> atom_concat(Prefix,WamSuffix,WamFile)
              ;
                 atom_concat(Prefix,Suffix,WF),
		 atom_concat(WF,WamSuffix,WamFile)).

emit_code_files(WamFile,_,WamFile).




emit_code_term(Bytes,Lines):-
	g_read(streamwamfile,Stream),
	character_count(Stream,Bytes),
	line_count(Stream,Lines),
	close(Stream).




emit_code(Pred,N,PlFile,PlLine,WamCode):-
	g_read(streamwamfile,Stream),
	emit_pred_start(Pred,N,PlFile,PlLine,Stream,_),
	emit_wam_code(WamCode,_,Stream),
	write(Stream,']).'), nl(Stream).




emit_pred_start(Pred,0,PlFile,PlLine,Stream,Type):-
	(Pred='$exe_user',   Type=user
             ;
	 Pred='$exe_system', Type=system),
	!,
	emit_file_name_if_needed(PlFile,Stream),
        format(Stream,'~n~ndirective(~d,~a,',[PlLine,Type]).

emit_pred_start(Pred,N,PlFile,PlLine,Stream,_):-
	emit_file_name_if_needed(PlFile,Stream),
	(test_pred_info(dyn,Pred,N)
                -> StaDyn=dynamic
                ;  StaDyn=static),
	(test_pred_info(pub,Pred,N)
                 -> PubPriv=public
                 ;  PubPriv=private),
	(test_pred_info(bpl,Pred,N) 
                 -> UsBplBfd=built_in
                 ;  (test_pred_info(bfd,Pred,N)
                             -> UsBplBfd=built_in_fd
                             ;  UsBplBfd=user)),
        format(Stream,'~n~npredicate(~q,~d,~a,~a,~a,',
                      [Pred/N,PlLine,StaDyn,PubPriv,UsBplBfd]).




emit_file_name_if_needed(PlFile,_):-
	g_read(cur_pl_file,PlFile),
	!.

emit_file_name_if_needed(PlFile,Stream):-
	format(Stream,'~n~nfile_name(~q).~n',[PlFile]),
	g_assign(cur_pl_file,PlFile).




emit_wam_code([],_,_).

emit_wam_code([WamInst|WamCode],First,Stream):-
	emit_wam_code(WamInst,First,Stream),                % for nested code
	emit_wam_code(WamCode,First,Stream),
	!.

emit_wam_code(WamInst,First,Stream):-
	special_form(WamInst,WamInst1),
	emit_wam_code(WamInst1,First,Stream).

emit_wam_code(WamInst,_,_):-
	g_read(keep_void_inst,f),
	dummy_instruction(WamInst),
	!.

emit_wam_code(WamInst,First,Stream):-
	WamInst=label(_),
	!,
	(var(First) ->  Car='[', First=f ; Car=(',')),
	format(Stream,'~a~n~n',[Car]),
	emit_one_inst(WamInst,Stream).

emit_wam_code(WamInst,First,Stream):-
	(var(First) ->  Car='[', First=f ; Car=(',')),
	format(Stream,'~a~n    ',[Car]),
	emit_one_inst(WamInst,Stream).




emit_one_inst(WamInst,Stream):-
	atom(WamInst),
	!,
	writeq(Stream,WamInst).

emit_one_inst(WamInst,Stream):-
	functor(WamInst,F,N),
	writeq(Stream,F),
	emit_args(0,N,WamInst,Stream),
	write(Stream,')').

emit_args(N,N,_,_):-
	!.

emit_args(I,N,WamInst,Stream):-
	I1 is I+1,
	(I1=1 -> Car='('
              ;  Car=(',')),
	arg(I1,WamInst,A),
	format(Stream,'~a~q',[Car,A]),
	emit_args(I1,N,WamInst,Stream).




emit_ensure_linked:-
	g_read(streamwamfile,Stream),
	retract(ensure_linked(Name,Arity)),
	!,
        format(Stream,'~n~nensure_linked([~q',[Name/Arity]),
	(clause(ensure_linked(Name1,Arity1),_),
         format(Stream,',~q',[Name1/Arity1]),
	 fail
          ;
         true),
	write(Stream,']).'), nl(Stream).

emit_ensure_linked.




bc_emit_code(Pred,N,PlFile,PlLine,LCompCl):-
	g_read(streamwamfile,Stream),
	emit_pred_start(Pred,N,PlFile,PlLine,Stream,Type),
	(nonvar(Type) 
            -> LCompCl=[bc((_:-Body),_)],
	       bc_emit_prolog_term(Stream,Body),
	       format(Stream,').~n',[])
             ;
	       length(LCompCl,NbCl),
	       (LCompCl=[bc('$$empty$$predicate$$clause$$',[proceed])]
                    -> NbCl1=0,    LCompCl1=[]
                    ;  NbCl1=NbCl, LCompCl1=LCompCl),
	       format(Stream,'~d).~n',[NbCl1]),
	       bc_emit_lst_clause(LCompCl1,Stream)).




bc_emit_lst_clause([],_).

bc_emit_lst_clause([bc(Cl,WamCode)|LCompCl],Stream):-
	format(Stream,'~n~nclause(',[]),
	bc_emit_prolog_term(Stream,Cl),
	write(Stream,','),
	emit_wam_code(WamCode,_,Stream),
	format(Stream,']).~n',[]),
	bc_emit_lst_clause(LCompCl,Stream).




bc_emit_prolog_term(Stream,X):-
	numbervars(X,0,_),
	write_term(Stream,X,[numbervars(true),ignore_ops(true),
                             quoted(true)]).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
/*
Predicats inconnus, supposes non-terminants : 
$catch/6
abort/0
absolute_file_name/2
callable/1
character_count/2
current_output/1
expand_term/2
format/3
gvar/2
line_count/2
line_position/2
list/1
numbervars/1
read_pl_state_file/1
real_time/1
syntax_error_info/4
unix/1
user_time/1


'$catch'(_,_,_,_,_,_).
gvar(_,value).
numbervars(_).
read_pl_state_file(sora).
real_time(0).
syntax_error_info(_,_,_,_).
unix(gnu).
user_time(0).

list([]).
list([_|Xs]):-list(Xs).
*/

