%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%  PDSS (PIMOS Development Support System)  Version 2.52		 %
%  (C) Copyright 1988,1989,1990,1992.					 %
%  Institute for New Generation Computer Technology (ICOT), Japan.	 %
%  Read "../COPYRIGHT" for detailed information.			 %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

%%%%%%%%%%%%%%%%%%%%%%%%%
%   Top level predicates
%
%	of
%
%   KL1/KL1 compiler
%%%%%%%%%%%%%%%%%%%%%%%%%

:- module 	kl1cmp_command.
:- public       tsscomp/1, tsscomp/0,
		kl1compile/0, ghccompile/8, message_distributer/7,
		write_string/3,
		compile_for_pdss/6.

%:- mode klb_version(-).
kl1b_version(Version) :- true |
   Version='**** KL1B Compiler Ver 0.5a (8807xx) ****'.		%%880427-KH

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%  Toplevels  %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

%:- mode kl1compile.
kl1compile :- true |
    window:create(Window, string#"kl1cmp"),
%    file:create(Infile, Infile_name, 'r'),
%    symbol_name(I, Infile_name),
    file_open(Window1, Window2, Infile, I, r),
%    file:create(Outfile, Outfile_name, 'w'),
%    symbol_name(O, Outfile_name),
    file_open(Window2, Window3, Outfile, O, w),
    Window=[show, putt(Version), nl,
        putt('Optimize lavel : '), getft(Opt, _),
        putt('Input File     : '), getft(I, _),
        putt('Output File    : '), getft(O, _)|Window1],
   kl1b_version(Version),
   ghccompile(StructStream, [], Out, [], Error1, [], Opt, _)
		@priority('$', -1024),
   kl1cmp_reader:create_reader(Infile, [],
		S0, [], Reader_stream)@priority('$', 1024),
   kl1cmp_macro:generate_macro_expander(Reader_stream, [], MacroError, [],
		MacroArg, MacroStream),
   kl1cmp_macro_arg:init_macro_table(MacroArg0),
   merge(MacroArg, MacroArg0),
   kl1cmp_struct:struct_processor(MacroStream, [], ConstCode,
			[], StructStream),
   kl1cmp_output:output_const_code(ConstCodeMsg, [close(Ack0)], ConstCode),
   my_merge({S0, Out, Error1, MacroError}, IOs)@priority('$', 1024),
   message_distributer(Outfile, ConstCodeMsg,
	Window3, Window4, non_error, Error, IOs)@priority('$', 1024),
   check_error(Error, Ack0, Ack),
   Window4=[nl, putt('Status is '), putt(Ack), nl,		%%880427-KH
	    putt(I), putt(' is compiled.'), getl(_)].		%%880427-KH

check_error(error, _, Ack) :- true | Ack =error.
check_error(non_error, Ack0, Ack) :- true | Ack0=Ack.

my_merge(In, Out) :- true |
   merge(In, Out).

% File Open
:- local_implicit wind:oldnew.
file_open(St, Name, Mode) --> true |
   convert_name_to_string(Name, STname),
 {{mpimos_file:create(StOrg, STname, Mode, Status)}},
   status_check(Status, StOrg, St, Mode).

convert_name_to_string(Name, STname) --> string(Name, _, _) |
 {{STname = Name}}.
convert_name_to_string(Name, STname) --> string(Name, _, _) |
 {{STname = Name}}.
convert_name_to_string(Name, STname) --> atom(Name) |
 {{atom_name(Name, STname)}}.
otherwise.
convert_name_to_string(Name, STname) --> true |
   &wind<<=[nl, puttq(Name), putt(string#"is not allowed as file name."), nl,
           putt(string#"Input once more"), gett(NewName)],
   convert_name_to_string(NewName, STname).

status_check(success, StOrg, St, _) --> true | StOrg=St.
otherwise.
status_check(_, StOrg, St, Mode) --> true |
    &wind<<=[nl, putt(string#"Can't get file stream."), nl,
           putt(string#"Input Once More"), gett(NewName)],
    StOrg=[],
    file_open(St, NewName, Mode).

compile_for_pdss(Opt, Instream0, Outstream0, Error0, Ext, Ack) :- true |
   ghccompile(StructStream, [], IO0, [], CompileError, [], Opt, Ext)
		@priority('$', -1024),
   kl1cmp_reader:create_reader(Instream0, [], IO2, [], ReaderStream),
   kl1cmp_macro:generate_macro_expander(ReaderStream, [], MacroError, [],
		MacroArg, MacroStream),
   kl1cmp_macro_arg:init_macro_table(MacroArg0),
   merge(MacroArg, MacroArg0),
   kl1cmp_struct:struct_processor(MacroStream, [], ConstCode, [],
		StructStream),
   kl1cmp_output:output_const_code(ConstCodeMsg, [close(Ack0)], ConstCode),
   merge({CompileError, IO0, IO2, MacroError}, ToMsg),
   message_distributer(Outstream0, ConstCodeMsg, Error0, [],
		non_error, Error, ToMsg),
 {{check_error(Error, Ack0, Ack)}}.


% This predicate devide a message stream into three stream,
% infile, outfile, window.
% for window output
% change for error message 880315 D.Sekita

:- local_implicit outfile:oldnew, window:oldnew, error:oldnew.
message_distributer([display(X)|S1]) --> true |
    &window<<=[putt(X)],
    message_distributer(S1).
message_distributer([ttynl|S1]) --> true |
    &window<<=[nl],
    message_distributer(S1).
message_distributer([ttyput(X)|S1]) --> true |
    &window<<=[putc(X)],
    message_distributer(S1).
%message_distributer([add_op(Prec, Type, Atom)|S1]) --> true |
%   &infile<<=[add_op(Prec, Type, Atom)],
%    message_distributer(S1).
% for input
%message_distributer([getft(X, Y)|S1]) --> true |
%    &infile<<=[getft(X,Y)],
%    message_distributer(S1).
% for output
message_distributer([putc(X)|S1]) --> true |
    &outfile<<=[putc(X)],
    message_distributer(S1).
message_distributer([puts(X)|S1]) --> true |
  {{write_string(&outfile, X)}},
    message_distributer(S1).
message_distributer([putt(X)|S1]) --> true |
    &outfile<<=[putt(X)],
    message_distributer(S1).
message_distributer([puttq(X)|S1]) --> true |
     &outfile<<=[puttq(X)],
    message_distributer(S1).
message_distributer([nl|S1]) --> true |
    &outfile <<= [nl],
    message_distributer(S1).
message_distributer([code(Codes, CodeTail)|S1]) --> true |
  {{'C'(&outfile, Codes, CodeTail)}},
    &outfile<<=[flush(Out)],
    &window<<=[flush(Win)],
%    wait_flushed(Out, Win, S1).
    message_distributer(S1).
message_distributer([error_message(Msg, Cls)|S1]) --> true |
    &error<=error,
 {{ error(&window, Msg, Cls)}},
    message_distributer(S1).
message_distributer([warning_message(Msg, Cls)|S1]) --> true |
 {{ warning(&window, Msg, Cls)}},
    message_distributer(S1).
message_distributer([]) --> true | true.
otherwise.
message_distributer([Msg|S1]) --> true |
    &window<<=[putt(string#"Strange I/O command found"), nl, putt(Msg),
			nl],
    message_distributer(S1).

wait_flushed(done, done, S) --> true |
    message_distributer(S).

'C'(Out0, Out1, In0, In1) :- true | Out0=In0, Out1=In1.

:- local_implicit io:oldnew.
write_string(Str) --> true |
    intern_atom(Atom, Str),
    &io<<=[putt(Atom)].

write_string(0, _, _) --> true | true .
otherwise.
write_string(N, A, Str) --> string_element(Str, A, C) |
  {{N1 := N-1, A1 := A+1}},
    &io<<=[putc(C)],
    write_string(N1, A1, Str).


:- local_implicit reader:oldnew, io:oldnew, error:oldnew.
%:- mode ghccompile(+, -, ?).
ghccompile(Opt, Ext) --> true |
 {{create_state([(module)=[], external=[], messages=[]], State0)}},
   &reader<<=[read_predicate(Clauses, Pred)],
 {{compile_case_on_pred(&io, &error,
		Pred, Clauses, Opt, Module, Ext, State0)@priority('$', 1024)}},
   &reader<<=[read_predicate(NextClauses, NextPred)],
   check_end_of_file(NextPred, Opt, NextClauses, Module)@priority('$', 1024).

:- local_implicit io:oldnew, error:oldnew.
compile_case_on_pred(directive, Dir, _, Module, Ext, State0) --> true |
 {{compile_initial_directives(&error, State0, State1, Dir),
   access_state(State1, State2, (module), Module, void),
   access_state(State2, State3, external, Ext, void)}},
   kl1cmp_output:write_rkp_information(Module, Ext),
 {{access_state(State3, _, messages, Msg, void),
   kl1cmp_output:write_messages(&io, Msg)}}.
otherwise.
compile_case_on_pred(_, _, _, Module, Ext, _) --> true |
   &io<<=[error_message(string#"No Initial directives found ", [])],
   Module=[], Ext=[].

:- local_implicit reader:oldnew, io:oldnew, error:oldnew.

check_end_of_file(end_of_file, _, _, _) --> true|
	&error<<=[error_message(string#"no predicate found", [])] .
otherwise.
check_end_of_file(Pred, Opt, Clauses, Module) --> true |
 {{read_and_compile_predicate(R0, Code0, Error0, Opt, Clauses, Pred,
		Module)@priority('$', -1024),
   merge(Code0,Code), merge(Error0,Error), merge(R0,R),
%   high_priority_merge(Code0, Code)@priority('$', 1024),
   out_to_stream(&io, Code)@priority('$', 1024),
   out_to_stream(&error, Error)@priority('$', 1024),
   out_to_stream(&reader, R)}}.

high_priority_merge(In, Out) :- true |
   merge(In, Out).

:- local_implicit reader:oldnew.
out_to_stream([Msg|Cdr]) --> true |
   &reader<<=[Msg],
   out_to_stream(Cdr).
out_to_stream([])--> true | true.

:- local_implicit reader:oldnew, io:oldnew.
%:- mode tsscomp(+).
tsscomp(Opt) :-	 true |				% 86,8,9 YKIMURA
   window:create([show|Window_stream], string#"kl1cmp"),
   kl1cmp_reader:trans_io_instr(Wind, [], S1),
   merge({Wind, In}, Window_stream),
   kl1cmp_reader:create_reader(In, [], Out, [], R0),  % debug 871014
   R0=[read_predicate(Clauses, Pred)|R1], % Ignore directives.
   create_state([(module)=[], external=[], messages=[]], _),
   merge({IOs, Out, Error_msg}, S1),
   read_and_compile_predicate(R1, IOs, Error_msg, Opt, Clauses, Pred, []).

tsscomp :- true | tsscomp(0).

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%  Directives  %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Directives before the first predicate.

:- local_implicit error:oldnew, states:oldnew.
%:- mode compile_initial_directives(+, +, -, -, ?).
compile_initial_directives([]) --> true | true.
compile_initial_directives([D|Ds]) --> true |
   compile_initial_directive(D),
   compile_initial_directives(Ds).

%:- mode compile_initial_directive(+, +, -, -, ?).
compile_initial_directive((:- public P)) --> true |
 {{conjunction_to_list(Ext0, Ext1, P),
   access_state(&states, external, Ext1, Ext0) }}.
compile_initial_directive((:- message(M))) --> true |
 {{access_state(&states, messages, Ext1, [M|Ext1])}}.
compile_initial_directive((:- module M2)) --> true |
 {{access_state(&states, (module), M1, M2),
   check_module(&error, M1, M2)}}.
otherwise.
compile_initial_directive(Directive) --> true |
   &error<<=[warning_message(string#"This directive is not allowed here. ",
		[Directive])].

:- local_implicit error:oldnew.
%:-mode compile_directives(+, -, ?).
compile_directives([]) --> true | true.
compile_directives([(:- message(M))|Ds]) --> true |
   kl1cmp_output:write_messages([M]), compile_directives(Ds).
otherwise.
compile_directives([D|Ds]) --> true |
   &error<<=[warning_message(string#"This directive is not allowed here.", [D])],
   compile_directives(Ds).

:- local_implicit error:oldnew.
%:- mode check_module(+, +, -, -, ?).
check_module([], M2) --> true | true.
check_module(M1, M2) --> M1 \= [] |
    &error<<=[error_message(string#"Duplicate module specification ", [M2])].

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%  Compiling predicates  %%%%%%%%%%%%%%%%%%%%%%%%%%

:- local_implicit reader:stream, io:stream, error:stream.
%:-mode read_and_compile_predicate(+, +, +, -, ?).
read_and_compile_predicate(_, _, end_of_file, _) --> true |
   &error<<=[display('END.'), ttynl].
otherwise.
read_and_compile_predicate(Opt, Clauses, Pred, Module) --> true |
 {{check_overlapped_builtin(&error,Pred)}},
 {{kl1cmp_register:compile_predicate(Code, CodeTail, &error, [], Opt, Module,
	Clauses, Pred, 1)}},
   CodeTail = [flush(F)|CodeTail1], % 890417 Nishizaki
   &io<<=[code(Code, CodeTail1)],
   wait_compiled(F, Pred, Next_clauses,Next_pred)@priority('$', 1024),
   compile_directives_or_clause(Next_pred, Next_clauses, Opt, Module).

compile_directives_or_clause(directive, Dir, Opt, Module) --> true |
 {{compile_directives(DirCode, DirCodeTail, Dir)}},
   &io <<= [code(DirCode, DirCodeTail)],
   &reader<<=[read_predicate(Next_clauses, Next_pred)],
   read_and_compile_predicate(Opt, Next_clauses, Next_pred, Module).
otherwise.
compile_directives_or_clause(Pred, Clause, Opt, Module) --> true |
   read_and_compile_predicate(Opt, Clause, Pred, Module).

wait_compiled(F, Pred, Next_clauses,Next_pred) -->
   wait(F) |
   &error<<=[display(Pred), display(',')],
   &reader<<=[read_predicate(Next_clauses, Next_pred)].

:- local_implicit io:oldnew.
error(Msg, Cls) --> true |
   &io<<=[putb(string#"Error"), putt(':'), putb(Msg), nl],
   output_error(Cls).

warning(Msg, Cls) --> true |
   &io<<=[putb(string#"Warning"), putt(':'), putb(Msg), nl],
   output_error(Cls).

output_error([E|R]) --> true |
   &io<<=[putc(9), puttq(E)],
   output_error(R).
output_error([]) --> true | &io<<=[nl].
otherwise.
output_error(X) --> true |
   &io<<=[putc(9), puttq(X), nl].

create_state(L,State) :- true | L=State.	% Ha!

%:- mode access_state(+, +, -, ?, -).
access_state([(K=V)|S1], T0, K, V1, V2) :- true | V=V1, T0=[(K=V2)|S1].
access_state([(K2=V)|S1], T0, K1, V1, V2) :- K1\=K2 |
    T0=[(K2=V)|T1], access_state(S1, T1, K1, V1, V2).
access_state([], T0, K, V1, V2) :- true |
    T0=[K=V1], V2=V1.

:- local_implicit list:oldnew.
%:- mode conjunction_to_list(+, -, ?).
conjunction_to_list((A,X)) --> true |
   &list<<=[A],
   conjunction_to_list(X).
otherwise.
conjunction_to_list(X) --> true |
   &list<<=[X].

:- local_implicit error:stream.
check_overlapped_builtin(F/A) --> true |
   L:=A+1,
   new_vector(V,L), set_vector_element(V,0,_,F,B),
 {{kl1cmp_blttbl:active_builtin(B,_,_,_,Type)}},
   check_overlapped_builtin_type(Type,F,A).

check_overlapped_builtin_type(builtin,F,A) --> true|
   &error<<=[warning_message(
	string#"This predicate overlapped with builtin predicate",[F/A])].
check_overlapped_builtin_type(none,merge,3) --> true |
   &error<<=[warning_message(
	string#"This predicate overlapped with builtin macro",[merge/3])].
check_overlapped_builtin_type(none,merge_in,3) --> true |
   &error<<=[warning_message(
	string#"This predicate overlapped with builtin macro",[merge_in/3])].
otherwise.
check_overlapped_builtin_type(none,_,_) --> true | true.
