Mercurial > hg > Applications > Tokio
diff to.pl @ 0:cfb7c6b24319
Initial revision
author | kono |
---|---|
date | Thu, 30 Aug 2007 14:57:44 +0900 |
parents | |
children |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/to.pl Thu Aug 30 14:57:44 2007 +0900 @@ -0,0 +1,238 @@ +/* + Copyright (C) 1988,2005, Shinji Kono + Everyone is permitted to copy and distribute verbatim copies + of this license, but changing it is not allowed. You can also + use this wording to make the terms for other programs. + + send your comments to kono@ie.u-ryukyu.ac.jp +*/ + +/* + + Tokio compiler to prolog + Thu Aug 15 12:17:04 JST 1985 + Fri Jan 10 16:11:31 JST 1986 + Fri Sep 5 09:51:36 JST 1986 for 1.2a + Thu Mar 26 16:19:10 JST 1987 + Wed Oct 14 13:35:54 JST 1987 full time F + Fri Oct 16 11:28:26 JST 1987 Sicstus + $Header$ + compiler main routine +*/ + +com(X) :- reset_macro,tokiocompile(X). +com(X,Y) :- reset_macro,tokiocompile(X, Y), + (Y = user,!;reconsult(Y)). + +tokiocompile(S) :- + tokiocompile(S, '#temp.tokio'), +% reconsult('#temp.tokio'). + compile0('#temp.tokio'). + +tokiocompile(S, O) :- + cputime(Time), + init_tokiocomp, + tell(O), + tokiocomp(S, [], _L), told, + cputime(Time1),Time0 is Time1-Time, + c_error((write('END '), nl, write(Time0), write(' sec.'),nl)). + +init_tokiocomp :- recorded('$uskel', _X, R), erase(R), fail. +init_tokiocomp :- recorded('$mnum', _X, R), erase(R), fail. +init_tokiocomp. + +tokiocomp([], L, L) :- !. +tokiocomp([H|T], L0, L) :- !, tokiocomp(H, L0, L1), tokiocomp(T, L1, L). +tokiocomp(F, _L0, _L) :- + seeing(O), nofileerrors, tokiofile(F,F1),see(F1), !, + tokiocomp1('$$$$'), seen, see(O), !. +tokiocomp(F, _, _) :- + fileerrors, + c_error((write('Cannot open file: '), write(F), nl)), !, fail. + +tokiofile(F,F). +tokiofile(F,F1) :- name(F,FL),concatenate([FL,".tokio"],NewL),name(F1,NewL). +tokiofile(F,F1) :- name(F,FL),concatenate([FL,".t"],NewL),name(F1,NewL). + + +/* tokiocomp1 + read loop (fail loop) +*/ + +tokiocomp1(X) :- tokiocomp2(X). +tokiocomp1(_) :- + read(Next), !, tokiocomp1(Next). +tokiocomp1(_) :- c_error((nl,write('read error'),nl)). + +/* tokocomp2 + compiler directive + this predicate never success except file end. +*/ + +tokiocomp2(end_of_file) :- !. +tokiocomp2('$$$$') :- !,fail. +tokiocomp2('$define'(Macro)) :- + read_macro(Macro),!,fail. +tokiocomp2('$function'(Function)) :- + read_function(Function),!,fail. +tokiocomp2((:- X)) :- + call(X), write_clause((:- X)),!,fail. +tokiocomp2((?- X)) :- + call(X), write_clause((:- X)),!,fail. +tokiocomp2(Head) :- compiling_message(Head),fail. +tokiocomp2(X) :- preprocess(X,X1),!,tokiocomp3(X1). + +compiling_message((Head :- _Body)) :- !,compiling_message(Head). +compiling_message(Head) :- + (systemp(Head);Head = (_,_);Head = [_|_];functor(Head,'{}',_)),!, + functor(Head,H,A), + c_error(( + write('Compiling System Predicate: '), + write(H/A),nl)),!. +compiling_message(Head) :- + functor(Head,H,A), + c_error(( + write('Compiling: '), + write(H/A),nl)),!,!. + +/* tokiocomp3 + if end_of_file then success otherwise fail +*/ + +tokiocomp3((X,_Y)) :- tokiocomp3(X),fail. % fail and fall into next line +tokiocomp3((_X,Y)) :- !,tokiocomp3(Y). +tokiocomp3(X) :- + c_clause(X, C), write_clause(C),!, fail. % to reduce stack +tokiocomp3(X) :- + c_error((nl,write('compiler error on '),write(X),nl)),fail. + +% preprocess(X,X). % no development + +display_fa(F/A) :- display(F), display('/'), display(A), display(','). + +writel([]) :- !. +writel([X|L]) :- writel(L), write(X), write(', '). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% +% varialble type +% +% '$REF' full referenced variable +% '$TMP' both now and next are referenced +% '$NOW','$NXT' either now or next is referenced +% '$CNT' this variable is constnat in time transition +% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +variable(X) :- var(X), !. +variable('$REF'(_)) :- !. +variable('$CNT'(_)) :- !. +variable('$NOW'(_,_)) :- !. +variable('$NXT'(_,_)) :- !. +variable('$TMP'(_,_,_)). + + +% c_post(Vname, Vname, V0, V) :- +% var(Vname),!, V is V0+1,name(V0,Lv),name(Vname,[95|Lv]). %%% _001 +c_post(Vname, Vname, V0, V) :- + var(Vname),!, V is V0+1,Vname = '$VAR'(V0). %%% _001 +c_post('$VAR'(X), '$VAR'(X), V, V) :- !. +c_post('$CNT'(X), XX, V0, V) :- !, c_post(X, XX, V0, V). +c_post('$REF'(X), XX, V0, V) :- !, c_post(X, XX, V0, V). +c_post('$TMP'(X,Now,Nxt), XX, V0, V) :- !, c_post_tvar(X,Now,Nxt, XX, V0, V). +c_post('$NOW'(X,Now), XX, V0, V) :- !, c_post_tvar(X,Now,_Nxt, XX, V0, V). +c_post('$NXT'(X,Nxt), XX, V0, V) :- !, c_post_tvar(X,_Now,Nxt, XX, V0, V). +c_post(Atomic,Qatomic,V,V) :- atomic(Atomic),!, + c_post_atomic(Atomic,Qatomic). +c_post([A|B],[AA|BB], V0, V) :- !, + c_post(A,AA,V0,V1),c_post(B,BB,V1,V). +c_post((A,B),(AA,BB), V0, V) :- !, + c_post(A,AA,V0,V1),c_post(B,BB,V1,V). +% Special Hack.... ( nonvar for C-Prolog) +c_post('r_eq'(A,B,Q1,Q2), B1=A1, V0, V) :- nonvar(A),nonvar(B), + functor(A,'$CNT',_),functor(B,'$CNT',_),!, + c_post(A,A1,V0,V1),c_post(B,B1,V1,V2), + c_post(Q1,Q11,V2,V3),c_post(Q2,Q12,V3,V),Q11=Q12. +c_post('r_eq'(A,B,Q1,Q2), 'r_eqn'(B1,A1,Q11,Q12), V0, V) :- nonvar(A), + functor(A,'$CNT',_),!, + c_post(A,A1,V0,V1),c_post(B,B1,V1,V2), + c_post(Q1,Q11,V2,V3),c_post(Q2,Q12,V3,V). +c_post('r_eq'(A,B,Q1,Q2), 'r_eqn'(A1,B1,Q11,Q12), V0, V) :- nonvar(B), + functor(B,'$CNT',_),!, + c_post(A,A1,V0,V1),c_post(B,B1,V1,V2), + c_post(Q1,Q11,V2,V3),c_post(Q2,Q12,V3,V). +c_post('r_eq'(A,B,Q1,Q2), 'r_eq'(A1,B1,Q11,Q12), V0, V) :- !, + c_post(A,A1,V0,V1),c_post(B,B1,V1,V2), + c_post(Q1,Q11,V2,V3),c_post(Q2,Q12,V3,V). +c_post(X, XX, V0, V) :- + functor(X, F, A), c_post_atomic(F,F1),!, functor(XX, F1, A), + c_post_args(0, A, X, XX, V0, V). + +c_post_atomic(X,X). +% c_post_atomic([],[]) :- !. +% c_post_atomic(Number,Number) :- number(Number),!. +% c_post_atomic(Atomic,Qatomic):- +% name(Atomic,La),La=[H|_],[H]\="'",[H]\="_",!, +% concatenate(["'",La,"'"],Nla),name(Qatomic,Nla). +% c_post_atomic(Atomic,Atomic). + +c_post_args(N, N, _, _, V, V) :- !. +c_post_args(K, N, X, XX, V0, V) :- + K1 is K+1, arg(K1, X, XK), c_post(XK, XXK, V0, V1), arg(K1, XX, XXK), + c_post_args(K1, N, X, XX, V1, V). + +c_post_tvar(X, Now, Nxt, '$t'(Now1,Nxt1), V0, V) :- var(X),!, + X='$TMP'(_,Now,Nxt), + c_post(Now, Now1, V0, V1), + c_post(Nxt, Nxt1, V1, V). +c_post_tvar('$REF'(X), _Now, _Nxt, XX, V0, V) :- !, + c_post(X, XX, V0, V). +c_post_tvar('$CNT'(X), _Now, _Nxt, XX, V0, V) :- !, + c_post(X, XX, V0, V). +c_post_tvar('$TMP'(X,Now,Nxt), Now, Nxt, XX, V0, V) :- !, + c_post_tvar(X, Now, Nxt, XX, V0, V). + +write_clause(X) :- recorded('r_assert',_,_),assert_clause0(X). +write_clause(_) :- recorded('r_assert',_,_). +write_clause(X) :- write_clause0(X). +write_clause(_). + +write_clause0((X:-true)) :- + c_post(X, XX, 0, _), + write_term(XX,[numbervars(true),quoted(true)]), + % writeq(XX), + put("."), nl,!,fail. %%% writeq --> write +write_clause0(X) :- + c_post(X, XX, 0, _), writeq1(XX), put("."), nl,!,fail. %%% writeq --> write + +% a little pretty print +writeq1((A,B)) :- !,writeq1(A),put("."), nl, + writeq1(B). +writeq1((H:-B)) :- !, + % writeq(H), + write_term(H,[numbervars(true),quoted(true)]), + write((:-)), + writeq2(B). +writeq1(X) :- + % writeq(X). + write_term(X,[numbervars(true),quoted(true)]). +writeq2((A,B)) :- !,nl,tab(4), + % writeq(A), + write_term(A,[numbervars(true),quoted(true)]), + put(","),writeq2(B). +writeq2(X) :- nl,tab(4), + write_term(X,[numbervars(true),quoted(true)]). + % writeq(X). + + +assert_clause(X) :- assert_clause0(X). +assert_clause(_). + +%assert_clause0((X:-true)) :- +% c_post(X, XX, 0, _), c_melt(XX,XXX,_), +% recorda('r_run',XXX,Ref),assertz(XXX), !,fail. +assert_clause0(X) :- + c_post(X, XX, 0, _), c_melt(XX,((XXX:-Y)),_), + recorda('r_run',((XXX:-_)),_Ref),assertz((XXX:-Y)), !,fail. + +/* end */