diff -ruN klic-3.003-2002-01-22/compiler/extern.kl1 klic-3.003-2002-01-23/compiler/extern.kl1 --- klic-3.003-2002-01-22/compiler/extern.kl1 Tue Jan 22 13:41:07 2002 +++ klic-3.003-2002-01-23/compiler/extern.kl1 Wed Jan 23 15:28:16 2002 @@ -5,9 +5,6 @@ % (Read COPYRIGHT-JIPDEC for detailed information.) ----------------------------------------------------------- */ -% referring modules. -% klic_comp_util - :- module klic_comp_extern. :- public make_ext_table/3. % called in write.kl1 diff -ruN klic-3.003-2002-01-22/compiler/insert.kl1 klic-3.003-2002-01-23/compiler/insert.kl1 --- klic-3.003-2002-01-22/compiler/insert.kl1 Thu Dec 27 19:15:57 2001 +++ klic-3.003-2002-01-23/compiler/insert.kl1 Wed Jan 23 11:12:07 2002 @@ -1,6 +1,6 @@ -/* ---------------------------------------------------------- -% (C)1993,1994,1995 Institute for New Generation Computer Technology -% (Read COPYRIGHT for detailed information.) +/* ---------------------------------------------------------- +% (C)1993,1994,1995 Institute for New Generation Computer Technology +% (Read COPYRIGHT for detailed information.) % (C)1996, 1997, 1998, 1999 Japan Information Processing Development Center % (Read COPYRIGHT-JIPDEC for detailed information.) ----------------------------------------------------------- */ @@ -46,225 +46,272 @@ :- module klic_comp_insert. -make_index_tree([],_V,T0,T,_):- T = T0. -make_index_tree([Cond-Body|CT],V0,T0,T,Info) :- - ins_index(Cond,T0,V0,Body,T1,Ans), - make_index_tree_1(Ans,CT,V0,T0,T1,T,Info). -make_index_tree([otherwise|CT],V0,T0,R,Info) :- - R = other(T0,T), - make_index_tree(CT,V0,e,T,Info). -make_index_tree([alternatively|CT],V0,T0,R,Info) :- - R = alter(T0,T), - make_index_tree(CT,V0,e,T,Info). - - make_index_tree_1(normal,CT,V0,T0,T1,T,Info) :- - make_index_tree(CT,V0,T1,T,Info). - make_index_tree_1(abnormal,CT,V0,T0,T1,T,Info) :- Info=Name/Arity | - klic_comp_message:warning("Clause deleted: ~w/~d", [Name,Arity]), - make_index_tree(CT,V0,T0,T,Info). - -ins_index([],T0,_Vars,Body,T,Ans) :- T0=e | - Ans = normal, T = l(Body). -ins_index([],T0,_Vars,Body,T,Ans) :- T0\=e | - ins_redundant(Ans), T = l(Body). -ins_index([(X;Y)],T0,Vars,Body,T,Ans) :- - ins_index(X,T0,Vars,Body,T1,Ans0), - ins_index_check_and_stop(Y,T1,Vars,Body,T ,Ans0,Ans). -ins_index([Position:Pattern|CondT],T0,Vars,Body,T,Ans) :- - subsumed(Pattern,Position,Vars,Ans0), - ins_index_check_and_go([Position:Pattern|CondT],T0,Vars,Body,T,Ans0,Ans). +% called in normalize.kl1, generate.kl1 +:- public make_index_tree/5, subsumed_type/3. + +make_index_tree( [], _V, T0, T, _ ) :- + T = T0. +make_index_tree( [Cond-Body | CT], V0, T0, T, Info ) :- + ins_index( Cond, T0, V0, Body, T1, Ans ), + make_index_tree_1( Ans, CT, V0, T0, T1, T, Info ). +make_index_tree( [otherwise | CT], V0, T0, R, Info ) :- + R = other( T0, T ), + make_index_tree( CT, V0, e, T, Info ). +make_index_tree( [alternatively | CT], V0, T0, R, Info ) :- + R = alter( T0, T ), + make_index_tree( CT, V0, e, T, Info ). + + make_index_tree_1( normal, CT, V0, T0, T1, T, Info ) :- + make_index_tree( CT, V0, T1, T, Info ). + make_index_tree_1( abnormal, CT, V0, T0, T1, T, Info ) :- Info = Name/Arity | + klic_comp_message:warning( "Clause deleted: ~w/~d", [Name, Arity] ), + make_index_tree( CT, V0, T0, T, Info ). + +ins_index( [], T0, _Vars, Body, T, Ans ) :- T0 = e | + Ans = normal, + T = l( Body ). +ins_index( [], T0, _Vars, Body, T, Ans ) :- T0 \= e | + ins_redundant( Ans ), + T = l( Body ). +ins_index( [( X;Y )], T0, Vars, Body, T, Ans ) :- + ins_index( X, T0, Vars, Body, T1, Ans0 ), + ins_index_check_and_stop( Y, T1, Vars, Body, T , Ans0, Ans ). +ins_index( [Position:Pattern | CondT], T0, Vars, Body, T, Ans ) :- + subsumed( Pattern, Position, Vars, Ans0 ), + ins_index_check_and_go( + [Position:Pattern | CondT], T0, Vars, Body, T, Ans0, Ans ). otherwise. -ins_index(Cond,T0,Vars,Body,T,Ans) :- - ins_index_1(Cond,T0,Vars,Body,T,Ans). +ins_index( Cond, T0, Vars, Body, T, Ans ) :- + ins_index_1( Cond, T0, Vars, Body, T, Ans ). -ins_index_check_and_stop(X,T0,Vars,Body,T,Check,Ans) :- Check=normal | - ins_index(X,T0,Vars,Body,T,Ans). -ins_index_check_and_stop(X,T0,Vars,Body,T,Check,Ans) :- Check=abnormal | - T=T0, Ans=Check. - -ins_index_check_and_go(L,T0,Vars,Body,T,Check,Ans) :- Check=normal, L=[_|X] | - ins_index(X,T0,Vars,Body,T,Ans). -ins_index_check_and_go(X,T0,Vars,Body,T,Check,Ans) :- Check=abnormal | - ins_index_1(X,T0,Vars,Body,T,Ans). - -ins_index_1([Cond|CondT], T0,Vars,Body,T,Ans) :- - ( Cond=gp(C); Cond=gg(C,K); Cond=il(F,A,I) ) | - ins_gb(T0,Cond,T,T1,T2,Ans0), - ins_index_check_and_stop(CondT,T1,Vars,Body,T2,Ans0,Ans). -ins_index_1([Cond|CondT], T0,Vars,Body,T,Ans) :- Cond=gb(C,OT) | - ins_gb(T0,Cond,T,T1,T2,Ans0), - ins_index_check_and_stop(CondT,T1,[gb(C)=OT|Vars],Body,T2,Ans0,Ans). -ins_index_1([Position:Pattern|CondT], T0,Vars0,Body,T,Ans) :- - ins_pattern(T0,Pattern,Position,T,Vars0,Vars,T1,T2,Ans0), - ins_index_check_and_stop(CondT,T1,Vars,Body,T2,Ans0,Ans). +ins_index_check_and_stop( X, T0, Vars, Body, T, Check, Ans ) :- + Check = normal | + ins_index( X, T0, Vars, Body, T, Ans ). +ins_index_check_and_stop( X, T0, Vars, Body, T, Check, Ans ) :- + Check = abnormal | + T = T0, + Ans = Check. + +ins_index_check_and_go( L, T0, Vars, Body, T, Check, Ans ) :- + Check = normal, L = [_ | X] | + ins_index( X, T0, Vars, Body, T, Ans ). +ins_index_check_and_go( X, T0, Vars, Body, T, Check, Ans ) :- + Check = abnormal | + ins_index_1( X, T0, Vars, Body, T, Ans ). + +ins_index_1( [Cond | CondT], T0, Vars, Body, T, Ans ) :- + ( Cond = gp( C ); Cond = gg( C, K ); Cond = il( F, A, I )) | + ins_gb( T0, Cond, T, T1, T2, Ans0 ), + ins_index_check_and_stop( CondT, T1, Vars, Body, T2, Ans0, Ans ). +ins_index_1( [Cond | CondT], T0, Vars, Body, T, Ans ) :- Cond = gb( C, OT ) | + ins_gb( T0, Cond, T, T1, T2, Ans0 ), + ins_index_check_and_stop( + CondT, T1, [gb( C )=OT | Vars], Body, T2, Ans0, Ans ). +ins_index_1( [Position:Pattern | CondT], T0, Vars0, Body, T, Ans ) :- + ins_pattern( T0, Pattern, Position, T, Vars0, Vars, T1, T2, Ans0 ), + ins_index_check_and_stop( CondT, T1, Vars, Body, T2, Ans0, Ans ). /* Normal Pattern */ -ins_pattern(e,Pat,Pos,NewN,Vars0,Vars,T0,T,Ans) :- - Vars = [Pos=Pat|Vars0], - pattern_kind(Pat,Kind), - ins_value_node(Kind,Pat,Pos,e,e,e,e,e,NewN,T0,T,Ans). -ins_pattern(v(Pos,A,L,F,B,U),Pat,Pos,NewN,Vars0,Vars,T0,T,Ans) :- - Vars = [Pos=Pat|Vars0], - pattern_kind(Pat,Kind), - ins_value_node(Kind,Pat,Pos,A,L,F,B,U,NewN,T0,T,Ans). -ins_pattern(v(Pos,A,L,F,B,U),Pos,Pat,NewN,Vars0,Vars,T0,T,Ans) :- - Vars = [Pos=Pat|Vars0], - pattern_kind(Pat,Kind), - ins_value_node(Kind,Pat,Pos,A,L,F,B,U,NewN,T0,T,Ans). -ins_pattern(x(Cond,Node,U0),Pat,Pos,NewN,Vars0,Vars,T0,T,Ans) :- - NewN = x(Cond,Node,U), - ins_pattern(U0,Pat,Pos,U,Vars0,Vars,T0,T,Ans). -ins_pattern(l(_Body),_,_,_,_,_,_,_,Ans) :- ins_redundant(Ans). +ins_pattern( e, Pat, Pos, NewN, Vars0, Vars, T0, T, Ans ) :- + Vars = [Pos=Pat | Vars0], + pattern_kind( Pat, Kind ), + ins_value_node( Kind, Pat, Pos, e, e, e, e, e, NewN, T0, T, Ans ). +ins_pattern( v( Pos, A, L, F, B, U ), Pat, Pos, NewN, Vars0, Vars, T0, T, Ans ) :- + Vars = [Pos=Pat | Vars0], + pattern_kind( Pat, Kind ), + ins_value_node( Kind, Pat, Pos, A, L, F, B, U, NewN, T0, T, Ans ). +ins_pattern( v( Pos, A, L, F, B, U ), Pos, Pat, NewN, Vars0, Vars, T0, T, Ans ) :- + Vars = [Pos=Pat | Vars0], + pattern_kind( Pat, Kind ), + ins_value_node( Kind, Pat, Pos, A, L, F, B, U, NewN, T0, T, Ans ). +ins_pattern( x( Cond, Node, U0 ), Pat, Pos, NewN, Vars0, Vars, T0, T, Ans ) :- + NewN = x( Cond, Node, U ), + ins_pattern( U0, Pat, Pos, U, Vars0, Vars, T0, T, Ans ). +ins_pattern( l( _Body ), _, _, _, _, _, _, _, Ans ) :- + ins_redundant( Ans ). otherwise. -ins_pattern(v(Pos0,A,L,F,B,U0),Pat,Pos,NewN,Vars0,Vars,T0,T,Ans) :- - NewN = v(Pos0,A,L,F,B,U), - ins_pattern(U0,Pat,Pos,U,Vars0,Vars,T0,T,Ans). - -ins_value_node(list,_,Pos,A,L0,F,B,U,NewN,T0,L,Ans) :- - NewN = v(Pos,A,L,F,B,U), T0 = L0, Ans = normal. -ins_value_node(bound,_,Pos,A,L,F,B0,U,NewN,T0,B,Ans) :- - NewN = v(Pos,A,L,F,B,U), T0 = B0, Ans = normal. -ins_value_node(atomic,X,Pos,A0,L,F,B,U,NewN,T0,T,Ans) :- - NewN = v(Pos,A,L,F,B,U), - ins_atomic_node(A0,X,A,T0,T,Ans). -ins_value_node(functor,X,Pos,A,L,F0,B,U,NewN,T0,T,Ans) :- - NewN = v(Pos,A,L,F,B,U), - ins_funct_node(F0,X,F,T0,T,Ans). -ins_value_node(other,X,Pos,A,L,F,B0,U,NewN,T0,T,Ans) :- - NewN = v(Pos,A,L,F,B,U), - ins_eq(B0,Pos,X,B,T0,T,Ans). - -pattern_kind(list, Kind) :- Kind = list. -pattern_kind(bound, Kind) :- Kind = bound. -pattern_kind(atom(_),Kind) :- Kind = atomic. -pattern_kind(int(_) ,Kind) :- Kind = atomic. -pattern_kind(atom ,Kind) :- Kind = atomic. -pattern_kind(int ,Kind) :- Kind = atomic. -pattern_kind(atomic ,Kind) :- Kind = atomic. -pattern_kind(functor, Kind) :- Kind = functor. -pattern_kind(functor(_,_),Kind) :- Kind = functor. -pattern_kind(object, Kind) :- Kind = functor. -pattern_kind(object(_), Kind) :- Kind = functor. +ins_pattern( v( Pos0, A, L, F, B, U0 ), Pat, Pos, NewN, Vars0, Vars, T0, T, Ans ) :- + NewN = v( Pos0, A, L, F, B, U ), + ins_pattern( U0, Pat, Pos, U, Vars0, Vars, T0, T, Ans ). + +ins_value_node( list, _, Pos, A, L0, F, B, U, NewN, T0, L, Ans ) :- + NewN = v( Pos, A, L, F, B, U ), + T0 = L0, Ans = normal. +ins_value_node( bound, _, Pos, A, L, F, B0, U, NewN, T0, B, Ans ) :- + NewN = v( Pos, A, L, F, B, U ), + T0 = B0, Ans = normal. +ins_value_node( atomic, X, Pos, A0, L, F, B, U, NewN, T0, T, Ans ) :- + NewN = v( Pos, A, L, F, B, U ), + ins_atomic_node( A0, X, A, T0, T, Ans ). +ins_value_node( functor, X, Pos, A, L, F0, B, U, NewN, T0, T, Ans ) :- + NewN = v( Pos, A, L, F, B, U ), + ins_funct_node( F0, X, F, T0, T, Ans ). +ins_value_node( other, X, Pos, A, L, F, B0, U, NewN, T0, T, Ans ) :- + NewN = v( Pos, A, L, F, B, U ), + ins_eq( B0, Pos, X, B, T0, T, Ans ). + +pattern_kind( list , Kind ) :- Kind = list. +pattern_kind( bound , Kind ) :- Kind = bound. +pattern_kind( atom( _ ) , Kind ) :- Kind = atomic. +pattern_kind( int( _ ) , Kind ) :- Kind = atomic. +pattern_kind( atom , Kind ) :- Kind = atomic. +pattern_kind( int , Kind ) :- Kind = atomic. +pattern_kind( atomic , Kind ) :- Kind = atomic. +pattern_kind( functor , Kind ) :- Kind = functor. +pattern_kind( functor( _, _ ), Kind ) :- Kind = functor. +pattern_kind( object , Kind ) :- Kind = functor. +pattern_kind( object( _ ) , Kind ) :- Kind = functor. otherwise. -pattern_kind(_ , Kind) :- Kind = other. +pattern_kind( _ , Kind ) :- Kind = other. -ins_eq(e, Pos1,Pos2,B1,T0, T,Ans) :- - B1 = v(Pos1,e,e,e,x(eq(Pos1,Pos2),T,e),e), T0 = e, Ans = normal. -ins_eq(v(Pos,A,L,F,B0,U), Pos, Pos1,B1,T0,T,Ans) :- - B1 = v(Pos,A,L,F,B,U), - ins_eq(B0,Pos,Pos1,B,T0,T,Ans). -ins_eq(x(Cond,Node,U0), Pos1,Pos2,B1,T0,T,Ans) :- - B1 = x(Cond,Node,U), - ins_eq(U0,Pos1,Pos2,U,T0,T,Ans). -ins_eq(l(_Body), _Pos1,_Pos2,_Node,_T0,_T,Ans) :- - ins_redundant(Ans). +ins_eq( e, Pos1, Pos2, B1, T0, T, Ans ) :- + B1 = v( Pos1, e, e, e, x( eq( Pos1, Pos2 ), T, e ), e ), + T0 = e, Ans = normal. +ins_eq( v( Pos, A, L, F, B0, U ) , Pos , Pos1, B1, T0, T, Ans ) :- + B1 = v( Pos, A, L, F, B, U ), + ins_eq( B0, Pos, Pos1, B, T0, T, Ans ). +ins_eq( x( Cond, Node, U0 ) , Pos1, Pos2, B1, T0, T, Ans ) :- + B1 = x( Cond, Node, U ), + ins_eq( U0, Pos1, Pos2, U, T0, T, Ans ). +ins_eq( l( _Body ) , _Pos1, _Pos2, _Node, _T0, _T, Ans ) :- + ins_redundant( Ans ). otherwise. -ins_eq(v(Pos0,A,L,F,B,U0),Pos1,Pos2,B1,T0,T,Ans) :- - B1 = v(Pos0,A,L,F,B,U), - ins_eq(U0,Pos1,Pos2,U,T0,T,Ans). +ins_eq( v( Pos0, A, L, F, B, U0 ), Pos1, Pos2, B1, T0, T, Ans ) :- + B1 = v( Pos0, A, L, F, B, U ), + ins_eq( U0, Pos1, Pos2, U, T0, T, Ans ). /* Atomic and Functor Cases */ -ins_atomic_node(e,X,A,T0,T,Ans) :- - ins_atomic_node(a([],e,[],e,e),X,A,T0,T,Ans). -ins_atomic_node(a(AC,AN,IC,IN,EC0),atomic,A,T0,EC,Ans) :- - A = a(AC,AN,IC,IN,EC), T0 = EC0, Ans = normal. -ins_atomic_node(a(AC,AN0,IC,IN,EC),atom,A,T0,AN,Ans) :- - A = a(AC,AN,IC,IN,EC), T0 = AN0, Ans = normal. -ins_atomic_node(a(AC,AN,IC,IN0,EC),int,A,T0,IN,Ans) :- - A = a(AC,AN,IC,IN,EC), T0 = IN0, Ans = normal. -ins_atomic_node(a(AC0,AN,IC,IN,EC),atom(A),X,T0,T,Ans) :- - X = a(AC,AN,IC,IN,EC), Ans = normal, - ins_merge_case(AC0,A,AC,T0,T). -ins_atomic_node(a(AC,AN,IC0,IN,EC),int(N),A,T0,T,Ans) :- - A = a(AC,AN,IC,IN,EC), Ans = normal, - ins_merge_case(IC0,N,IC,T0,T). +ins_atomic_node( e, X, A, T0, T, Ans ) :- + ins_atomic_node( a( [], e, [], e, e ), X, A, T0, T, Ans ). +ins_atomic_node( a( AC, AN, IC, IN, EC0 ), atomic, A, T0, EC, Ans ) :- + A = a( AC, AN, IC, IN, EC ), + T0 = EC0, + Ans = normal. +ins_atomic_node( a( AC, AN0, IC, IN, EC ), atom, A, T0, AN, Ans ) :- + A = a( AC, AN, IC, IN, EC ), + T0 = AN0, + Ans = normal. +ins_atomic_node( a( AC, AN, IC, IN0, EC ), int, A, T0, IN, Ans ) :- + A = a( AC, AN, IC, IN, EC ), + T0 = IN0, + Ans = normal. +ins_atomic_node( a( AC0, AN, IC, IN, EC ), atom( A ), X, T0, T, Ans ) :- + X = a( AC, AN, IC, IN, EC ), + Ans = normal, + ins_merge_case( AC0, A, AC, T0, T ). +ins_atomic_node( a( AC, AN, IC0, IN, EC ), int( N ), A, T0, T, Ans ) :- + A = a( AC, AN, IC, IN, EC ), + Ans = normal, + ins_merge_case( IC0, N, IC, T0, T ). otherwise. -ins_atomic_node(_,_,_,_,_,Ans) :- Ans = abnormal. +ins_atomic_node( _, _, _, _, _, Ans ) :- + Ans = abnormal. -ins_funct_node(e,X,F,T0,T,Ans) :- - ins_funct_node(f([],e,e),X,F,T0,T,Ans). -ins_funct_node(f(FC,FO,FN0),functor,F,T0,FN,Ans) :- - T0 = FN0, F = f(FC,FO,FN), Ans = normal. -ins_funct_node(f(FC0,FO,FN),functor(F,A),X,T0,T,Ans) :- - X = f(FC,FO,FN), Ans = normal, - ins_merge_case(FC0,F/A,FC,T0,T). -ins_funct_node(f(FC,e,FN),object,F,T0,FO,Ans) :- - T0 = e, F = f(FC,o([],FO),FN), Ans = normal. -ins_funct_node(f(FC,e,FN),object(Class),F,FO0,FO,Ans) :- - F = f(FC,o(O,e),FN), Ans = normal, - ins_merge_case([],Class,O,FO0,FO). -ins_funct_node(f(FC,o(O,FO0),FN),object,F,T0,FO,Ans) :- - T0 = FO0, F = f(FC,o(O,FO),FN), Ans = normal. -ins_funct_node(f(FC,o(O0,U),FN),object(Class),F,FO0,FO,Ans) :- - F = f(FC,o(O,U),FN), Ans = normal, - ins_merge_case(O0,Class,O,FO0,FO). +ins_funct_node( e, X, F, T0, T, Ans ) :- + ins_funct_node( f( [], e, e ), X, F, T0, T, Ans ). +ins_funct_node( f( FC, FO, FN0 ), functor, F, T0, FN, Ans ) :- + T0 = FN0, + F = f( FC, FO, FN ), + Ans = normal. +ins_funct_node( f( FC0, FO, FN ), functor( F, A ), X, T0, T, Ans ) :- + X = f( FC, FO, FN ), + Ans = normal, + ins_merge_case( FC0, F/A, FC, T0, T ). +ins_funct_node( f( FC, e, FN ), object, F, T0, FO, Ans ) :- + T0 = e, + F = f( FC, o( [], FO ), FN ), + Ans = normal. +ins_funct_node( f( FC, e, FN ), object( Class ), F, FO0, FO, Ans ) :- + F = f( FC, o( O, e ), FN ), + Ans = normal, + ins_merge_case( [], Class, O, FO0, FO ). +ins_funct_node( f( FC, o( O, FO0 ), FN ), object, F, T0, FO, Ans ) :- + T0 = FO0, + F = f( FC, o( O, FO ), FN ), + Ans = normal. +ins_funct_node( f( FC, o( O0, U ), FN ), object( Class ), F, FO0, FO, Ans ) :- + F = f( FC, o( O, U ), FN ), + Ans = normal, + ins_merge_case( O0, Class, O, FO0, FO ). otherwise. -ins_funct_node(_, _, _,_,_,Ans) :- Ans = abnormal. +ins_funct_node( _, _, _, _, _, Ans ) :- + Ans = abnormal. -ins_merge_case([], V,O,T0,T) :- O = [V-T], T0 = e. -ins_merge_case([V-T0|Rest],V,O,T1,T) :- O = [V-T|Rest], T1 = T0. +ins_merge_case( [] , V, O, T0, T ) :- + O = [V-T], + T0 = e. +ins_merge_case( [V-T0 | Rest], V, O, T1, T ) :- + O = [V-T | Rest], + T1 = T0. otherwise. -ins_merge_case([V0-X|Rest],V,O,T0,T) :- O = [V0-X|Tail], - ins_merge_case(Rest,V,Tail,T0,T). +ins_merge_case( [V0-X | Rest], V, O, T0, T ) :- + O = [V0-X | Tail], + ins_merge_case( Rest, V, Tail, T0, T ). /* Guard Builtin */ -ins_gb(e, GB,TT,T0,T,Ans) :- - TT = x(GB,T,e), T0 = e, Ans = normal. -ins_gb(v(Pos,A,L,F,B,U0),GB,TT,T0,T,Ans) :- - TT = v(Pos,A,L,F,B,U), - ins_gb(U0,GB,U,T0,T,Ans). -ins_gb(x(GB,T00,U), GB,TT,T0,T,Ans) :- - T0 = T00, TT = x(GB,T,U), Ans = normal. -ins_gb(l(_Body), _GB,_T,_T1,_T2,Ans) :- - ins_redundant(Ans). +ins_gb( e , GB, TT, T0, T, Ans ) :- + TT = x( GB, T, e ), + T0 = e, + Ans = normal. +ins_gb( v( Pos, A, L, F, B, U0 ), GB, TT, T0, T, Ans ) :- + TT = v( Pos, A, L, F, B, U ), + ins_gb( U0, GB, U, T0, T, Ans ). +ins_gb( x( GB, T00, U ) , GB, TT, T0, T, Ans ) :- + T0 = T00, + TT = x( GB, T, U ), + Ans = normal. +ins_gb( l( _Body ) , _GB, _T, _T1, _T2, Ans ) :- + ins_redundant( Ans ). otherwise. -ins_gb(x(Cond,Node,U0), GB,TT,T0,T,Ans) :- - TT = x(Cond,Node,U), - ins_gb(U0,GB,U,T0,T,Ans). +ins_gb( x( Cond, Node, U0 ) , GB, TT, T0, T, Ans ) :- + TT = x( Cond, Node, U ), + ins_gb( U0, GB, U, T0, T, Ans ). /* Type Information Handling */ -subsumed(Pattern,Pos,Vars,Ans) :- - subsumed_type(Pos,Pattern,Ans0), - subsumed_1(Pattern,Pos,Vars,Ans0,Ans). - -subsumed_1(Pattern,Pos,Vars,normal, Ans) :- Ans = normal. -subsumed_1(Pattern,Pos,Vars,abnormal,Ans) :- - klic_comp_util:assoc(Vars,Pos,Ans0), - subsumed_2(Ans0,Pattern,Ans). - -subsumed_2(yes(Position),Pattern,Ans) :- - subsumed_type(Position,Pattern,Ans). -subsumed_2(no,_,Ans) :- Ans=abnormal. - -subsumed_type(Type, Type,Ans) :- Ans = normal. -subsumed_type( _, any ,Ans) :- Ans = normal. -subsumed_type(atom(_), X ,Ans) :- subsumed_type(atom,X,Ans). -subsumed_type(int(_), X ,Ans) :- subsumed_type(int, X,Ans). -subsumed_type(float(_), X ,Ans) :- subsumed_type(float, X,Ans). -subsumed_type(list(_), X ,Ans) :- subsumed_type(list,X,Ans). -subsumed_type(functor(_), X ,Ans) :- subsumed_type(functor,X,Ans). -subsumed_type(functor(_,_),X ,Ans) :- subsumed_type(functor,X,Ans). -subsumed_type(string(_), X ,Ans) :- subsumed_type(string,X,Ans). -subsumed_type(vector(_), X ,Ans) :- subsumed_type(vector,X,Ans). -subsumed_type(atom, atomic,Ans) :- Ans = normal. -subsumed_type(atom, bound ,Ans) :- Ans = normal. -subsumed_type(int, atomic,Ans) :- Ans = normal. -subsumed_type(int, bound ,Ans) :- Ans = normal. -subsumed_type(float, bound ,Ans) :- Ans = normal. -subsumed_type(atomic, bound ,Ans) :- Ans = normal. -subsumed_type(functor, bound ,Ans) :- Ans = normal. -subsumed_type(string, bound ,Ans) :- Ans = normal. -subsumed_type(vector, bound ,Ans) :- Ans = normal. -subsumed_type(float, object,Ans) :- Ans = normal. -subsumed_type(string, object,Ans) :- Ans = normal. -subsumed_type(vector, object,Ans) :- Ans = normal. +subsumed( Pattern, Pos, Vars, Ans ) :- + subsumed_type( Pos, Pattern, Ans0 ), + subsumed_1( Pattern, Pos, Vars, Ans0, Ans ). + +subsumed_1( Pattern, Pos, Vars, normal, Ans ) :- + Ans = normal. +subsumed_1( Pattern, Pos, Vars, abnormal, Ans ) :- + klic_comp_util:assoc( Vars, Pos, Ans0 ), + subsumed_2( Ans0, Pattern, Ans ). + +subsumed_2( yes( Position ), Pattern, Ans ) :- + subsumed_type( Position, Pattern, Ans ). +subsumed_2( no, _, Ans ) :- + Ans = abnormal. + +subsumed_type( Type, Type, Ans ) :- Ans = normal. +subsumed_type( _, any, Ans ) :- Ans = normal. +subsumed_type( atom( _ ), X, Ans ) :- subsumed_type( atom , X, Ans ). +subsumed_type( int( _ ), X, Ans ) :- subsumed_type( int , X, Ans ). +subsumed_type( float( _ ), X, Ans ) :- subsumed_type( float , X, Ans ). +subsumed_type( list( _ ), X, Ans ) :- subsumed_type( list , X, Ans ). +subsumed_type( functor( _ ), X, Ans ) :- subsumed_type( functor, X, Ans ). +subsumed_type( functor( _, _ ), X, Ans ) :- subsumed_type( functor, X, Ans ). +subsumed_type( string( _ ), X, Ans ) :- subsumed_type( string , X, Ans ). +subsumed_type( vector( _ ), X, Ans ) :- subsumed_type( vector , X, Ans ). +subsumed_type( atom, atomic, Ans ) :- Ans = normal. +subsumed_type( atom, bound , Ans ) :- Ans = normal. +subsumed_type( int, atomic, Ans ) :- Ans = normal. +subsumed_type( int, bound , Ans ) :- Ans = normal. +subsumed_type( float, bound , Ans ) :- Ans = normal. +subsumed_type( atomic, bound , Ans ) :- Ans = normal. +subsumed_type( functor, bound , Ans ) :- Ans = normal. +subsumed_type( string, bound , Ans ) :- Ans = normal. +subsumed_type( vector, bound , Ans ) :- Ans = normal. +subsumed_type( float, object, Ans ) :- Ans = normal. +subsumed_type( string, object, Ans ) :- Ans = normal. +subsumed_type( vector, object, Ans ) :- Ans = normal. otherwise. -subsumed_type( _, _,Ans) :- Ans = abnormal. +subsumed_type( _, _, Ans ) :- Ans = abnormal. /* Warning */ -ins_redundant(Ans) :- - klic_comp_message:warning("Redundant clause", []), - Ans=abnormal. +ins_redundant( Ans ) :- + klic_comp_message:warning( "Redundant clause", [] ), + Ans = abnormal. diff -ruN klic-3.003-2002-01-22/compiler/kl1cmp.kl1 klic-3.003-2002-01-23/compiler/kl1cmp.kl1 --- klic-3.003-2002-01-22/compiler/kl1cmp.kl1 Mon Jan 21 20:57:00 2002 +++ klic-3.003-2002-01-23/compiler/kl1cmp.kl1 Wed Jan 23 12:51:57 2002 @@ -1,304 +1,319 @@ -% /* ---------------------------------------------------------- -% % (C)1993,1995 Institute for New Generation Computer Technology -% % (Read COPYRIGHT for detailed information.) +/* ---------------------------------------------------------- +% (C)1993,1995 Institute for New Generation Computer Technology +% (Read COPYRIGHT for detailed information.) % (C)1996, 1997, 1998, 1999 Japan Information Processing Development Center % (Read COPYRIGHT-JIPDEC for detailed information.) % ----------------------------------------------------------- */ -% + % referring modules. -% klic_utility, +% klic_utility, % klic_comp_util, klic_comp_version, klic_comp_obj, % klic_comp_macro, klic_comp_normalize, klic_comp_write, % klic_comp_message :- module klic_comp_kl1cmp. +:- public klcmp/2. % called in main.kl1 + % -------------------------------------- -% When the compilation of Infile programs, +% When the compilation of Infile programs, % 'normal' will be returned to 'Report'. -% %%% 1. Check the input file name is "xxx.kl1" or not! -klcmp(InFile,Report) :- string(InFile,FL,_) | - FL1 := FL - 1, - generic:search_character(InFile,FL1,1,#".",Split), - ( Split>0 -> generic:split(InFile,Split,Name,Ext) - ; Split=<0 -> Name=InFile, Ext="" ), - klcmp1(InFile,Name,Ext,Report). +klcmp( InFile, Report ) :- string( InFile, FL, _ ) | + FL1 := FL - 1, + generic:search_character( InFile, FL1, 1, #".", Split ), + ( Split > 0 -> generic:split( InFile, Split, Name, Ext ) + ; Split =< 0 -> Name=InFile, Ext="" ), + klcmp1( InFile, Name, Ext, Report ). otherwise. -klcmp(InFile,Report) :- Report = abnormal(inputfile,InFile). +klcmp( InFile, Report ) :- + Report = abnormal( inputfile, InFile ). % If the extention of the input file is ".kl1", then ... -klcmp1(InFile,Name,".kl1",Report) :- - generic:join(Name,".c",OutFile), - generic:join(Name,".ext",HdrFile), - compile(InFile,OutFile,HdrFile,Report). +klcmp1( InFile, Name, ".kl1", Report ) :- + generic:join( Name, ".c", OutFile ), + generic:join( Name, ".ext", HdrFile ), + compile( InFile, OutFile, HdrFile, Report ). otherwise. -klcmp1(InFile,_,_,Report) :- - Report = abnormal(inputfile,InFile), - klic_comp_message:report_error( - "File name extension of ~s is not kl1\n",[InFile]). - -%%% 2. Open Files -compile(InFile,OutFile,HdrFile,Report) :- - klic_comp_message:see(InFile,In), - klic_comp_message:tell(OutFile,Out), - klic_comp_message:tell(HdrFile,HdrOut), - compile1(In,Out,HdrOut,Report). +klcmp1( InFile, _, _, Report ) :- + Report = abnormal( inputfile, InFile ), + klic_comp_message:report_error( + "File name extension of ~s is not kl1\n", [InFile] ). + +%%% 2. Open Files +compile( InFile, OutFile, HdrFile, Report ) :- + klic_comp_message:see( InFile, In ), + klic_comp_message:tell( OutFile, Out ), + klic_comp_message:tell( HdrFile, HdrOut ), + compile1( In, Out, HdrOut, Report ). -%%% see and tell was moved to message.kl1\ +%%% see and tell was moved to message.kl1 %%% 3. Read programs -compile1(normal(In),normal(Out),normal(HdrOut),Report) :- -% constant macro pool - keyed_set:create(Pool), - read_in(ReadResult)+In+[]+Pool+[], - compile2(ReadResult,Report)+Out+[]+HdrOut+[]. +compile1( normal( In ), normal( Out ), normal( HdrOut ), Report ) :- + % constant macro pool + keyed_set:create( Pool ), + read_in( ReadResult )+In+[]+Pool+[], + compile2( ReadResult, Report )+Out+[]+HdrOut+[]. otherwise. -compile1(_In,_Out,_HdrOut,Report) :- - close_streams([_In,_Out,_HdrOut]), - Report = abnormal(fileopen,(_In,_Out,_HdrOut)). - - close_streams([]). - close_streams([normal(S)|L]) :- S = [], close_streams(L). - otherwise. - close_streams([_|L]) :- close_streams(L). - -read_in(Result)-In-CP :- - Result = normal(Terms,Inline), - In <= getwt(Term), - read_inline(Term,Inline,Terms)-In-CP. - - %%%%% 3.1 (:- inline xxxx) - read_inline(normal(functor((:- functor(atom(inline):X)))), - Inline,Terms)-In-CP :- - Inline=[X|Rest], - In <= getwt(More), - read_inline(More,Rest,Terms)-In-CP. - otherwise. - read_inline(normal(X),Inline,Terms)-In-CP :- - Inline = [], - read_all(X,Terms)-In-CP. - otherwise. - read_inline(X,Inline,Terms)-In-CP :- - handle_exception(X). - - - %%%%% 3.2 (:- module xxxx) Check! - read_all(end_of_file, Tail )-In-CP :- Tail = []. - read_all(empty, Tail )-In-CP :- Tail = []. - read_all(functor((:- functor(module(X)))),Terms)-In-CP :- - read_all_1(X,Terms)-In-CP. - otherwise. - read_all(_,Terms)-In-CP :- - Terms = [], - klic_comp_message:report_error("Module declaration is not found", []). - - read_all_1(atom(X),Terms)-In-CP :- - Terms = [module(X,One)|Tail], - In <= getwt(More), - read_one_module(More,One,Next)-In-CP, - read_all(Next,Tail)-In-CP. - otherwise. - read_all_1(X,Terms)-In-CP :- - Terms = [], - klic_comp_message:report_error("Module name is not an atom :~w", [X]). +compile1( _In, _Out, _HdrOut, Report ) :- + close_streams( [_In, _Out, _HdrOut] ), + Report = abnormal( fileopen, ( _In, _Out, _HdrOut )). + + close_streams( [] ). + close_streams( [normal( S )|L] ) :- + S = [], + close_streams( L ). + otherwise. + close_streams( [_|L] ) :- + close_streams( L ). + +read_in( Result )-In-CP :- + Result = normal( Terms, Inline ), + In <= getwt( Term ), + read_inline( Term, Inline, Terms )-In-CP. + + %%%%% 3.1 ( :- inline xxxx ) + read_inline( normal( functor( :-( functor( atom( inline ): X )))), + Inline, Terms )-In-CP :- + Inline = [X | Rest], + In <= getwt( More ), + read_inline( More, Rest, Terms )-In-CP. + otherwise. + read_inline( normal( X ), Inline, Terms )-In-CP :- + Inline = [], + read_all( X, Terms )-In-CP. + otherwise. + read_inline( X, Inline, Terms )-In-CP :- + handle_exception( X ). + + + %%%%% 3.2 ( :- module xxxx ) Check! + read_all( end_of_file, Tail )-In-CP :- + Tail = []. + read_all( empty, Tail )-In-CP :- + Tail = []. + read_all( functor( :-( functor( module( X )))), Terms )-In-CP :- + read_all_1( X, Terms )-In-CP. + otherwise. + read_all( _, Terms )-In-CP :- + Terms = [], + klic_comp_message:report_error( "Module declaration is not found", [] ). + + read_all_1( atom( X ), Terms )-In-CP :- + Terms = [module( X, One ) | Tail], + In <= getwt( More ), + read_one_module( More, One, Next )-In-CP, + read_all( Next, Tail )-In-CP. + otherwise. + read_all_1( X, Terms )-In-CP :- + Terms = [], + klic_comp_message:report_error( "Module name is not an atom: ~w", [X] ). %%%%% 3.3 Read module - read_one_module(normal(end_of_file), One,Next)-In-CP :- - One = [], Next = end_of_file. - read_one_module(normal(empty), One,Next)-In-CP:- - One = [], Next = end_of_file. - read_one_module(normal(functor((:- functor(module(atom(X)))))), - One,Next)-In-CP :- - One = [], Next = functor((:- functor(module(atom(X))))). -% constant macro - read_one_module(normal(functor((:- functor(with(Defs))))), - One,Next)-In-CP :- - klic_comp_cmacro:insDefs(Defs)-CP, - In <= getwt(X), - read_one_module(X,One,Next)-In-CP. - otherwise. - read_one_module(normal(functor((:- _))),Tail,Next)-In-CP :- - In <= getwt(X), - read_one_module(X,Tail,Next)-In-CP. - otherwise. - read_one_module(normal(One0),Result,Next)-In-CP :- -% constant macro processing - klic_comp_cmacro:replaceClause(One0, One1)-CP, - klic_comp_macro:macro(One1,One), %%% ------------> macro.kl1 - % 'One' will be returned as - % 1) clause(Head,Guard,Body,Expanded) - % 2) otherwise - % 3) alternatively - % 4) end_of_file - Result = [One|Tail], - In <= getwt(X), - read_one_module(X,Tail,Next)-In-CP. + read_one_module( normal( end_of_file ), One, Next )-In-CP :- + One = [], + Next = end_of_file. + read_one_module( normal( empty ), One, Next )-In-CP:- + One = [], + Next = end_of_file. + read_one_module( normal( functor( :-( functor( module( atom( X )))))), + One, Next )-In-CP :- + One = [], + Next = functor( :-( functor( module( atom( X ))))). + % constant macro + read_one_module( normal( functor( :-( functor( with( Defs ))))), + One, Next )-In-CP :- + klic_comp_cmacro:insDefs( Defs )-CP, + In <= getwt( X ), + read_one_module( X, One, Next )-In-CP. otherwise. - read_one_module(X,Result,Next)-In-CP :- - handle_exception(X). + read_one_module( normal( functor( :-( _ ))), Tail, Next )-In-CP :- + In <= getwt( X ), + read_one_module( X, Tail, Next )-In-CP. + otherwise. + read_one_module( normal( One0 ), Result, Next )-In-CP :- + % constant macro processing + klic_comp_cmacro:replaceClause( One0, One1 )-CP, + klic_comp_macro:macro( One1, One ), %%% ------------> macro.kl1 + % 'One' will be returned as + % 1 ) clause( Head, Guard, Body, Expanded ) + % 2 ) otherwise + % 3 ) alternatively + % 4 ) end_of_file + Result = [One | Tail], + In <= getwt( X ), + read_one_module( X, Tail, Next )-In-CP. + otherwise. + read_one_module( X, Result, Next )-In-CP :- + handle_exception( X ). %%% 4. Write headers -compile2(normal(Modules,Inline),Report)-Out-HdrOut :- - write_file_header -Out, - write_inline_header(Inline) -Out, - Out<= #"\n", - compile_modules(Modules,Report) -Out-HdrOut. +compile2( normal( Modules, Inline ), Report )-Out-HdrOut :- + write_file_header -Out, + write_inline_header( Inline ) -Out, + Out <= #"\n", + compile_modules( Modules, Report ) -Out-HdrOut. %%%%% 4.1 Write File Header write_file_header-Out :- - klic_comp_version:compiler_version(Version), % version.kl1 - klic_comp_version:compiler_date(Date), % - klic_comp_obj:klicformat( - "/* Compiled by KLIC compiler ~w (~w) */\n\n" - "#include \n" - "#include \"atom.h\"\n" - "#include \"funct.h\"\n", - [Version,Date])-Out. + klic_comp_version:compiler_version( Version ), % version.kl1 + klic_comp_version:compiler_date( Date ), % + klic_comp_obj:klicformat( + "/* Compiled by KLIC compiler ~w ( ~w ) */\n\n" + "#include \n" + "#include \"atom.h\"\n" + "#include \"funct.h\"\n", + [Version, Date] )-Out. %%%%% 4.2 Write Inline Header - write_inline_header([])-Out. - write_inline_header([String|Rest])-Out :- - klic_comp_obj:write_inline(String,[],[],[])-Out, - write_inline_header(Rest)-Out. - -%%% 5. Compile modules (Analyze) -compile_modules([],Report)+Out0+Out+HOut0+HOut :- - klic_comp_obj:flush(Status0,Out0,Out), - klic_comp_obj:flush(Status1,HOut0,HOut), - wait_output_end(Status0,Status1,Report). -compile_modules([One|Rest],Report)+Out0+Out+HOut0+HOut :- - analyze(One,Module), - klic_comp_write:write_out(Module,Out0,Out1), % write.kl1 - klic_comp_write:write_header_file(Module,HOut0,HOut1), % - compile_modules(Rest,Report)+Out1+Out+HOut1+HOut. + write_inline_header( [] )-Out. + write_inline_header( [String|Rest] )-Out :- + klic_comp_obj:write_inline( String, [], [], [] )-Out, + write_inline_header( Rest )-Out. + +%%% 5. Compile modules ( Analyze ) +compile_modules( [], Report )+Out0+Out+HOut0+HOut :- + klic_comp_obj:flush( Status0, Out0, Out ), + klic_comp_obj:flush( Status1, HOut0, HOut ), + wait_output_end( Status0, Status1, Report ). +compile_modules( [One|Rest], Report )+Out0+Out+HOut0+HOut :- + analyze( One, Module ), + klic_comp_write:write_out( Module, Out0, Out1 ), % write.kl1 + klic_comp_write:write_header_file( Module, HOut0, HOut1 ), % + compile_modules( Rest, Report )+Out1+Out+HOut1+HOut. -%wait_output_end(normal,normal,Report) :- Report = normal. -wait_output_end(0,0,Report) :- Report = normal. +wait_output_end( 0, 0, Report ) :- Report = normal. otherwise. -wait_output_end(X,Y,Report) :- Report = abnormal(fileoutput,(X,Y)). +wait_output_end( X, Y, Report ) :- Report = abnormal( fileoutput, (X, Y) ). -analyze(module(Name,Module),Result) :- - Result = module(Name,Predicates,Ex), - % pool:keyed_set([empty(A)|Pool]), - keyed_sorted_set:create([empty(A)|Pool]), - analyze1(Module,Name,Predicates,Ex,A,Pool). +analyze( module( Name, Module ), Result ) :- + Result = module( Name, Predicates, Ex ), + keyed_sorted_set:create( [empty( A ) | Pool] ), + analyze1( Module, Name, Predicates, Ex, A, Pool ). otherwise. -analyze(_,_Result) :- - klic_comp_message:report_error("Internal error in analyze ",[]). +analyze( _, _Result ) :- + klic_comp_message:report_error( "Internal error in analyze ", [] ). -analyze1(Module,Name,Predicates,Ex,yes,Pool) :- - Pool = [put(compiling_module,Name,_)|Pool1], - analyze_preds(Module,0,Predicates,Ex,[],Pool1). +analyze1( Module, Name, Predicates, Ex, yes, Pool ) :- + Pool = [put( compiling_module, Name, _ ) | Pool1], + analyze_preds( Module, 0, Predicates, Ex, [], Pool1 ). otherwise. -analyze1(_Module,_Name,_Predicates,_Ex,_,Pool) :- - Pool=[], - klic_comp_message:report_error("Internal error in analyze1 ",[]). +analyze1( _Module, _Name, _Predicates, _Ex, _, Pool ) :- + Pool = [], + klic_comp_message:report_error( "Internal error in analyze1 ", [] ). %%%%% 5.1 Analyze predicates - analyze_preds([],_,Predicates,Ex0,Ex,Pool) :- - Predicates = [], Ex = Ex0, Pool = []. - analyze_preds([clause(Head,Guard,Body,Exp0)|Rest0], - Seq0,Predicates,Ex0,Ex, Pool) :- - get_clause_name(Head,Name,Arity), - Pool = [put(compiling_predicate,Name/Arity,_)|Pool1], - - Predicates = [pred(Name,Arity,Seq0,Works,Object)|OtherPreds], - Clauses = [clause(Name/Arity/0,Head,Guard,Body)|OtherClauses], - % a) Collect same predicate clauses - collect_same(Rest0,Rest1,Name,Arity,1,OtherClauses,Exp0,Exp), - klic_comp_util:name(Name,NameS), - klic_comp_util:name(Arity,ArityS), - klic_comp_util:append(NameS,[#"/"|ArityS],Prefix), - % b) Rename macro expansion - rename_macro_preds(Exp,Prefix,0,Rest1,Rest), - % c) Generate => normalize.kl1 - klic_comp_normalize:generate((Name/Arity),Clauses, - Works,Exx,[],Object,Pool1,Pool2), - - klic_comp_util:remove(Exx,exec(Name/Arity),Ex0,Ex1), - Seq1 := Seq0+1, - analyze_preds(Rest,Seq1,OtherPreds,Ex1,Ex,Pool2). - - get_clause_name(functor(Head),Name,Arity) :- functor(Head,N,A) | - Name = N, Arity = A. - get_clause_name(atom(Head),Name,Arity) :- - Name = Head, Arity = 0. - - %%%%%%% a) Collect same clauses - collect_same([Clause|Rest0],Rest,Name,Arity,K, - Clauses,Exp0,Exp) :- - Clause = clause(Head,Guard,Body,Exp1) | - get_clause_name(Head,Name0,Arity0), - collect_same_1([Clause|Rest0],Rest,Name,Arity,K,Clauses,Exp0,Exp, - Name0,Arity0). - collect_same([otherwise|Rest0],Rest,Name,Arity,K, - Clauses,Exp0,Exp) :- - Clauses = [otherwise|OtherClauses], - collect_same(Rest0,Rest,Name,Arity,K,OtherClauses,Exp0,Exp). - collect_same([alternatively|Rest0],Rest,Name,Arity,K, - Clauses,Exp0,Exp) :- - Clauses = [alternatively|OtherClauses], - collect_same(Rest0,Rest,Name,Arity,K,OtherClauses,Exp0,Exp). - otherwise. - collect_same(Rest,RestT,_Name,_Arity,_K,Clauses,Exp0,Exp) :- - RestT = Rest, Clauses = [], Exp = Exp0. - - collect_same_1([clause(Head,Guard,Body,Exp1)|Rest0],Rest,Name,Arity, - K,Clauses,Exp0,Exp,Name,Arity) :- - Clauses = [clause(Name/Arity/K,Head,Guard,Body)|OtherClauses], - K1 := K+1, - klic_comp_util:append(Exp1,Exp0,Exp2), - collect_same(Rest0,Rest,Name,Arity,K1,OtherClauses,Exp2,Exp). - otherwise. - collect_same_1(Rest,RestT,_Name,_Arity,_K,Clauses,Exp0,Exp,_,_) :- - RestT = Rest, Clauses = [], Exp = Exp0. - - %%%%%%% b) Rename Macro Expansion - rename_macro_preds([],_,_,Rest0,Rest) :- Rest = Rest0. - rename_macro_preds([expanded(OR,NewName)|Exp],Prefix,K,Rest0,Rest) :- - klic_comp_util:name(K,KS), - klic_comp_util:append(Prefix,[#"$"|KS],NewNameS), - klic_comp_util:make_atom(NewNameS,NewName), - rename_macro_clauses(OR,Rest1,Rest0), - K1 := K+1, - rename_macro_preds(Exp,Prefix,K1,Rest1,Rest). - - rename_macro_clauses([],Rest,Rest0) :- Rest = Rest0. - rename_macro_clauses([otherwise|T],Rest1,Rest) :- - Rest1 = [otherwise|Rest0], - rename_macro_clauses(T,Rest0,Rest). - rename_macro_clauses([alternatively|T],Rest1,Rest) :- - Rest1 = [alternatively|Rest0], - rename_macro_clauses(T,Rest0,Rest). - rename_macro_clauses([clause(H0,G,B,Exp)|T],Rest1,Rest) :- - Rest1 = [clause(H,G,B,Exp)|Rest0], - shift_vector(H0,H), - rename_macro_clauses(T,Rest0,Rest). - - % H0=..[_,NewName|Args], H=..[NewName|Args], - shift_vector(H0,H) :- functor(H0,_,A) | - A1 := A - 1, - shift_vector(A1,H0,H). - shift_vector(A1,H0,H) :- A1 > 0, - arg(1,H0,F) | - functor_table:new_functor(H1,F,A1), - shift_vector(1,A1,H0,H1,H). - shift_vector(A1,H0,H) :- A1 =:= 0, - arg(1,H0,F) | - H = atom(F). - - shift_vector(P,A1,H0,H1,H) :- A1 >= P, - Pm1 := P-1, - Pp1 := P+1, - arg(Pp1,H0,X) | - functor_table:setarg(P,H1,_,X,H2), - shift_vector(Pp1,A1,H0,H2,H). + analyze_preds( [], _, Predicates, Ex0, Ex, Pool ) :- + Predicates = [], + Ex = Ex0, + Pool = []. + analyze_preds( [clause( Head, Guard, Body, Exp0 ) | Rest0], + Seq0, Predicates, Ex0, Ex, Pool ) :- + get_clause_name( Head, Name, Arity ), + Pool = [put( compiling_predicate, Name/Arity, _ ) | Pool1], + + Predicates = [pred( Name, Arity, Seq0, Works, Object ) | OtherPreds], + Clauses = [clause( Name/Arity/0, Head, Guard, Body ) | OtherClauses], + + % a ) Collect same predicate clauses + collect_same( Rest0, Rest1, Name, Arity, 1, OtherClauses, Exp0, Exp ), + klic_comp_util:name( Name, NameS ), + klic_comp_util:name( Arity, ArityS ), + klic_comp_util:append( NameS, [#"/"|ArityS], Prefix ), + + % b ) Rename macro expansion + rename_macro_preds( Exp, Prefix, 0, Rest1, Rest ), + + % c ) Generate => normalize.kl1 + klic_comp_normalize:generate( (Name/Arity), Clauses, + Works, Exx, [], Object, Pool1, Pool2 ), + + klic_comp_util:remove( Exx, exec( Name/Arity ), Ex0, Ex1 ), + Seq1 := Seq0 + 1, + analyze_preds( Rest, Seq1, OtherPreds, Ex1, Ex, Pool2 ). + + get_clause_name( functor( Head ), Name, Arity ) :- functor( Head, N, A ) | + Name = N , Arity = A. + get_clause_name( atom( Head ), Name, Arity ) :- + Name = Head, Arity = 0. + + %%%%%%% a ) Collect same clauses + collect_same( [Clause | Rest0], Rest, Name, Arity, K, + Clauses, Exp0, Exp ) :- + Clause = clause( Head, Guard, Body, Exp1 ) | + get_clause_name( Head, Name0, Arity0 ), + collect_same_1( [Clause | Rest0], Rest, Name, Arity, K, Clauses, Exp0, Exp, + Name0, Arity0 ). + collect_same( [otherwise | Rest0], Rest, Name, Arity, K, + Clauses, Exp0, Exp ) :- + Clauses = [otherwise | OtherClauses], + collect_same( Rest0, Rest, Name, Arity, K, OtherClauses, Exp0, Exp ). + collect_same( [alternatively | Rest0], Rest, Name, Arity, K, + Clauses, Exp0, Exp ) :- + Clauses = [alternatively | OtherClauses], + collect_same( Rest0, Rest, Name, Arity, K, OtherClauses, Exp0, Exp ). + otherwise. + collect_same( Rest, RestT, _Name, _Arity, _K, Clauses, Exp0, Exp ) :- + RestT = Rest, + Clauses = [], + Exp = Exp0. + + collect_same_1( [clause( Head, Guard, Body, Exp1 )|Rest0], Rest, Name, Arity, + K, Clauses, Exp0, Exp, Name, Arity ) :- + Clauses = [clause( Name/Arity/K, Head, Guard, Body ) | OtherClauses], + K1 := K+1, + klic_comp_util:append( Exp1, Exp0, Exp2 ), + collect_same( Rest0, Rest, Name, Arity, K1, OtherClauses, Exp2, Exp ). + otherwise. + collect_same_1( Rest, RestT, _Name, _Arity, _K, Clauses, Exp0, Exp, _, _ ) :- + RestT = Rest, + Clauses = [], + Exp = Exp0. + + %%%%%%% b ) Rename Macro Expansion + rename_macro_preds( [], _, _, Rest0, Rest ) :- + Rest = Rest0. + rename_macro_preds( [expanded( OR, NewName ) | Exp], Prefix, K, Rest0, Rest ) :- + klic_comp_util:name( K, KS ), + klic_comp_util:append( Prefix, [#"$" | KS], NewNameS ), + klic_comp_util:make_atom( NewNameS, NewName ), + rename_macro_clauses( OR, Rest1, Rest0 ), + K1 := K+1, + rename_macro_preds( Exp, Prefix, K1, Rest1, Rest ). + + rename_macro_clauses( [], Rest, Rest0 ) :- + Rest = Rest0. + rename_macro_clauses( [otherwise|T], Rest1, Rest ) :- + Rest1 = [otherwise | Rest0], + rename_macro_clauses( T, Rest0, Rest ). + rename_macro_clauses( [alternatively|T], Rest1, Rest ) :- + Rest1 = [alternatively | Rest0], + rename_macro_clauses( T, Rest0, Rest ). + rename_macro_clauses( [clause( H0, G, B, Exp )|T], Rest1, Rest ) :- + Rest1 = [clause( H, G, B, Exp ) | Rest0], + shift_vector( H0, H ), + rename_macro_clauses( T, Rest0, Rest ). + + % H0 =.. [_, NewName|Args], H =.. [NewName|Args], + shift_vector( H0, H ) :- functor( H0, _, A ) | + A1 := A - 1, + shift_vector( A1, H0, H ). + shift_vector( A1, H0, H ) :- A1 > 0, arg( 1, H0, F ) | + functor_table:new_functor( H1, F, A1 ), + shift_vector( 1, A1, H0, H1, H ). + shift_vector( A1, H0, H ) :- A1 =:= 0, arg( 1, H0, F ) | + H = atom( F ). + + shift_vector( P, A1, H0, H1, H ) :- A1 >= P, Pp1 := P+1, arg( Pp1, H0, X ) | + functor_table:setarg( P, H1, _, X, H2 ), + shift_vector( Pp1, A1, H0, H2, H ). otherwise. - shift_vector(_P,_A1,_H0,H1,H) :- H = functor(H1). + shift_vector( _P, _A1, _H0, H1, H ) :- + H = functor( H1 ). %%%%%%% OTHER ROUTINE @@ -306,86 +321,95 @@ % report_error, warning was moved to error.kl1 % ------ HANDLE EXCEPTION ----- -% handle_exception(syntax_error(_,between(_,_),Msg,Tokens,After)) :- -% tell(user_error,Out), -% klic_comp_obj:klicformat("Syntax error: ",[], Out, Out1), -% complain_words(Msg) +Out1+Out2, -% klic_comp_obj:nl( Out2,Out3), -% klic_comp_util:length(Tokens,Len), -% Pos := Len-After, -% complain_tokens(0,Pos,Tokens, Rest) +Out3+Out4, -% klic_comp_obj:klicformat("\n*** Here ***\n",[], Out4,Out5), -% complain_tokens(Rest) +Out5+Out6, -% klic_comp_obj:nl( Out6,[]), -% compilation_error. +% handle_exception( syntax_error( _, between( _, _ ), Msg, Tokens, After )) :- +% tell( user_error, Out ), +% klic_comp_obj:klicformat( "Syntax error: ", [], Out , Out1 ), +% complain_words( Msg ) +Out1 +Out2, +% klic_comp_obj:nl( Out2, Out3 ), +% klic_comp_util:length( Tokens, Len ), +% Pos := Len-After, +% complain_tokens( 0, Pos, Tokens, Rest ) +Out3 +Out4, +% klic_comp_obj:klicformat( "\n*** Here ***\n", [], Out4, Out5 ), +% complain_tokens( Rest ) +Out5 +Out6, +% klic_comp_obj:nl( Out6, [] ), +% compilation_error. % temporary ? -%% I found the interface was 'abnormal(error({TL,Ps}))' in the PIMOS manual, +%% I found the interface was 'abnormal( error( {TL, Ps} ))' in the PIMOS manual, %% but the parser gave like the following argument. -handle_exception(abnormal(error(Ps,TL))) :- - handle_exception(Ps,TL,[]). -handle_exception(abnormal(ambiguous(Ps,TL))) :- - handle_exception(Ps,TL,[ambiguous,token,was,found]). -handle_exception(abnormal(error({TL,Reason,Ps}))) :- - klic_comp_message:tell(user_error,Out), - klic_comp_obj:klicformat("!! Error !!\nTL = ~w\nReason = ~wPs = \n", - [TL,Reason,Ps])-Out, - klic_comp_obj:flush(Status)-Out, - Out=[], - klic_comp_message:compilation_error(Status). +handle_exception( abnormal( error( Ps, TL ))) :- + handle_exception( Ps, TL, [] ). +handle_exception( abnormal( ambiguous( Ps, TL ))) :- + handle_exception( Ps, TL, [ambiguous, token, was, found] ). +handle_exception( abnormal( error( {TL, Reason, Ps} ))) :- + klic_comp_message:tell( user_error, Out ), + klic_comp_obj:klicformat( "!! Error !!\nTL = ~w\nReason = ~wPs = \n", + [TL, Reason, Ps] )-Out, + klic_comp_obj:flush( Status )-Out, + Out = [], + klic_comp_message:compilation_error( Status ). otherwise. -handle_exception(Exception) :- - klic_comp_message:tell(user_error,Out), - klic_comp_obj:klicformat("~w\n",[Exception], Out, Out1), - klic_comp_obj:flush(Status, Out1,[]), - klic_comp_message:compilation_error(Status). - -handle_exception(Ps,TL,Msg) :- - klic_comp_message:tell(user_error,Out), - klic_comp_obj:klicformat("Syntax error: ")-Out, - complain_words(Msg)-Out, - Out <= #"\n", - complain_tokens(0,Ps,TL,Rest)-Out, - klic_comp_obj:klicformat("\n*** Here ***\n")-Out, - complain_tokens(Rest)-Out, - Out <= #"\n", - klic_comp_obj:flush(Status)-Out, - Out=[], - klic_comp_message:compilation_error(Status). - -complain_tokens(K,K,T,R)+O0+O :- R = T, O = O0. +handle_exception( Exception ) :- + klic_comp_message:tell( user_error, Out ), + klic_comp_obj:klicformat( "~w\n", [Exception], Out, Out1 ), + klic_comp_obj:flush( Status, Out1, [] ), + klic_comp_message:compilation_error( Status ). + +handle_exception( Ps, TL, Msg ) :- + klic_comp_message:tell( user_error, Out ), + klic_comp_obj:klicformat( "Syntax error: " )-Out, + complain_words( Msg )-Out, + Out <= #"\n", + complain_tokens( 0, Ps, TL, Rest )-Out, + klic_comp_obj:klicformat( "\n*** Here ***\n" )-Out, + complain_tokens( Rest )-Out, + Out <= #"\n", + klic_comp_obj:flush( Status )-Out, + Out = [], + klic_comp_message:compilation_error( Status ). + +complain_tokens( K, K, T, R )+O0+O :- + R = T, + O = O0. otherwise. -complain_tokens(K,N,[H|T],R)-O :- - complain_token(H)-O, - K1 := K+1, - complain_tokens(K1,N,T,R)-O. - -complain_tokens([])+O0+O :- O = O0. -complain_tokens([H|T])-O :- - complain_token(H)-O, - complain_tokens(T)-O. - -complain_token(atom(A) )-O :- klic_comp_obj:klicformat("~w",[A])-O. -complain_token(integer(N) )-O :- klic_comp_obj:klicformat("~w",[N])-O. -complain_token(string(S) )-O :- - klic_comp_util:string_to_char_list(S,L), - complain_string(L)-O. -complain_token('$VAR'(_,V))-O :- klic_comp_obj:klicformat("~s",[V])-O. -complain_token(open(F) )-O :- klic_comp_obj:klicformat("~w(",[F])-O. -complain_token(end )-O :- klic_comp_obj:klicformat(".\n")-O. +complain_tokens( K, N, [H|T], R )-O :- + complain_token( H )-O, + K1 := K+1, + complain_tokens( K1, N, T, R )-O. + +complain_tokens( [] )+O0+O :- + O = O0. +complain_tokens( [H|T] )-O :- + complain_token( H )-O, + complain_tokens( T )-O. + +complain_token( atom( A ) )-O :- + klic_comp_obj:klicformat( "~w", [A] )-O. +complain_token( integer( N ) )-O :- + klic_comp_obj:klicformat( "~w", [N] )-O. +complain_token( string( S ) )-O :- + klic_comp_util:string_to_char_list( S, L ), + complain_string( L )-O. +complain_token( '$VAR'( _, V ))-O :- + klic_comp_obj:klicformat( "~s", [V] )-O. +complain_token( open( F ) )-O :- + klic_comp_obj:klicformat( "~w( ", [F] )-O. +complain_token( end )-O :- + klic_comp_obj:klicformat( ".\n" )-O. otherwise. -complain_token(X )-O :- klic_comp_obj:klicformat("~w",[X])-O. +complain_token( X )-O :- + klic_comp_obj:klicformat( "~w", [X] )-O. -complain_string([])-O. -complain_string([#"\""|T])-O :- - klic_comp_obj:klicformat("\\\"")-O, - complain_string(T)-O. +complain_string( [] )-O. +complain_string( [#"\"" | T] )-O :- + klic_comp_obj:klicformat( "\\\"" )-O, + complain_string( T )-O. otherwise. -complain_string([H|T])-O :- - klic_comp_obj:klicformat("~c",[H])-O, - complain_string(T)-O. - -complain_words([])-O. -complain_words([H|T])-O :- - klic_comp_obj:klicformat("~w~c",[H,#" "])-O, - complain_words(T)-O. +complain_string( [H | T] )-O :- + klic_comp_obj:klicformat( "~c", [H] )-O, + complain_string( T )-O. + +complain_words( [] )-O. +complain_words( [H | T] )-O :- + klic_comp_obj:klicformat( "~w~c", [H, #" "] )-O, + complain_words( T )-O. diff -ruN klic-3.003-2002-01-22/compiler/macro.kl1 klic-3.003-2002-01-23/compiler/macro.kl1 --- klic-3.003-2002-01-22/compiler/macro.kl1 Sat Dec 29 12:46:20 2001 +++ klic-3.003-2002-01-23/compiler/macro.kl1 Wed Jan 23 13:42:47 2002 @@ -1,774 +1,824 @@ -/* ---------------------------------------------------------- -% (C)1993,1994,1995 Institute for New Generation Computer Technology -% (Read COPYRIGHT for detailed information.) +/* ---------------------------------------------------------- +% (C)1993,1994,1995 Institute for New Generation Computer Technology +% (Read COPYRIGHT for detailed information.) % (C)1996, 1997, 1998, 1999 Japan Information Processing Development Center % (Read COPYRIGHT-JIPDEC for detailed information.) ----------------------------------------------------------- */ :- module klic_comp_macro. -macro(In, Out) :- macro(In, Out, _). +public macro/2, macro/3. % called in kl1cmp.kl1, macropp.kl1 -macro(atom(otherwise),R,Tbl) :- R=otherwise, Tbl=[]. -macro(atom(alternatively),R,Tbl) :- R=alternatively, Tbl=[]. -macro(functor((H:-B)),Clause,Tbl) :- macro_1(B,Clause,H,Tbl). -otherwise. -macro(H, Clause,Tbl) :- exp_one_clause(H,atom(true),atom(true),Clause,Tbl). - -macro_1(functor('|'(G,B)), Clause, H, Tbl) :- exp_one_clause(H,G,B,Clause,Tbl). -otherwise. -macro_1(B, Clause, H, Tbl) :- exp_one_clause(H,atom(true),B,Clause,Tbl). +macro( In, Out ) :- macro( In, Out, _ ). -exp_one_clause(H0,G0,B0,Clause,TableOut) :- - Clause = clause(NewH,NewG,NewB,Exp), -%% klic_comp_util:numbervars([H0,G0|B0],[H00,G00|B00],0,V00), - klic_comp_util:numbervars([H0,G0|B0],[H00,G00|B00],0,V00,[],VTbl), - dlclause(H00,G00,B00,H,G,B,V00,V0,[]), - countvars([H,G|B],Table), - exp_head(H,NewH,V0,V1,NewG0,G1), - linearize_guard(G,G1,[]), - exp_guard(NewG0,V1,V,NewG,[]), -%% exp_body(B,V,_,Table,Exp,[],NewB,[]). - exp_body(B,V,_,Table,Table0,Exp,[],NewB,[]), - TableOut=VTbl-Table0. +macro( atom( otherwise ), R, Tbl ) :- + R = otherwise , Tbl = []. +macro( atom( alternatively ), R, Tbl ) :- + R = alternatively, Tbl = []. +macro( functor( ( H:-B )), Clause, Tbl ) :- + macro_1( B, Clause, H, Tbl ). +otherwise. +macro( H, Clause, Tbl ) :- + exp_one_clause( H, atom( true ), atom( true ), Clause, Tbl ). + +macro_1( functor( '|'( G, B )), Clause, H, Tbl ) :- + exp_one_clause( H, G, B, Clause, Tbl ). +otherwise. +macro_1( B , Clause, H, Tbl ) :- + exp_one_clause( H, atom( true ), B, Clause, Tbl ). + +exp_one_clause( H0, G0, B0, Clause, TableOut ) :- + Clause = clause( NewH, NewG, NewB, Exp ), + klic_comp_util:numbervars( [H0, G0|B0], [H00, G00|B00], 0, V00, [], VTbl ), + dlclause( H00, G00, B00, H, G, B, V00, V0, [] ), + countvars( [H, G|B], Table ), + exp_head( H, NewH, V0, V1, NewG0, G1 ), + linearize_guard( G, G1, [] ), + exp_guard( NewG0, V1, V, NewG, [] ), + exp_body( B, V, _, Table, Table0, Exp, [], NewB, [] ), + TableOut = VTbl-Table0. % ----- DLCLAUSE ------ % Head Goal must be functor or atom! -dlclause(functor(H0),G0,B0,H,G,B,N0,N,V) :- - dlclause_1(H0,G0,B0,H,G,B,N0,N,V). -dlclause(atom(F),G0,B0,H,G,B,N0,N,V) :- - dlclause_1(F,G0,B0,H,G,B,N0,N,V). -otherwise. -dlclause(H0,G0,B0,H,G,B,N0,N,V) :- - klic_comp_message:report_error("Invalid head: ~w",[H0]). - - % ---------- Extra Arguments are added to the head goal ---------- - % If Head Goal is a functor, then - dlclause_1((H0 - variable(I)),G0,B0,H,G,B,N0,N,V) :- - dlclause(H0,G0,B0,H,G,B,N0,N,[-I|V]). - dlclause_1((H0 + X), G0,B0,H,G,B,N0,N,V) :- - dlclause(H0,G0,B0,H,G,B,N0,N,[+X|V]). - otherwise. - dlclause_1(H0,G0,B0,H,G,B,N0,N,V) :- - initialize_info(V,N0,N1,[],Vinfo1,ExtraArgs,Vars), - klic_comp_util:univ(H0,[F|L],ExtraArgs), - functor_table:(H=..[F|L]), - dlgoals(G0,G,Vars,N1,N2,Vinfo1,Vinfo2), - dlgoals(B0,B1,Vars,N2,N,Vinfo2,Vinfo3), - finalize_vars(Vars,Vinfo3,B1,B). - - % ----- INITIALIZE INFO ----- - initialize_info([])-N-Vinfo+EArgs+Vars :- - EArgs = [], Vars = []. - initialize_info([-I|T])-N-Vinfo+ExtraArgs+Vars :- - ExtraArgs = [variable(J),variable(N)|A], Vars = [J,N|V], - klic_comp_util:assoc(Vinfo,I,Ans), - N += 1, (I=J)=>Vinfo, - initialize_info_1(T)-N-Vinfo+A+V+Ans+J+I. - initialize_info([+X0|T])-N-Vinfo+ExtraArgs+V :- - ExtraArgs = [X|A], - replace_vars(X0,X,Vinfo), - initialize_info(T)-N-Vinfo+A+V. - - initialize_info_1(T)-N-Vinfo+A+V+yes(X)+J+_I :- - J=X, - initialize_info(T)-N-Vinfo+A+V. - initialize_info_1(T)-N-Vinfo+A+V+no+J+I :- - J=I, - initialize_info(T)-N-Vinfo+A+V. - - % ----- DLGOALS ----- - dlgoals(functor((X0,Y0)),XY,Vars)-N-Vinfo :- - XY = functor((X,Y)), - dlgoals(X0,X,Vars)-N-Vinfo, - dlgoals(Y0,Y,Vars)-N-Vinfo. - dlgoals(Funct,X,Vars)-N-Vinfo :- - ( Funct=functor((X0;Y0)); Funct=functor((G0->B0))) | - dlor(Funct,X,Vars)-N-Vinfo+_. - dlgoals(functor(X0@Y0),XAY,Vars)-N-Vinfo :- - XAY=functor(X@Y), - dlgoal(X0,X,[])-N-Vinfo, - replace_vars(Y0,Y,Vinfo). - otherwise. - dlgoals(X0,X,_Vars)-N-Vinfo :- - dlgoal(X0,X,[])-N-Vinfo. - - dlor(functor((functor((G0->B0));R0)),OR,Vars)-N-Vinfo+NC :- - Vinfo0=Vinfo, - OR=functor((functor((G->functor((B,M))));R)), - dlgoals(G0,G,Vars)-N-Vinfo, - dlgoals(B0,B,Vars)-N-Vinfo, - dlor(R0,R,Vars)-N+Vinfo0+_+NC, - merge_vinfo(Vars,NC,M)-Vinfo. - dlor(functor((G0->B0)),OR,Vars)-N-Vinfo+NC :- - OR=functor((G->functor((B,M)))), - dlgoals(G0,G,Vars)-N-Vinfo, - dlgoals(B0,B,Vars)-N-Vinfo, - NC=N, - klic_comp_util:length(Vars,L), - N+=L, - merge_vinfo(Vars,NC,M)-Vinfo. - otherwise. - dlor(functor((G0;R0)),OR,Vars)-N-Vinfo+NC :- - OR=functor((G;R)), - dlgoals(G0,G,Vars)-N-Vinfo, - dlor(R0,R,Vars)-N-Vinfo+NC. - otherwise. - dlor(G0,G,Vars)-N-Vinfo+_NC :- - dlgoals(G0,G,Vars)-N-Vinfo. - - merge_vinfo([],_NC,Merged,_Vinfo1,Vinfo) :- - Merged=atom(true), Vinfo=[]. - merge_vinfo([V,_|Vars],NC,Merged,Vinfo1,Vinfo) :- - Merged=functor((functor(variable(NC)=variable(K)),M)), - Vinfo=[V=NC|VinfoT], - klic_comp_util:assoc(Vinfo1,V,yes(K)), - NC1 := NC+1, - merge_vinfo(Vars,NC1,M,Vinfo1,VinfoT). - - dlgoal(functor(M:X0),MX,V)-N-Vinfo :- M=atom(inline) | - MX=functor(M:X), - replace_vars(X0,X1,Vinfo), - update_info(V,Vars)-N-Vinfo, - dlappend_args(X1,Vars,X). - dlgoal(functor(M:X0),MX,V)-N-Vinfo :- M=atom(MN), MN\=inline | - MX=functor(M:X), - dlgoal(X0,X,V)-N-Vinfo. - dlgoal(functor(X0-variable(I)),X,V)-N-Vinfo :- - dlgoal(X0,X,[-I|V])-N-Vinfo. - dlgoal(functor(X0+Y),X,V)-N-Vinfo :- - dlgoal(X0,X,[+Y|V])-N-Vinfo. - dlgoal(atom(X0),X,V)-N-Vinfo :- - update_info(V,Vars)-N-Vinfo, - dlgoal_atom(X0,Vars,X). - dlgoal(functor(<==(variable(I),Term0)),X,V)-N-Vinfo :- - N0=N, - dl_update(Term0,X,V)-N-Vinfo+I+J+N0+Term+Term. - dlgoal(functor(variable(I)<=Term0),X,V)-N-Vinfo :- - N0=N, - dl_update(Term0,X,V)-N-Vinfo+I+J+J+Term+list([Term|variable(N0)]). - dlgoal(functor(Term0=>variable(I)),X,V)-N-Vinfo :- - N0=N, - dl_update(Term0,X,V)-N-Vinfo+I+J+N0+Term+list([Term|variable(J)]). - dlgoal(functor(variable(I)+=Expr0),X,V)-N-Vinfo :- - dl_compute(Expr0,X,V)-N-Vinfo+I+(+). - dlgoal(functor(variable(I)-=Expr0),X,V)-N-Vinfo :- - dl_compute(Expr0,X,V)-N-Vinfo+I+(-). - dlgoal(functor(variable(I)*=Expr0),X,V)-N-Vinfo :- - dl_compute(Expr0,X,V)-N-Vinfo+I+(*). - dlgoal(functor(variable(I)/=Expr0),X,V)-N-Vinfo :- - dl_compute(Expr0,X,V)-N-Vinfo+I+(/). - dlgoal(variable(X0), X, V)-N-Vinfo :- - klic_comp_message:report_error("Invalid goal: ~W",[variable(X0)]), - X=variable(X0). - otherwise. - dlgoal(X0,X,V)-N-Vinfo :- - replace_vars(X0,X1,Vinfo), - update_info(V,Vars)-N-Vinfo, - dlappend_args(X1,Vars,X). - - dl_compute(Expr0,X,V)-N-Vinfo+I+Op :- - functor_table:(Expr1=..[Op,variable(J),Expr]), - X=functor(variable(N):=functor(Expr1)), - dl_common(Expr0,Expr,V)-N-Vinfo+I+J. - - dl_update(Term0,X,V)-N-Vinfo+I+J+K+Term+Value :- - X=functor(variable(K)=Value), - dl_common(Term0,Term,V)-N-Vinfo+I+J. - - dl_common(Term0,Term,V)-N-Vinfo+I+J :- - replace_vars(Term0,Term,Vinfo), - klic_comp_util:assoc(Vinfo,I,Ans), - (I=N)=>Vinfo, - N+=1, - update_info_1(V,V)-N-Vinfo+Ans+I+J. - - dlgoal_atom(X0,Vars,X) :- Vars=[] | X = atom(X0). - dlgoal_atom(X0,Vars,X) :- Vars\=[] | - functor_table:(X1=..[X0|Vars]), - X = functor(X1). - - dlappend_args(X0,Vars,X) :- Vars=[] | X=X0. - dlappend_args(X0,Vars,X) :- Vars\=[] | - ( X0=functor(F0) -> klic_comp_util:univ(F0,[F|L],Vars) - ; X0=atom(F0) -> F=F0, L=Vars - ; X0=list([Car|Cdr]) -> F='.', L=[Car,Cdr|Vars] ), - functor_table:(X1=..[F|L]), - X = functor(X1). +dlclause( functor( H0 ), G0, B0, H, G, B, N0, N, V ) :- + dlclause_1( H0, G0, B0, H, G, B, N0, N, V ). +dlclause( atom( F ), G0, B0, H, G, B, N0, N, V ) :- + dlclause_1( F, G0, B0, H, G, B, N0, N, V ). +otherwise. +dlclause( H0, G0, B0, H, G, B, N0, N, V ) :- + klic_comp_message:report_error( "Invalid head: ~w", [H0] ). + + % ---------- Extra Arguments are added to the head goal ---------- + % If Head Goal is a functor, then + dlclause_1( (H0 - variable( I )), G0, B0, H, G, B, N0, N, V ) :- + dlclause( H0, G0, B0, H, G, B, N0, N, [-I | V] ). + dlclause_1( (H0 + X) , G0, B0, H, G, B, N0, N, V ) :- + dlclause( H0, G0, B0, H, G, B, N0, N, [+X | V] ). + otherwise. + dlclause_1( H0 , G0, B0, H, G, B, N0, N, V ) :- + initialize_info( V, N0, N1, [], Vinfo1, ExtraArgs, Vars ), + klic_comp_util:univ( H0, [F | L], ExtraArgs ), + functor_table:( H =.. [F | L] ), + dlgoals( G0, G, Vars, N1, N2, Vinfo1, Vinfo2 ), + dlgoals( B0, B1, Vars, N2, N, Vinfo2, Vinfo3 ), + finalize_vars( Vars, Vinfo3, B1, B ). + + % ----- INITIALIZE INFO ----- + initialize_info( [] )-N-Vinfo+EArgs+Vars :- + EArgs = [], + Vars = []. + initialize_info( [-I | T] )-N-Vinfo+ExtraArgs+Vars :- + ExtraArgs = [variable( J ), variable( N ) | A], + Vars = [J, N | V], + klic_comp_util:assoc( Vinfo, I, Ans ), + N += 1, (I=J) => Vinfo, + initialize_info_1( T )-N-Vinfo+A+V+Ans+J+I. + initialize_info( [+X0 | T] )-N-Vinfo+ExtraArgs+V :- + ExtraArgs = [X | A], + replace_vars( X0, X, Vinfo ), + initialize_info( T )-N-Vinfo+A+V. + + initialize_info_1( T )-N-Vinfo+A+V+yes( X )+J+_I :- + J = X, + initialize_info( T )-N-Vinfo+A+V. + initialize_info_1( T )-N-Vinfo+A+V+no+J+I :- + J = I, + initialize_info( T )-N-Vinfo+A+V. + + % ----- DLGOALS ----- + dlgoals( functor( ( X0, Y0 )), XY, Vars )-N-Vinfo :- + XY = functor( (X, Y) ), + dlgoals( X0, X, Vars )-N-Vinfo, + dlgoals( Y0, Y, Vars )-N-Vinfo. + dlgoals( Funct, X, Vars )-N-Vinfo :- + (Funct = functor( (X0; Y0) ); Funct = functor( (G0 -> B0) )) | + dlor( Funct, X, Vars )-N-Vinfo+_. + dlgoals( functor( X0@Y0 ), XAY, Vars )-N-Vinfo :- + XAY = functor( X@Y ), + dlgoal( X0, X, [] )-N-Vinfo, + replace_vars( Y0, Y, Vinfo ). + otherwise. + dlgoals( X0, X, _Vars )-N-Vinfo :- + dlgoal( X0, X, [] )-N-Vinfo. + + dlor( functor( (functor( (G0->B0) ); R0) ), OR, Vars )-N-Vinfo+NC :- + Vinfo0 = Vinfo, + OR = functor( (functor( (G -> functor( (B, M) )) ); R) ), + dlgoals( G0, G, Vars )-N-Vinfo, + dlgoals( B0, B, Vars )-N-Vinfo, + dlor( R0, R, Vars )-N+Vinfo0+_+NC, + merge_vinfo( Vars, NC, M )-Vinfo. + dlor( functor( (G0 -> B0) ), OR, Vars )-N-Vinfo+NC :- + OR = functor( (G -> functor( (B, M) )) ), + dlgoals( G0, G, Vars )-N-Vinfo, + dlgoals( B0, B, Vars )-N-Vinfo, + NC = N, + klic_comp_util:length( Vars, L ), + N += L, + merge_vinfo( Vars, NC, M )-Vinfo. + otherwise. + dlor( functor( (G0; R0) ), OR, Vars )-N-Vinfo+NC :- + OR = functor( (G; R) ), + dlgoals( G0, G, Vars )-N-Vinfo, + dlor( R0, R, Vars )-N-Vinfo+NC. + otherwise. + dlor( G0, G, Vars )-N-Vinfo+_NC :- + dlgoals( G0, G, Vars )-N-Vinfo. + + merge_vinfo( [], _NC, Merged, _Vinfo1, Vinfo ) :- + Merged = atom( true ), + Vinfo = []. + merge_vinfo( [V, _|Vars], NC, Merged, Vinfo1, Vinfo ) :- + Merged = functor( (functor( variable( NC ) = variable( K )), M) ), + Vinfo = [V=NC | VinfoT], + klic_comp_util:assoc( Vinfo1, V, yes( K )), + NC1 := NC + 1, + merge_vinfo( Vars, NC1, M, Vinfo1, VinfoT ). + + dlgoal( functor( M:X0 ), MX, V )-N-Vinfo :- M = atom( inline ) | + MX = functor( M:X ), + replace_vars( X0, X1, Vinfo ), + update_info( V, Vars )-N-Vinfo, + dlappend_args( X1, Vars, X ). + dlgoal( functor( M:X0 ), MX, V )-N-Vinfo :- M = atom( MN ), MN \= inline | + MX = functor( M:X ), + dlgoal( X0, X, V )-N-Vinfo. + dlgoal( functor( X0 - variable( I )), X, V )-N-Vinfo :- + dlgoal( X0, X, [-I|V] )-N-Vinfo. + dlgoal( functor( X0 + Y ), X, V )-N-Vinfo :- + dlgoal( X0, X, [+Y|V] )-N-Vinfo. + dlgoal( atom( X0 ), X, V )-N-Vinfo :- + update_info( V, Vars )-N-Vinfo, + dlgoal_atom( X0, Vars, X ). + dlgoal( functor( variable( I ) <== Term0 ), X, V )-N-Vinfo :- + N0 = N, + dl_update( Term0, X, V )-N-Vinfo+I+J+N0+Term+Term. + dlgoal( functor( variable( I ) <= Term0 ), X, V )-N-Vinfo :- + N0 = N, + dl_update( Term0, X, V )-N-Vinfo+I+J+J+Term+list( [Term|variable( N0 )] ). + dlgoal( functor( Term0 => variable( I )), X, V )-N-Vinfo :- + N0 = N, + dl_update( Term0, X, V )-N-Vinfo+I+J+N0+Term+list( [Term|variable( J )] ). + dlgoal( functor( variable( I ) += Expr0 ), X, V )-N-Vinfo :- + dl_compute( Expr0, X, V )-N-Vinfo+I+( + ). + dlgoal( functor( variable( I ) -= Expr0 ), X, V )-N-Vinfo :- + dl_compute( Expr0, X, V )-N-Vinfo+I+( - ). + dlgoal( functor( variable( I ) *= Expr0 ), X, V )-N-Vinfo :- + dl_compute( Expr0, X, V )-N-Vinfo+I+( * ). + dlgoal( functor( variable( I ) /= Expr0 ), X, V )-N-Vinfo :- + dl_compute( Expr0, X, V )-N-Vinfo+I+( / ). + dlgoal( variable( X0 ), X, V )-N-Vinfo :- + klic_comp_message:report_error( "Invalid goal: ~W", [variable( X0 )] ), + X = variable( X0 ). + otherwise. + dlgoal( X0, X, V )-N-Vinfo :- + replace_vars( X0, X1, Vinfo ), + update_info( V, Vars )-N-Vinfo, + dlappend_args( X1, Vars, X ). + + dl_compute( Expr0, X, V )-N-Vinfo+I+Op :- + functor_table:( Expr1 =.. [Op, variable( J ), Expr] ), + X = functor( variable( N ) := functor( Expr1 )), + dl_common( Expr0, Expr, V )-N-Vinfo+I+J. + + dl_update( Term0, X, V )-N-Vinfo+I+J+K+Term+Value :- + X = functor( variable( K ) = Value ), + dl_common( Term0, Term, V )-N-Vinfo+I+J. + + dl_common( Term0, Term, V )-N-Vinfo+I+J :- + replace_vars( Term0, Term, Vinfo ), + klic_comp_util:assoc( Vinfo, I, Ans ), + (I=N) => Vinfo, + N += 1, + update_info_1( V, V )-N-Vinfo+Ans+I+J. + + dlgoal_atom( X0, Vars, X ) :- Vars = [] | + X = atom( X0 ). + dlgoal_atom( X0, Vars, X ) :- Vars \= [] | + functor_table:( X1 =.. [X0|Vars] ), + X = functor( X1 ). + + dlappend_args( X0, Vars, X ) :- Vars = [] | + X = X0. + dlappend_args( X0, Vars, X ) :- Vars \= [] | + ( X0 = functor( F0 ) -> klic_comp_util:univ( F0, [F|L], Vars ) + ; X0 = atom( F0 ) -> F = F0 , L = Vars + ; X0 = list( [Car|Cdr] ) -> F = '.', L = [Car, Cdr | Vars] ), + functor_table:( X1 =.. [F|L] ), + X = functor( X1 ). % ----- UPDATE INFO ----- - update_info([],Vars,N0,N,Vinfo0,Vinfo) :- - N = N0, Vinfo = Vinfo0, Vars = []. - update_info([-I|T],Vars,N0,N,Vinfo0,Vinfo) :- - Vars = [variable(J),variable(N0)|V], - klic_comp_util:assoc(Vinfo0,I,Ans), - N1 := N0+1, - update_info_1(T,V,N1,N,[I=N0|Vinfo0],Vinfo,Ans,I,J). - update_info([+X0|T],Vars,N0,N,Vinfo0,Vinfo) :- - Vars = [X|V], - replace_vars(X0,X,Vinfo0), - update_info(T,V,N0,N,Vinfo0,Vinfo). - - update_info_1(T,V,N1,N,Vinfo0,Vinfo,yes(X),I,J) :- - J=X, - update_info(T,V,N1,N,Vinfo0,Vinfo). - update_info_1(T,V,N1,N,Vinfo0,Vinfo,no,I,J) :- - J=I, - update_info(T,V,N1,N,Vinfo0,Vinfo). + update_info( [], Vars, N0, N, Vinfo0, Vinfo ) :- + N = N0, + Vinfo = Vinfo0, + Vars = []. + update_info( [-I|T], Vars, N0, N, Vinfo0, Vinfo ) :- + Vars = [variable( J ), variable( N0 ) | V], + klic_comp_util:assoc( Vinfo0, I, Ans ), + N1 := N0 + 1, + update_info_1( T, V, N1, N, [I=N0|Vinfo0], Vinfo, Ans, I, J ). + update_info( [+X0|T], Vars, N0, N, Vinfo0, Vinfo ) :- + Vars = [X | V], + replace_vars( X0, X, Vinfo0 ), + update_info( T, V, N0, N, Vinfo0, Vinfo ). + + update_info_1( T, V, N1, N, Vinfo0, Vinfo, yes( X ), I, J ) :- + J = X, + update_info( T, V, N1, N, Vinfo0, Vinfo ). + update_info_1( T, V, N1, N, Vinfo0, Vinfo, no, I, J ) :- + J = I, + update_info( T, V, N1, N, Vinfo0, Vinfo ). % ----- REPLACE VARS ----- - replace_vars(variable(K),Replaced,Vinfo) :- - Replaced = variable(J), - klic_comp_util:assoc(Vinfo,K,Ans), - replace_vars_1(Ans,J,K). - replace_vars(list([H0|T0]),Replaced,Vinfo) :- - Replaced = list([H|T]), - replace_vars(H0,H,Vinfo), - replace_vars(T0,T,Vinfo). - replace_vars(vector(V0),Replaced,Vinfo) :- - klic_comp_util:vector_to_list(V0,L0), - replace_vars_elems(L0,L,Vinfo), - generic:new(vector,V,L), - Replaced=vector(V). - replace_vars(functor(F0),Replaced,Vinfo) :- - klic_comp_util:univ(F0,[P|L0]), - replace_vars_elems(L0,L,Vinfo), - functor_table:(F=..[P|L]), - Replaced=functor(F). -otherwise. - replace_vars(Term,Replaced,_) :- Replaced = Term. - - replace_vars_1(yes(X),J,_K) :- J=X. - replace_vars_1(no , J, K) :- J=K. - - replace_vars_elems([],L,Vinfo) :- L=[]. - replace_vars_elems([H0|T0],L,Vinfo) :- - replace_vars(H0,H,Vinfo), - L = [H|T], - replace_vars_elems(T0,T,Vinfo). - - % ----- COUNTVARS ----- - countvars(X,Table) :- findvars(X,Vars,[]), countvars(Vars,Table,[]). - - countvars([])-Tbl. - countvars([K|T0])-Tbl :- - countsame(T0,T,K,1,N), - Tbl <= (K=N), - countvars(T)-Tbl. + replace_vars( variable( K ), Replaced, Vinfo ) :- + Replaced = variable( J ), + klic_comp_util:assoc( Vinfo, K, Ans ), + replace_vars_1( Ans, J, K ). + replace_vars( list( [H0|T0] ), Replaced, Vinfo ) :- + Replaced = list( [H | T] ), + replace_vars( H0, H, Vinfo ), + replace_vars( T0, T, Vinfo ). + replace_vars( vector( V0 ), Replaced, Vinfo ) :- + klic_comp_util:vector_to_list( V0, L0 ), + replace_vars_elems( L0, L, Vinfo ), + generic:new( vector, V, L ), + Replaced = vector( V ). + replace_vars( functor( F0 ), Replaced, Vinfo ) :- + klic_comp_util:univ( F0, [P|L0] ), + replace_vars_elems( L0, L, Vinfo ), + functor_table:( F =.. [P|L] ), + Replaced = functor( F ). + otherwise. + replace_vars( Term, Replaced, _ ) :- + Replaced = Term. + + replace_vars_1( yes( X ), J, _K ) :- J = X. + replace_vars_1( no , J, K ) :- J = K. + + replace_vars_elems( [], L, Vinfo ) :- + L = []. + replace_vars_elems( [H0|T0], L, Vinfo ) :- + replace_vars( H0, H, Vinfo ), + L = [H | T], + replace_vars_elems( T0, T, Vinfo ). + + % ----- COUNTVARS ----- + countvars( X, Table ) :- + findvars( X, Vars, [] ), + countvars( Vars, Table, [] ). + + countvars( [] )-Tbl. + countvars( [K|T0] )-Tbl :- + countsame( T0, T, K, 1, N ), + Tbl <= (K=N), + countvars( T )-Tbl. % ----- FINDVARS ----- - findvars(variable(K))-V :- integer(K) | V <= K. - findvars(Vect)-V :- vector(Vect,_) | - klic_comp_util:vector_to_list(Vect,L), - findvars_elems(L)-V. -otherwise. - findvars(Term)-V :- - klic_comp_util:univ(Term,[_|L]), - findvars_elems(L)-V. - - findvars_elems([])-V. - findvars_elems([H|T])-V :- - findvars(H)-V, findvars_elems(T)-V. - - % ----- COUNTSAME ----- - countsame([], T,_)-N :- T = []. - countsame([J|T0], T,K)-N :- J=:=K | N += 1, countsame(T0,T,K)-N. - countsame([J|T0],T1,K)-N :- J=\=K | T1 = [J|T], countsame(T0,T,K)-N. - - % ----- FINALIZE VARS ----- - finalize_vars([], _)-B. - finalize_vars([I,J|VF],Info,B0,B) :- - klic_comp_util:assoc(Info,I,yes(K)), - finalize_vars(VF,Info,functor((functor(variable(J)=variable(K)),B0)),B). - - % ----- EXP HEAD ----- - exp_head(H,NewH)-V-G :- functor(H,F,Arity) | - NewH = functor(NewH0), - klic_comp_util:univ(H,[F|Args]), - exp_head_and_guard_top(Args,NewArgs)-V-G, - functor_table:(NewH0=..[F|NewArgs]). - - exp_head_and_guard_top([],NewArgs)-V-G :- NewArgs = []. - exp_head_and_guard_top([A|Args],NewArgs0)-V-G :- - NewArgs0 = [variable(V)|NewArgs], - G <= functor(A=variable(V)), - V += 1, - exp_head_and_guard_top(Args,NewArgs)-V-G. - - % ----- LINEARIZE GUARD ----- - linearize_guard(atom(true))-G. - linearize_guard(functor((X,Y)))-G :- - linearize_guard(X)-G, linearize_guard(Y)-G. - otherwise. - linearize_guard(Goal)-G :- G <= Goal. - + findvars( variable( K ))-V :- integer( K ) | + V <= K. + findvars( Vect )-V :- vector( Vect, _ ) | + klic_comp_util:vector_to_list( Vect, L ), + findvars_elems( L )-V. + otherwise. + findvars( Term )-V :- + klic_comp_util:univ( Term, [_|L] ), + findvars_elems( L )-V. + + findvars_elems( [] )-V. + findvars_elems( [H|T] )-V :- + findvars( H )-V, + findvars_elems( T )-V. - % ----- EXP GUARD ----- - exp_guard([])-V-G. - exp_guard([functor((X0;Y0))|T])-V-G :- - G <= functor((X;Y)), - linearize_guard(X0,X1,T), exp_guard(X1)-V+X+[], - linearize_guard(Y0,Y1,T), exp_guard(Y1)-V+Y+[]. - otherwise. - exp_guard([G|T])-V+NewG0+NewG :- - macro_goal(G)-V+After+NewG1+NewG0+After+g, - exp_guard(T)-V+NewG1+NewG. - - % ----- EXP BODY ----- - exp_body(atom(true))-V-T-M-B. - exp_body(functor((X,Y)))-V-T-M-B :- - exp_body(X)-V-T-M-B, exp_body(Y)-V-T-M-B. - exp_body(Funct)-V-T-M-B :- - ( Funct=functor((X->Y)); Funct=functor((X;Y)) ) | - M <= expanded(OR,ID), - B <= Goal, - exp_body_or(Funct,Goal,ID,V,T,OR). - otherwise. - exp_body(G)-V-T-M+B0+B :- - macro_goal(G)-V+After+B+B0+After+b. + % ----- COUNTSAME ----- + countsame( [], T, _ )-N :- T = []. + countsame( [J|T0], T, K )-N :- J=:=K | N += 1, countsame( T0, T, K )-N. + countsame( [J|T0], T1, K )-N :- J=\=K | T1 = [J|T], countsame( T0, T, K )-N. + + % ----- FINALIZE VARS ----- + finalize_vars( [], _ )-B. + finalize_vars( [I, J|VF], Info, B0, B ) :- + klic_comp_util:assoc( Info, I, yes( K )), + finalize_vars( VF, Info, + functor( (functor( variable( J ) = variable( K )), B0) ), B ). + + % ----- EXP HEAD ----- + exp_head( H, NewH )-V-G :- functor( H, F, Arity ) | + NewH = functor( NewH0 ), + klic_comp_util:univ( H, [F|Args] ), + exp_head_and_guard_top( Args, NewArgs )-V-G, + functor_table:( NewH0 =.. [F|NewArgs] ). + + exp_head_and_guard_top( [], NewArgs )-V-G :- + NewArgs = []. + exp_head_and_guard_top( [A|Args], NewArgs0 )-V-G :- + NewArgs0 = [variable( V ) | NewArgs], + G <= functor( A = variable( V )), + V += 1, + exp_head_and_guard_top( Args, NewArgs )-V-G. + + % ----- LINEARIZE GUARD ----- + linearize_guard( atom( true ))-G. + linearize_guard( functor( (X, Y) ))-G :- + linearize_guard( X )-G, + linearize_guard( Y )-G. + otherwise. + linearize_guard( Goal )-G :- + G <= Goal. + + + % ----- EXP GUARD ----- + exp_guard( [] )-V-G. + exp_guard( [functor( (X0; Y0) ) | T] )-V-G :- + G <= functor( (X; Y) ), + linearize_guard( X0, X1, T ), exp_guard( X1 )-V+X+[], + linearize_guard( Y0, Y1, T ), exp_guard( Y1 )-V+Y+[]. + otherwise. + exp_guard( [G | T] )-V+NewG0+NewG :- + macro_goal( G )-V+After+NewG1+NewG0+After+g, + exp_guard( T )-V+NewG1+NewG. + + % ----- EXP BODY ----- + exp_body( atom( true ))-V-T-M-B. + exp_body( functor( (X, Y) ))-V-T-M-B :- + exp_body( X )-V-T-M-B, + exp_body( Y )-V-T-M-B. + exp_body( Funct )-V-T-M-B :- + (Funct=functor( (X->Y) ); Funct=functor( (X;Y) )) | + M <= expanded( OR, ID ), + B <= Goal, + exp_body_or( Funct, Goal, ID, V, T, OR ). + otherwise. + exp_body( G )-V-T-M+B0+B :- + macro_goal( G )-V+After+B+B0+After+b. % ------ EXP BODY OR ---- - exp_body_or(X,G,ID,V,T,OR) :- - countvars(X,T1), - find_interface_vars(T1,T,IV), - functor_table:(G=..['$macroexpanded',ID,IV]), - functor_table:(G1=..['$macroexpanded',ID|IV]), - body_or_clauses(X,G1,V,T,OR,[]). - - find_interface_vars([], _,V) :- V = []. - find_interface_vars([K=N|T0],T1,V) :- - klic_comp_util:assoc(T1,K,Ans), - find_interface_vars_1(T0,T1,V,K,N,Ans). - - find_interface_vars_1(T0,T1,V,_K,N,yes(N)) :- - find_interface_vars(T0,T1,V). + exp_body_or( X, G, ID, V, T, OR ) :- + countvars( X, T1 ), + find_interface_vars( T1, T, IV ), + functor_table:( G =.. ['$macroexpanded', ID, IV] ), + functor_table:( G1 =.. ['$macroexpanded', ID | IV] ), + body_or_clauses( X, G1, V, T, OR, [] ). + + find_interface_vars( [], _, V ) :- + V = []. + find_interface_vars( [K=N|T0], T1, V ) :- + klic_comp_util:assoc( T1, K, Ans ), + find_interface_vars_1( T0, T1, V, K, N, Ans ). + + find_interface_vars_1( T0, T1, V, _K, N, yes( N )) :- + find_interface_vars( T0, T1, V ). + otherwise. + find_interface_vars_1( T0, T1, V, K, N, _ ) :- + V = [variable( K ) | V1], + find_interface_vars( T0, T1, V1 ). + + body_or_clauses( functor( (X ; Rest) ), H, V, T )-OR :- + body_or_one( X, H, V, T )-OR, + body_or_clauses( Rest, H, V, T )-OR. otherwise. - find_interface_vars_1(T0,T1,V, K,N,_) :- - V = [variable(K)|V1], - find_interface_vars(T0,T1,V1). - - body_or_clauses(functor((X ; Rest)),H,V,T)-OR :- - body_or_one(X,H,V,T)-OR, - body_or_clauses(Rest,H,V,T)-OR. - otherwise. - body_or_clauses(Last,H,V,T)-OR :- - body_or_one(Last,H,V,T)-OR. - - body_or_one(atom(A),_,_,_)-OR :- ( A=otherwise; A=alternatively ) | - OR <= A. - body_or_one(functor((G->B)),H,V,T)-OR :- - OR <= clause(H,NewG,NewB,Exp), - linearize_guard(G,G1,[]), - exp_guard(G1,V,V1,NewG,[]), -% try to patch by Fujise 19940709 -% exp_body(B,V1,_,T,Exp,[],NewB,[]). - countvars([H,G|B],NewT), - exp_body(B,V1,_,NewT,_,Exp,[],NewB,[]). + body_or_clauses( Last, H, V, T )-OR :- + body_or_one( Last, H, V, T )-OR. + + body_or_one( atom( A ), _, _, _ )-OR :- + (A=otherwise; A=alternatively) | + OR <= A. + body_or_one( functor( (G->B) ), H, V, T )-OR :- + OR <= clause( H, NewG, NewB, Exp ), + linearize_guard( G, G1, [] ), + exp_guard( G1, V, V1, NewG, [] ), + countvars( [H, G|B], NewT ), + exp_body( B, V1, _, NewT, _, Exp, [], NewB, [] ). otherwise. - body_or_one(X, _,_,_)-OR :- - klic_comp_message:report_error("Invalid body or case: ~w", [X]). + body_or_one( X, _, _, _ )-OR :- + klic_comp_message:report_error( "Invalid body or case: ~w", [X] ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % ----- MACRO GOAL ----- % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -macro_goal(functor(G0))-V-After-B+GB :- - macro_goal_functor(G0)-V-After-B+GB. -macro_goal(atom(G))-V-After-B+GB :- - B <= atom(G). -otherwise. -macro_goal(G)-V-After-B+GB :- - klic_comp_message:report_error("Invalid Goal: ~w",[G]). - -macro_goal_functor((LHS0:=RHS0))-V-After-B+GB :- - macro_arg_n([.(LHS0,LHS),.(RHS0,RHS)])-V-After-B+GB, - macro_exp(RHS,X)-V-B, - B <= functor(LHS=X). -macro_goal_functor((LHS0$:=RHS0))-V-After-B+GB :- - macro_arg_n([.(LHS0,LHS),.(RHS0,RHS)])-V-After-B+GB, - macro_float_exp(RHS,X)-V-B, - B <= functor(LHS=X). -macro_goal_functor((X0\=Y0))-V-After-B+g :- - macro_arg_n([.(X0,X),.(Y0,Y)])-V-After-B+g, - B <= functor(diff(X,Y)). -macro_goal_functor(vector(X0))-V-After-B+g :- - V0=V, V+=1, - macro_arg(X0,X,g)-V-After-B, - macro_goal_functor(vector(X,variable(V0)))-V-After-B+g. -macro_goal_functor(string(X0))-V-After-B+g :- - V0=V, V1:=V0+1, V+=2, - macro_arg(X0,X,g)-V-After-B, - macro_goal_functor(string(X,variable(V0),variable(V1)))-V-After-B+g. -macro_goal_functor(string(X0,Y0))-V-After-B+g :- - macro_arg_n([.(X0,X),.(Y0,Y)])-V-After-B+g, - V0=V, V+=1, - macro_goal_functor(string(X,Y,variable(V0)))-V-After-B+g. -macro_goal_functor(vector_element(S,L,E,NS))-V-After-B+b :- - macro_goal_functor(S=NS)-V-After-B+b, - macro_goal_functor(vector_element(S,L,E))-V-After-B+b. -macro_goal_functor(string(S0,L0,EL0,NS0))-V-After-B+b :- - macro_arg_n([.(S0,S),.(L0,L),.(EL0,EL),.(NS0,NS)])-V-After-B+b, - B <= functor(S=NS), - B <= functor(atom(generic):functor(string(S,L,EL))). -macro_goal_functor(string_element(S0,L0,EL0,NS0))-V-After-B+b :- - macro_arg_n([.(S0,S),.(L0,L),.(EL0,EL),.(NS0,NS)])-V-After-B+b, - B <= functor(S=NS), - B <= functor(atom(generic):functor(element(S,L,EL))). -macro_goal_functor(vector(S0,L0,NS0))-V-After-B+b :- - macro_arg_n([.(S0,S),.(L0,L),.(NS0,NS)])-V-After-B+b, - B <= functor(S=NS), - B <= functor(atom(generic):functor(size(S,L))). -macro_goal_functor(atom(builtin)#functor(apply(F0,A0)))-V-After-B+b :- - macro_arg_n([.(F0,F),.(A0,A)])-V-After-B+b, - B <= functor(atom(generic):functor(apply(F,A))). -otherwise. -macro_goal_functor(G)-V-After-B+GB :- - compar_macro(G,Ans)+GB, - macro_goal_functor_cmp(Ans)-V-After-B+GB+Goal, - B <= functor(Goal). - -macro_goal_functor_cmp(int(LHS0,RHS0,Op))-V-After-B+g+Goal :- - macro_arg_n([.(LHS0,LHS1),.(RHS0,RHS1)])-V-After-B+g, - macro_exp(LHS1,LHS)-V-B, - macro_exp(RHS1,RHS)-V-B, - functor_table:(Goal=..[Op,LHS,RHS]). -macro_goal_functor_cmp(float(LHS0,RHS0,Op))-V-After-B+g+Goal :- - macro_arg_n([.(LHS0,LHS1),.(RHS0,RHS1)])-V-After-B+g, - macro_float_exp(LHS1,LHS)-V-B, - macro_float_exp(RHS1,RHS)-V-B, - functor_table:(Goal0=..[Op,LHS,RHS]), - Goal=(atom(generic):functor(Goal0)). -macro_goal_functor_cmp(general(LHS0,RHS0,Op))-V-After-B+g+Goal :- - V0 = V, V += 1, - macro_arg_n([.(LHS0,LHS),.(RHS0,RHS)])-V-After-B+g, - B <= functor(compare(LHS,RHS,variable(V0))), - functor_table:(Goal=..[Op,variable(V0),integer(0)]). -macro_goal_functor_cmp(no(G))-V-After-B+GB+Goal :- - klic_comp_util:univ(G,[F|Args]), - macro_args(Args,Xargs,GB)-V-After-B, - functor_table:(G1=..[F|Xargs]), - expand_goal(GB,G1,Ans), - make_expanded_call(Ans,Goal). - -make_expanded_call(yes(Module,G0),Goal) :- - Goal=(atom(Module):functor(G0)). -make_expanded_call(no(G0),Goal) :- - Goal=G0. +macro_goal( functor( G0 ))-V-After-B+GB :- + macro_goal_functor( G0 )-V-After-B+GB. +macro_goal( atom( G ))-V-After-B+GB :- + B <= atom( G ). +otherwise. +macro_goal( G )-V-After-B+GB :- + klic_comp_message:report_error( "Invalid Goal: ~w", [G] ). + +macro_goal_functor( (LHS0 := RHS0) )-V-After-B+GB :- + macro_arg_n( [.( LHS0, LHS ), .( RHS0, RHS )] )-V-After-B+GB, + macro_exp( RHS, X )-V-B, + B <= functor( LHS=X ). +macro_goal_functor( (LHS0 $:= RHS0) )-V-After-B+GB :- + macro_arg_n( [.( LHS0, LHS ), .( RHS0, RHS )] )-V-After-B+GB, + macro_float_exp( RHS, X )-V-B, + B <= functor( LHS=X ). +macro_goal_functor( (X0 \= Y0) )-V-After-B+g :- + macro_arg_n( [.( X0, X ), .( Y0, Y )] )-V-After-B+g, + B <= functor( diff( X, Y )). +macro_goal_functor( vector( X0 ))-V-After-B+g :- + V0=V, V+=1, + macro_arg( X0, X, g )-V-After-B, + macro_goal_functor( vector( X, variable( V0 )))-V-After-B+g. +macro_goal_functor( string( X0 ))-V-After-B+g :- + V0=V, V1:=V0+1, V+=2, + macro_arg( X0, X, g )-V-After-B, + macro_goal_functor( string( X, variable( V0 ), variable( V1 )))-V-After-B+g. +macro_goal_functor( string( X0, Y0 ))-V-After-B+g :- + macro_arg_n( [.( X0, X ), .( Y0, Y )] )-V-After-B+g, + V0=V, V+=1, + macro_goal_functor( string( X, Y, variable( V0 )))-V-After-B+g. +macro_goal_functor( vector_element( S, L, E, NS ))-V-After-B+b :- + macro_goal_functor( S=NS )-V-After-B+b, + macro_goal_functor( vector_element( S, L, E ))-V-After-B+b. +macro_goal_functor( string( S0, L0, EL0, NS0 ))-V-After-B+b :- + macro_arg_n( + [.( S0, S ), .( L0, L ), .( EL0, EL ), .( NS0, NS )] )-V-After-B+b, + B <= functor( S=NS ), + B <= functor( atom( generic ):functor( string( S, L, EL ))). +macro_goal_functor( string_element( S0, L0, EL0, NS0 ))-V-After-B+b :- + macro_arg_n( + [.( S0, S ), .( L0, L ), .( EL0, EL ), .( NS0, NS )] )-V-After-B+b, + B <= functor( S=NS ), + B <= functor( atom( generic ):functor( element( S, L, EL ))). +macro_goal_functor( vector( S0, L0, NS0 ))-V-After-B+b :- + macro_arg_n( [.( S0, S ), .( L0, L ), .( NS0, NS )] )-V-After-B+b, + B <= functor( S=NS ), + B <= functor( atom( generic ):functor( size( S, L ))). +macro_goal_functor( atom( builtin )#functor( apply( F0, A0 )))-V-After-B+b :- + macro_arg_n( [.( F0, F ), .( A0, A )] )-V-After-B+b, + B <= functor( atom( generic ):functor( apply( F, A ))). +otherwise. +macro_goal_functor( G )-V-After-B+GB :- + compar_macro( G, Ans )+GB, + macro_goal_functor_cmp( Ans )-V-After-B+GB+Goal, + B <= functor( Goal ). + +macro_goal_functor_cmp( int( LHS0, RHS0, Op ))-V-After-B+g+Goal :- + macro_arg_n( [.( LHS0, LHS1 ), .( RHS0, RHS1 )] )-V-After-B+g, + macro_exp( LHS1, LHS )-V-B, + macro_exp( RHS1, RHS )-V-B, + functor_table:( Goal=..[Op, LHS, RHS] ). +macro_goal_functor_cmp( float( LHS0, RHS0, Op ))-V-After-B+g+Goal :- + macro_arg_n( [.( LHS0, LHS1 ), .( RHS0, RHS1 )] )-V-After-B+g, + macro_float_exp( LHS1, LHS )-V-B, + macro_float_exp( RHS1, RHS )-V-B, + functor_table:( Goal0=..[Op, LHS, RHS] ), + Goal=( atom( generic ):functor( Goal0 )). +macro_goal_functor_cmp( general( LHS0, RHS0, Op ))-V-After-B+g+Goal :- + V0 = V, V += 1, + macro_arg_n( [.( LHS0, LHS ), .( RHS0, RHS )] )-V-After-B+g, + B <= functor( compare( LHS, RHS, variable( V0 ))), + functor_table:( Goal=..[Op, variable( V0 ), integer( 0 )] ). +macro_goal_functor_cmp( no( G ))-V-After-B+GB+Goal :- + klic_comp_util:univ( G, [F|Args] ), + macro_args( Args, Xargs, GB )-V-After-B, + functor_table:( G1=..[F|Xargs] ), + expand_goal( GB, G1, Ans ), + make_expanded_call( Ans, Goal ). + +make_expanded_call( yes( Module, G0 ), Goal ) :- + Goal = (atom( Module ):functor( G0 )). +make_expanded_call( no( G0 ), Goal ) :- + Goal = G0. /* simple omission of module name */ -expand_goal(b,G,Ans) :- G=unbound(X,Y) | Ans=yes(variable,G). -expand_goal(b,G,Ans) :- G=new_functor(F,P,A) | Ans=yes(functor_table,G). -expand_goal(b,G,Ans) :- G=functor(F,P,A) | Ans=yes(functor_table,G). -expand_goal(b,G,Ans) :- G=functor(F,P,A,NF) | Ans=yes(functor_table,G). -expand_goal(b,G,Ans) :- G=setarg(I,F,E,NF) | Ans=yes(functor_table,G). -expand_goal(b,G,Ans) :- G=setarg(I,F,O,E,NF) | Ans=yes(functor_table,G). -expand_goal(b,G,Ans) :- G=arg(I,F,E) | Ans=yes(functor_table,G). -expand_goal(b,G,Ans) :- G=arg(I,F,E,NF) | Ans=yes(functor_table,G). -expand_goal(b,G,Ans) :- G=apply(A,B) | Ans=yes(generic,G). +expand_goal( b, G, Ans ) :- G = unbound( X, Y ) | + Ans = yes( variable, G ). +expand_goal( b, G, Ans ) :- G = new_functor( F, P, A ) | + Ans = yes( functor_table, G ). +expand_goal( b, G, Ans ) :- G = functor( F, P, A ) | + Ans = yes( functor_table, G ). +expand_goal( b, G, Ans ) :- G = functor( F, P, A, NF ) | + Ans = yes( functor_table, G ). +expand_goal( b, G, Ans ) :- G = setarg( I, F, E, NF ) | + Ans = yes( functor_table, G ). +expand_goal( b, G, Ans ) :- G = setarg( I, F, O, E, NF ) | + Ans = yes( functor_table, G ). +expand_goal( b, G, Ans ) :- G = arg( I, F, E ) | + Ans = yes( functor_table, G ). +expand_goal( b, G, Ans ) :- G = arg( I, F, E, NF ) | + Ans = yes( functor_table, G ). +expand_goal( b, G, Ans ) :- G = apply( A, B ) | + Ans = yes( generic, G ). + /* module name omission with predicate name change */ -expand_goal(b,G,Ans) :- G=string_element(S,L,EL) | - Ans=yes(generic,element(S,L,EL)). -expand_goal(b,G,Ans) :- G=set_string_element(S,L,EL,NS) | - Ans=yes(generic,set_element(S,L,EL,NS)). -expand_goal(b,G,Ans) :- G=vector_element(S,L,E) | - Ans=yes(generic,element(S,L,E)). -expand_goal(b,G,Ans) :- G=set_vector_element(X,I,NE,NX) | - Ans=yes(generic,set_element(X,I,NE,NX)). -expand_goal(b,G,Ans) :- G=set_vector_element(X,I,OE,NE,NX) | - Ans=yes(generic,set_element(X,I,OE,NE,NX)). -expand_goal(b,G,Ans) :- G=string_less_than(S,L) | - Ans=yes(generic,less_than(S,L)). -expand_goal(b,G,Ans) :- G=string_not_less_than(S,L) | - Ans=yes(generic,not_less_than(S,L)). -expand_goal(b,G,Ans) :- G=new_string(S,L,EL) | - Ans=yes(generic,new(atom(string),S,L,EL)). -expand_goal(b,G,Ans) :- G=new_vector(S,L) | - Ans=yes(generic,new(atom(vector),S,L)). -expand_goal(b,G,Ans) :- G=module(A,_) | - Ans=yes(generic,module(A)). -expand_goal(b,G,Ans) :- G=code(A,_,_,_) | - Ans=yes(generic,predicate(A)). -expand_goal(b,G,Ans) :- G=merge(X,Y) | - Ans=yes(generic,new(atom(merge),X,Y)). -expand_goal(b,G,Ans) :- G=predicate_to_code(A,B,C,D) | - Ans=yes(builtin_utility,predicate_to_code(A,B,C,D)). -expand_goal(b,G,Ans) :- G=(atom(builtin)#functor(Goal)) | - Ans=yes(builtin_utility,Goal). +expand_goal( b, G, Ans ) :- G = string_element( S, L, EL ) | + Ans = yes( generic, element( S, L, EL )). +expand_goal( b, G, Ans ) :- G = set_string_element( S, L, EL, NS ) | + Ans = yes( generic, set_element( S, L, EL, NS )). +expand_goal( b, G, Ans ) :- G = vector_element( S, L, E ) | + Ans = yes( generic, element( S, L, E )). +expand_goal( b, G, Ans ) :- G = set_vector_element( X, I, NE, NX ) | + Ans = yes( generic, set_element( X, I, NE, NX )). +expand_goal( b, G, Ans ) :- G = set_vector_element( X, I, OE, NE, NX ) | + Ans = yes( generic, set_element( X, I, OE, NE, NX )). +expand_goal( b, G, Ans ) :- G = string_less_than( S, L ) | + Ans = yes( generic, less_than( S, L )). +expand_goal( b, G, Ans ) :- G = string_not_less_than( S, L ) | + Ans = yes( generic, not_less_than( S, L )). +expand_goal( b, G, Ans ) :- G = new_string( S, L, EL ) | + Ans = yes( generic, new( atom( string ), S, L, EL )). +expand_goal( b, G, Ans ) :- G = new_vector( S, L ) | + Ans = yes( generic, new( atom( vector ), S, L )). +expand_goal( b, G, Ans ) :- G = module( A, _ ) | + Ans = yes( generic, module( A )). +expand_goal( b, G, Ans ) :- G = code( A, _, _, _ ) | + Ans = yes( generic, predicate( A )). +expand_goal( b, G, Ans ) :- G = merge( X, Y ) | + Ans = yes( generic, new( atom( merge ), X, Y )). +expand_goal( b, G, Ans ) :- G = predicate_to_code( A, B, C, D ) | + Ans = yes( builtin_utility, predicate_to_code( A, B, C, D )). +expand_goal( b, G, Ans ) :- G = ( atom( builtin )#functor( Goal )) | + Ans = yes( builtin_utility, Goal ). + /* guard goal expansion */ -expand_goal(g,G,Ans) :- G=string_less_than(S,L) | - Ans=yes(generic,less_than(S,L)). -expand_goal(g,G,Ans) :- G=string_not_less_than(S,L) | - Ans=yes(generic,not_less_than(S,L)). -expand_goal(g,G,Ans) :- G=module(A,_) | - Ans=yes(generic,module(A)). -expand_goal(g,G,Ans) :- G=code(A,_,_,_) | - Ans=yes(generic,predicate(A)). +expand_goal( g, G, Ans ) :- G = string_less_than( S, L ) | + Ans = yes( generic, less_than( S, L )). +expand_goal( g, G, Ans ) :- G = string_not_less_than( S, L ) | + Ans = yes( generic, not_less_than( S, L )). +expand_goal( g, G, Ans ) :- G = module( A, _ ) | + Ans = yes( generic, module( A )). +expand_goal( g, G, Ans ) :- G = code( A, _, _, _ ) | + Ans = yes( generic, predicate( A )). otherwise. -expand_goal(_,Goal,Ans) :- Ans=no(Goal). +expand_goal( _, Goal, Ans ) :- + Ans = no( Goal ). % ----- COMPAR MACRO ----- - compar_macro(G,Ans)+b :- Ans=no(G). - compar_macro(X=Y,Ans)+g :- Ans=int(X,Y,not_less_than). - compar_macro(X>Y,Ans)+g :- Ans=int(X,Y,greater_than). - compar_macro(X=:=Y,Ans)+g :- Ans=int(X,Y,equal). - compar_macro(X=\=Y,Ans)+g :- Ans=int(X,Y,not_equal). - compar_macro(X$=Y,Ans)+g :- Ans=float(X,Y,not_less_than). - compar_macro(X$>Y,Ans)+g :- Ans=float(X,Y,greater_than). - compar_macro(X$=:=Y,Ans)+g :- Ans=float(X,Y,equal). - compar_macro(X$=\=Y,Ans)+g :- Ans=float(X,Y,not_equal). - compar_macro(X@=Y,Ans)+g :- Ans=general(X,Y,not_less_than). - compar_macro(X@>Y,Ans)+g :- Ans=general(X,Y,greater_than). + compar_macro( G, Ans )+b :- Ans = no( G ). + compar_macro( X=Y, Ans )+g :- Ans = int( X, Y, not_less_than ). + compar_macro( X>Y, Ans )+g :- Ans = int( X, Y, greater_than ). + compar_macro( X=:=Y, Ans )+g :- Ans = int( X, Y, equal ). + compar_macro( X=\=Y, Ans )+g :- Ans = int( X, Y, not_equal ). + compar_macro( X$=Y, Ans )+g :- Ans = float( X, Y, not_less_than ). + compar_macro( X$>Y, Ans )+g :- Ans = float( X, Y, greater_than ). + compar_macro( X$=:=Y, Ans )+g :- Ans = float( X, Y, equal ). + compar_macro( X$=\=Y, Ans )+g :- Ans = float( X, Y, not_equal ). + compar_macro( X@=Y, Ans )+g :- Ans = general( X, Y, not_less_than ). + compar_macro( X@>Y, Ans )+g :- Ans = general( X, Y, greater_than ). otherwise. - compar_macro(G,Ans)+GB :- Ans = no(G). + compar_macro( G, Ans )+GB :- Ans = no( G ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % ----- MACRO ARGS ----- -macro_args([],XArgs,_GB)-V-After-B :- - XArgs = []. -macro_args([H0|T0],XArgs,GB)-V-After-B :- - XArgs = [H|T], - macro_arg(H0,H,GB)-V-After-B, - macro_args(T0,T,GB)-V-After-B. +macro_args( [], XArgs, _GB )-V-After-B :- + XArgs = []. +macro_args( [H0|T0], XArgs, GB )-V-After-B :- + XArgs = [H|T], + macro_arg( H0, H, GB )-V-After-B, + macro_args( T0, T, GB )-V-After-B. % ----- MACRO ARG ----- % VARIABLE -macro_arg(T,X,_GB)-V-After-B :- T=variable(_) | X=T. -macro_arg(T,X,_GB)-V-After-B :- T=atom(_) | X=T. -macro_arg(T,X,_GB)-V-After-B :- T=integer(_) | X=T. -macro_arg(T,X,_GB)-V-After-B :- T=float(_) | X=T. -macro_arg(T,X,_GB)-V-After-B :- T=string(_) | X=T. -macro_arg(list([CAR|CDR]),X,GB)-V-After-B :- - X = list([XCAR|XCDR]), - macro_arg_n([.(CAR,XCAR),.(CDR,XCDR)])-V-After-B+GB. -macro_arg(functor(F),X,GB)-V-After-B :- - macro_arg_functor(F,X,GB)-V-After-B. -macro_arg(vector(Vec),A,g)-V-After-B :- vector(Vec,N) | - A = variable(V), V += 1, - After <= functor(vector(A,integer(N))), - macro_vec_elems(0,N,A,Vec)-V-After. -macro_arg(vector(Vec0),A,b)-V-After-B :- vector(Vec0,N) | - A = vector(Vec), - macro_vector_elems(Vec0,Vec,0,N)-V-After-B. - -macro_arg_n([])-V-After-B+GB. -macro_arg_n([.(H0,H)|T])-V-After-B+GB :- - macro_arg(H0,H,GB)-V-After-B, - macro_arg_n(T)-V-After-B+GB. - - % ---- MACRO VECTOR ---- - - macro_vector_elems(Vec0,Vec,M,N)-V-After-B :- M>=N | Vec=Vec0. - macro_vector_elems(Vec0,Vec,M,N)-V-After-B :- M=N | true. - macro_vec_elems(K,N,A,Vec)-V+After0+After :- - K=N | + Vec = Vec0. + macro_vector_elems( Vec0, Vec, M, N )-V-After-B :- M=N | + true. + macro_vec_elems( K, N, A, Vec )-V+After0+After :- K= #"a", C =< #"z" | - T1 := T*B + C - #"a" + 10, - macro_N_10(N,B,T1,A). -macro_N_10([C|N],B,T,A):- C >= #"A", C =< #"Z" | - T1 := T*B + C - #"A" + 10, - macro_N_10(N,B,T1,A). -macro_N_10([C|N],B,T,A):- C >= #"0", C =< #"9" | - T1 := T*B + C - #"0", - macro_N_10(N,B,T1,A). -macro_N_10([],_B,T,A) :- A = T. +macro_arg_functor_sharp( atom( predicate ), + functor( atom( Module ):functor( atom( Pred )/integer( Arity ))), + X, _GB )-V-After-B :- + X = predicate( Module, Pred, Arity ). +macro_arg_functor_sharp( atom( c ), string( A ), X, _GB )-V-After-B :- + string( A, 1, _ ) | + string_element( A, 0, E ), X = integer( E ). +macro_arg_functor_sharp( atom( key ), atom( lf ), X, _GB )-V-After-B :- + X = integer( 10 ). +macro_arg_functor_sharp( atom( key ), atom( cr ), X, _GB )-V-After-B :- + X = integer( 13 ). +macro_arg_functor_sharp( integer( N ), string( S ), X, _GB )-V-After-B :- + klic_comp_util:string_to_char_list( S, L ), + X = integer( A ), macro_N_10( L, N, 0, A ). +macro_arg_functor_sharp( N, vector( Val ), X, _GB )-V-After-B :- + X = N#vector( Val ). +macro_arg_functor_sharp( atom( string ), S, A, _GB )-V-After-B :- + S=string( Str ) | + A=S. +macro_arg_functor_sharp( atom( module ), atom( Mod ), A, b, V, VN )-After-B :- + VN := V+1, A = variable( V ), + B <= functor( + atom( generic ):functor( new( atom( module ), A, atom( Mod )))). +otherwise. +macro_arg_functor_sharp( P, Q, X, GB )-V-After-B :- + X = functor( PP # QQ ), + macro_arg_n( [.( P, PP ), .( Q, QQ )] )-V-After-B+GB. + +% B # [...] +macro_N_10( [C|N], B, T, A ):- #"a" =< C, C =< #"z" | + T1 := T*B + C - #"a" + 10, + macro_N_10( N, B, T1, A ). +macro_N_10( [C|N], B, T, A ):- #"A" =< C, C =< #"Z" | + T1 := T*B + C - #"A" + 10, + macro_N_10( N, B, T1, A ). +macro_N_10( [C|N], B, T, A ):- #"0" =< C, C =< #"9" | + T1 := T*B + C - #"0", + macro_N_10( N, B, T1, A ). +macro_N_10( [], _B, T, A ) :- + A = T. % ----- MACRO EXP ----- -macro_exp(T,Exp)-V-B :- (T=variable(N); T=integer(N)) | - Exp = T. -macro_exp(functor(Exp0),Exp)-V-B :- - macro_arith_op(Exp0,Ans), - macro_exp_1(Exp0,Exp)-V+Ans-B. -otherwise. -macro_exp(Exp0,Exp)-V-B :- - Exp = Exp0, - klic_comp_message:warning("Unknown term in expression: ~W",[Exp0]). +macro_exp( T, Exp )-V-B :- (T=variable( N ); T=integer( N )) | + Exp = T. +macro_exp( functor( Exp0 ), Exp )-V-B :- + macro_arith_op( Exp0, Ans ), + macro_exp_1( Exp0, Exp )-V+Ans-B. +otherwise. +macro_exp( Exp0, Exp )-V-B :- + Exp = Exp0, + klic_comp_message:warning( "Unknown term in expression: ~W", [Exp0] ). % MACRO ARITH OP - macro_arith_op(_+_,Ans) :- Ans = yes(add). - macro_arith_op(_-_,Ans) :- Ans = yes(subtract). - macro_arith_op(_*_,Ans) :- Ans = yes(multiply). - macro_arith_op(_/_,Ans) :- Ans = yes(divide). - macro_arith_op(_ mod _,Ans) :- Ans = yes(modulo). - macro_arith_op(_/\_,Ans) :- Ans = yes(and). - macro_arith_op(_\/_,Ans) :- Ans = yes(or). - macro_arith_op(_ xor _,Ans) :- Ans = yes(exclusive_or). - macro_arith_op(_>>_,Ans) :- Ans = yes(shift_right). - macro_arith_op(_<<_,Ans) :- Ans = yes(shift_left). - macro_arith_op(+_,Ans) :- Ans = yes(plus). - macro_arith_op(-_,Ans) :- Ans = yes(minus). - macro_arith_op(\(_),Ans) :- Ans = yes(complement). - macro_arith_op(int(_),Ans) :- Ans = fix. - otherwise. - macro_arith_op(_,Ans) :- Ans = no. - - macro_exp_1(Exp0,Exp,V0,V,yes(Op))-B :- - Exp = variable(V1), - klic_comp_util:univ(Exp0,[_|Args]), - macro_exp_args(Args,[Exp],XArgs,V0,V1)-B, - functor_table:(Goal=..[Op|XArgs]), - V := V1+1, - B <= functor(Goal). - macro_exp_1(Exp0,Exp,V0,V,fix)-B :- - Exp = variable(V1), - klic_comp_util:univ(Exp0,[_|Args]), - macro_float_args(Args,[Exp],XArgs,V0,V1)-B, - functor_table:(Goal=..[floating_point_to_integer|XArgs]), - V := V1+1, - B <= functor(Goal). - macro_exp_1(Exp0,Exp,V0,V,no )-B :- - Exp = functor(Exp0), V = V0, - klic_comp_message:warning("Unknown term in expression: ~W",[Exp]). - - macro_exp_args([],Tail,XArgs)-V-B :- - XArgs = Tail. - macro_exp_args([A|T0],Tail,XArgs)-V-B :- - XArgs = [X|T], - macro_exp(A,X)-V-B, - macro_exp_args(T0,Tail,T)-V-B. + macro_arith_op( _ + _, Ans ) :- Ans = yes( add ). + macro_arith_op( _ - _, Ans ) :- Ans = yes( subtract ). + macro_arith_op( _ * _, Ans ) :- Ans = yes( multiply ). + macro_arith_op( _ / _, Ans ) :- Ans = yes( divide ). + macro_arith_op( _ mod _, Ans ) :- Ans = yes( modulo ). + macro_arith_op( _ /\ _, Ans ) :- Ans = yes( and ). + macro_arith_op( _ \/ _, Ans ) :- Ans = yes( or ). + macro_arith_op( _ xor _, Ans ) :- Ans = yes( exclusive_or ). + macro_arith_op( _ >> _, Ans ) :- Ans = yes( shift_right ). + macro_arith_op( _ << _, Ans ) :- Ans = yes( shift_left ). + macro_arith_op( + _, Ans ) :- Ans = yes( plus ). + macro_arith_op( - _, Ans ) :- Ans = yes( minus ). + macro_arith_op( \( _ ), Ans ) :- Ans = yes( complement ). + macro_arith_op( int( _ ), Ans ) :- Ans = fix. + otherwise. + macro_arith_op( _ , Ans ) :- Ans = no. + + macro_exp_1( Exp0, Exp, V0, V, yes( Op ))-B :- + Exp = variable( V1 ), + klic_comp_util:univ( Exp0, [_|Args] ), + macro_exp_args( Args, [Exp], XArgs, V0, V1 )-B, + functor_table:( Goal=..[Op|XArgs] ), + V := V1+1, + B <= functor( Goal ). + macro_exp_1( Exp0, Exp, V0, V, fix )-B :- + Exp = variable( V1 ), + klic_comp_util:univ( Exp0, [_|Args] ), + macro_float_args( Args, [Exp], XArgs, V0, V1 )-B, + functor_table:( Goal=..[floating_point_to_integer|XArgs] ), + V := V1+1, + B <= functor( Goal ). + macro_exp_1( Exp0, Exp, V0, V, no )-B :- + Exp = functor( Exp0 ), + V = V0, + klic_comp_message:warning( "Unknown term in expression: ~W", [Exp] ). + + macro_exp_args( [], Tail, XArgs )-V-B :- + XArgs = Tail. + macro_exp_args( [A|T0], Tail, XArgs )-V-B :- + XArgs = [X|T], + macro_exp( A, X )-V-B, + macro_exp_args( T0, Tail, T )-V-B. % ----- MACRO FLOAT EXP ----- -macro_float_exp(T,Exp)-V-B :- (T=variable(N); T=float(N)) | - Exp = T. -macro_float_exp(functor(Exp0),Exp)-V-B :- - macro_float_op(Exp0,Ans), - macro_float_exp_1(Exp0,Exp)-V+Ans-B. -otherwise. -macro_float_exp(Exp0,Exp)-V-B :- - Exp = Exp0, - klic_comp_message: - warning("Unknown term in floating point expression: ~W",[Exp0]). +macro_float_exp( T, Exp )-V-B :- (T=variable( N ); T=float( N )) | + Exp = T. +macro_float_exp( functor( Exp0 ), Exp )-V-B :- + macro_float_op( Exp0, Ans ), + macro_float_exp_1( Exp0, Exp )-V+Ans-B. +otherwise. +macro_float_exp( Exp0, Exp )-V-B :- + Exp = Exp0, + klic_comp_message: + warning( "Unknown term in floating point expression: ~W", [Exp0] ). % MACRO ARITH OP - macro_float_op(_+_,Ans) :- Ans = yes(add). - macro_float_op(_-_,Ans) :- Ans = yes(subtract). - macro_float_op(_*_,Ans) :- Ans = yes(multiply). - macro_float_op(_/_,Ans) :- Ans = yes(divide). - macro_float_op(pow(_,_),Ans) :- Ans = yes(pow). - macro_float_op(sin(_),Ans) :- Ans = yes(sin). - macro_float_op(cos(_),Ans) :- Ans = yes(cos). - macro_float_op(tan(_),Ans) :- Ans = yes(tan). - macro_float_op(asin(_),Ans) :- Ans = yes(asin). - macro_float_op(acos(_),Ans) :- Ans = yes(acos). - macro_float_op(atan(_),Ans) :- Ans = yes(atan). - macro_float_op(sinh(_),Ans) :- Ans = yes(sinh). - macro_float_op(cosh(_),Ans) :- Ans = yes(cosh). - macro_float_op(tanh(_),Ans) :- Ans = yes(tanh). - macro_float_op(exp(_),Ans) :- Ans = yes(exp). - macro_float_op(log(_),Ans) :- Ans = yes(log). - macro_float_op(sqrt(_),Ans) :- Ans = yes(sqrt). - macro_float_op(ceil(_),Ans) :- Ans = yes(ceil). - macro_float_op(floor(_),Ans) :- Ans = yes(floor). - macro_float_op(float(_),Ans) :- Ans = new. - macro_float_op(+_,Ans) :- Ans = yes(plus). - macro_float_op(-_,Ans) :- Ans = yes(minus). - otherwise. - macro_float_op(_,Ans) :- Ans = no. - - macro_float_exp_1(Exp0,Exp,V0,V,yes(Op))-B :- - Exp = variable(V1), - klic_comp_util:univ(Exp0,[_|Args]), - macro_float_args(Args,[Exp],XArgs,V0,V1)-B, - functor_table:(Goal=..[Op|XArgs]), - V := V1+1, - B <= functor(atom(generic):functor(Goal)). - macro_float_exp_1(Exp0,Exp,V0,V,new)-B :- Exp0 = float(Expr) | - Exp = variable(V1), - macro_exp(Expr,Result,V0,V1)-B, - functor_table:(Goal=..[new,atom(float),Exp,Result]), - V := V1+1, - B <= functor(atom(generic):functor(Goal)). - macro_float_exp_1(Exp0,Exp,V0,V,no )-B :- - Exp = functor(Exp0), V = V0, - klic_comp_message:warning("Unknown term in expression: ~W",[Exp]). - - macro_float_args([],Tail,XArgs)-V-B :- - XArgs = Tail. - macro_float_args([A|T0],Tail,XArgs)-V-B :- - XArgs = [X|T], - macro_float_exp(A,X)-V-B, - macro_float_args(T0,Tail,T)-V-B. + macro_float_op( _ + _, Ans ) :- Ans = yes( add ). + macro_float_op( _ - _, Ans ) :- Ans = yes( subtract ). + macro_float_op( _ * _, Ans ) :- Ans = yes( multiply ). + macro_float_op( _ / _, Ans ) :- Ans = yes( divide ). + macro_float_op( pow( _, _ ), Ans ) :- Ans = yes( pow ). + macro_float_op( sin( _ ), Ans ) :- Ans = yes( sin ). + macro_float_op( cos( _ ), Ans ) :- Ans = yes( cos ). + macro_float_op( tan( _ ), Ans ) :- Ans = yes( tan ). + macro_float_op( asin( _ ), Ans ) :- Ans = yes( asin ). + macro_float_op( acos( _ ), Ans ) :- Ans = yes( acos ). + macro_float_op( atan( _ ), Ans ) :- Ans = yes( atan ). + macro_float_op( sinh( _ ), Ans ) :- Ans = yes( sinh ). + macro_float_op( cosh( _ ), Ans ) :- Ans = yes( cosh ). + macro_float_op( tanh( _ ), Ans ) :- Ans = yes( tanh ). + macro_float_op( exp( _ ), Ans ) :- Ans = yes( exp ). + macro_float_op( log( _ ), Ans ) :- Ans = yes( log ). + macro_float_op( sqrt( _ ), Ans ) :- Ans = yes( sqrt ). + macro_float_op( ceil( _ ), Ans ) :- Ans = yes( ceil ). + macro_float_op( floor( _ ), Ans ) :- Ans = yes( floor ). + macro_float_op( float( _ ), Ans ) :- Ans = new. + macro_float_op( + _, Ans ) :- Ans = yes( plus ). + macro_float_op( - _, Ans ) :- Ans = yes( minus ). + otherwise. + macro_float_op( _, Ans ) :- Ans = no. + + macro_float_exp_1( Exp0, Exp, V0, V, yes( Op ))-B :- + Exp = variable( V1 ), + klic_comp_util:univ( Exp0, [_|Args] ), + macro_float_args( Args, [Exp], XArgs, V0, V1 )-B, + functor_table:( Goal=..[Op|XArgs] ), + V := V1+1, + B <= functor( atom( generic ):functor( Goal )). + macro_float_exp_1( Exp0, Exp, V0, V, new )-B :- Exp0 = float( Expr ) | + Exp = variable( V1 ), + macro_exp( Expr, Result, V0, V1 )-B, + functor_table:( Goal=..[new, atom( float ), Exp, Result] ), + V := V1+1, + B <= functor( atom( generic ):functor( Goal )). + macro_float_exp_1( Exp0, Exp, V0, V, no )-B :- + Exp = functor( Exp0 ), V = V0, + klic_comp_message:warning( "Unknown term in expression: ~W", [Exp] ). + + macro_float_args( [], Tail, XArgs )-V-B :- + XArgs = Tail. + macro_float_args( [A|T0], Tail, XArgs )-V-B :- + XArgs = [X|T], + macro_float_exp( A, X )-V-B, + macro_float_args( T0, Tail, T )-V-B. diff -ruN klic-3.003-2002-01-22/compiler/main.kl1 klic-3.003-2002-01-23/compiler/main.kl1 --- klic-3.003-2002-01-22/compiler/main.kl1 Thu Dec 27 19:15:57 2001 +++ klic-3.003-2002-01-23/compiler/main.kl1 Wed Jan 23 13:45:56 2002 @@ -1,22 +1,24 @@ -% /* ---------------------------------------------------------- -% % (C)1993,1995 Institute for New Generation Computer Technology -% % (Read COPYRIGHT for detailed information.) +/* ---------------------------------------------------------- +% (C)1993,1995 Institute for New Generation Computer Technology +% (Read COPYRIGHT for detailed information.) % (C)1996, 1997, 1998, 1999 Japan Information Processing Development Center % (Read COPYRIGHT-JIPDEC for detailed information.) % ----------------------------------------------------------- */ :- module main. +:- public main/0. + % ------------- UNIX Interface --------- main :- - unix:argv(List), - kl1cmps(List,normal). + unix:argv( List ), + kl1cmps( List, normal ). -kl1cmps([File|Next],normal):- - klic_comp_kl1cmp:klcmp(File,Ans), - kl1cmps(Next,Ans)@lower_priority. -kl1cmps([],normal) :- unix:exit(0). +kl1cmps( [File | Next], normal ) :- + klic_comp_kl1cmp:klcmp( File, Ans ), + kl1cmps( Next, Ans )@lower_priority. +kl1cmps( [], normal ) :- + unix:exit( 0 ). otherwise. -kl1cmps(_,Ans) :- wait(Ans) | unix:exit(-1). - - +kl1cmps( _, Ans ) :- wait( Ans ) | + unix:exit( -1 ). diff -ruN klic-3.003-2002-01-22/compiler/msg.kl1 klic-3.003-2002-01-23/compiler/msg.kl1 --- klic-3.003-2002-01-22/compiler/msg.kl1 Thu Dec 27 19:15:58 2001 +++ klic-3.003-2002-01-23/compiler/msg.kl1 Wed Jan 23 13:53:38 2002 @@ -1,92 +1,95 @@ -/* ---------------------------------------------------------- -% (C)1993,1994,1995 Institute for New Generation Computer Technology -% (Read COPYRIGHT for detailed information.) +/* ---------------------------------------------------------- +% (C)1993,1994,1995 Institute for New Generation Computer Technology +% (Read COPYRIGHT for detailed information.) % (C)1996, 1997, 1998, 1999 Japan Information Processing Development Center % (Read COPYRIGHT-JIPDEC for detailed information.) ----------------------------------------------------------- */ :- module klic_comp_message. +% called in cmacro.kl1, insert.kl1, kl1cmp.kl1, +% macro.kl1, normalize.kl1, obj.kl1 +:- public report_eror/2, warning/2, see/2, tell/2, compilation_error/1. + % ----- REPORT ERROR ------ -report_error(Format,Args) :- - write_message(Format,Args,Status), - compilation_error(Status). -report_error(Format,Args)+Pool0+Pool :- - write_message(Format,Args,Status,Pool0,Pool), - compilation_error(Status). +report_error( Format, Args ) :- + write_message( Format, Args, Status ), + compilation_error( Status ). +report_error( Format, Args )+Pool0+Pool :- + write_message( Format, Args, Status, Pool0, Pool ), + compilation_error( Status ). % ----- WARNING ----- -warning(Format,Args) :- - write_message(Format,Args,_). -warning(Format,Args)-Pool :- - write_message(Format,Args,_)-Pool. +warning( Format, Args ) :- + write_message( Format, Args, _ ). +warning( Format, Args )-Pool :- + write_message( Format, Args, _ )-Pool. % ----- WRITE MESSAGE ----- -write_message(Format,Args,Status) :- - tell(user_error,Out), - klic_comp_obj:klicformat(Format,Args,Out,Out1), - Out1 = [#"\n"|Out2], - klic_comp_obj:flush(Status, Out2,[]). -write_message(Format,Args,Status)+Pool0+Pool :- - Pool0 = [empty(compiling_module,A), - empty(compiling_predicate,B)|Pool1], - write_message1(Format,Args,Status,A,B)+Pool1+Pool. - -write_message1(Format,Args,Status,yes,B)+Pool0+Pool :- - Pool0 = [get(compiling_module,Module), - put(compiling_module,Module,_)|Pool1], - tell(user_error,Out), - klic_comp_obj:klicformat("In ~w:", [Module],Out,Out1), - write_message2(Format,Args,Status,B)+Pool1+Pool+Out1+[]. -write_message1(Format,Args,Status,no, B)-Pool :- - tell(user_error,Out), - write_message2(Format,Args,Status,B)-Pool+Out+[]. - -write_message2(Format,Args,Status,yes)+Pool0+Pool-Out :- - Pool0 = [get(compiling_predicate,Pred), - put(compiling_predicate,Pred,_)|Pool], - klic_comp_obj:klicformat("~w: ",[Pred])-Out, - klic_comp_obj:klicformat(Format,Args)-Out, - Out <= #"\n", - klic_comp_obj:flush(Status)-Out. -write_message2(Format,Args,Status,no )+Pool0+Pool-Out :- - Pool0 = Pool, - klic_comp_obj:klicformat(Format,Args)-Out, - Out <= #"\n", - klic_comp_obj:flush(Status)-Out. - -compilation_error :- - klic_comp_obj:flush(user_error,Status), - compilation_error(Status). +write_message( Format, Args, Status ) :- + tell( user_error, Out ), + klic_comp_obj:klicformat( Format, Args, Out, Out1 ), + Out1 = [#"\n"|Out2], + klic_comp_obj:flush( Status, Out2, [] ). +write_message( Format, Args, Status )+Pool0+Pool :- + Pool0 = [empty( compiling_module, A ), + empty( compiling_predicate, B )|Pool1], + write_message1( Format, Args, Status, A, B )+Pool1+Pool. + +write_message1( Format, Args, Status, yes, B )+Pool0+Pool :- + Pool0 = [get( compiling_module, Module ), + put( compiling_module, Module, _ )|Pool1], + tell( user_error, Out ), + klic_comp_obj:klicformat( "In ~w:", [Module], Out, Out1 ), + write_message2( Format, Args, Status, B )+Pool1+Pool+Out1+[]. +write_message1( Format, Args, Status, no, B )-Pool :- + tell( user_error, Out ), + write_message2( Format, Args, Status, B )-Pool+Out+[]. + +write_message2( Format, Args, Status, yes )+Pool0+Pool-Out :- + Pool0 = [get( compiling_predicate, Pred ), + put( compiling_predicate, Pred, _ )|Pool], + klic_comp_obj:klicformat( "~w: ", [Pred] )-Out, + klic_comp_obj:klicformat( Format, Args )-Out, + Out <= #"\n", + klic_comp_obj:flush( Status )-Out. +write_message2( Format, Args, Status, no )+Pool0+Pool-Out :- + Pool0 = Pool, + klic_comp_obj:klicformat( Format, Args )-Out, + Out <= #"\n", + klic_comp_obj:flush( Status )-Out. + +compilation_error :- + klic_comp_obj:flush( user_error, Status ), + compilation_error( Status ). -compilation_error(Status) :- wait(Status) | - unix:exit(-1). +compilation_error( Status ) :- wait( Status ) | + unix:exit( -1 ). %%%%% 2.1 'tell' - tell(user_error,OutStream) :- - unix:unix([stderr(normal(OutStream))]). + tell( user_error, OutStream ) :- + unix:unix( [stderr( normal( OutStream ) )] ). otherwise. - tell(OutFile,OutStream) :- - unix:unix([write_open(OutFile,OutQ)]), - tell1(OutFile,OutQ,OutStream). + tell( OutFile, OutStream ) :- + unix:unix( [write_open( OutFile, OutQ )] ), + tell1( OutFile, OutQ, OutStream ). -tell1(_OutFile,normal(Out),OutStream) :- - OutStream = normal(Out). +tell1( _OutFile, normal( Out ), OutStream ) :- + OutStream = normal( Out ). otherwise. -tell1(OutFile,R,OutStream) :- - OutStream = R, - klic_comp_obj:klicformat_stderr("Cannot open ~s!!\n",[OutFile]). +tell1( OutFile, R, OutStream ) :- + OutStream = R, + klic_comp_obj:klicformat_stderr( "Cannot open ~s!!\n", [OutFile] ). %%%%% 2.2 'see' - see(InFile,InStream) :- - klicio:klicio([read_open(InFile,InQ)]), - see_2(InFile,InQ,InStream). - - see_2(_InFile,normal(In0),InStream) :- - In0=[on_error(-1)|In], - InStream = normal(In). + see( InFile, InStream ) :- + klicio:klicio( [read_open( InFile, InQ )] ), + see_2( InFile, InQ, InStream ). + + see_2( _InFile, normal( In0 ), InStream ) :- + In0 = [on_error( -1 )|In], + InStream = normal( In ). otherwise. - see_2(InFile,R,InStream) :- - InStream = R, - klic_comp_obj:klicformat_stderr("~s does not exist !!\n",[InFile]). - + see_2( InFile, R, InStream ) :- + InStream = R, + klic_comp_obj:klicformat_stderr( "~s does not exist !!\n", [InFile] ). diff -ruN klic-3.003-2002-01-22/compiler/normalize.kl1 klic-3.003-2002-01-23/compiler/normalize.kl1 --- klic-3.003-2002-01-22/compiler/normalize.kl1 Sat Dec 29 12:46:20 2001 +++ klic-3.003-2002-01-23/compiler/normalize.kl1 Wed Jan 23 15:30:26 2002 @@ -1,10 +1,10 @@ -% /* ---------------------------------------------------------- -% % (C)1993, 1994, 1995 Institute for New Generation Computer Technology -% % (Read COPYRIGHT for detailed information.) +/* ---------------------------------------------------------- +% (C)1993, 1994, 1995 Institute for New Generation Computer Technology +% (Read COPYRIGHT for detailed information.) % (C)1996, 1997, 1998, 1999 Japan Information Processing Development Center % (Read COPYRIGHT-JIPDEC for detailed information.) % ----------------------------------------------------------- */ -% + % referred from klic_comp_kl1cmp. % % referring modules. @@ -13,738 +13,793 @@ :- module klic_comp_normalize. -% generate( +, +, -, -, +, -) -generate(Name/Arty,Clauses,Works,Info0,Info,Code)-Pool :- - separate_cond(Clauses,Cond,Ans)-Pool, - klic_comp_insert:make_index_tree(Cond,[],e,Tree,Name/Arty), - make_arg_assoc(0,Arty,AL), - klic_comp_generate:gen_code(Tree,interrupt,lab(_Top),AL,0, - Works,0,_,0,_,Info0,Info,Code,[]). - -make_arg_assoc(K,N,AL) :- K>=N | AL = []. -make_arg_assoc(K,N,AL0) :- K=N | + AL = []. +make_arg_assoc( K, N, AL0 ) :- K=N | true. -norm_args(K,N,F,Fid)-Vars-C :- K - klic_comp_util:append(Y0,Rest,Y), - klic_comp_util:append(CC,CCYT,CCY), - norm_guard(Y,Vars0,B,CCY,CT1,CT,CCYT,Ans)-P - ; Ans0\=normal -> Ans=Ans0 ). -otherwise. -norm_guard([],Vars,B,CC,Clauses,CT,Cond,Ans)-P :- - Clauses = [CC-Body|CT], Cond = [], - norm_body(B,Body,Vars,Ans)-P. -norm_guard([Guard|Rest],Vars0,B,CC,C,CT,CCT,Ans)-P :- - ( Guard=functor(One); Guard=atom(One) ) | - norm_guard_goal(One,Ans0,Vars0,Vars,CCT,CCT1)-P, - ( Ans0=normal -> - norm_guard(Rest,Vars,B,CC,C,CT,CCT1,Ans)-P - ; Ans0\=normal -> Ans=Ans0 ). +% atomic % any atomic value +% functor % any functor -% ----- Norm Guard Goal ----- -norm_guard_goal(X=Y,Ans)-Vars-CCT-P :- - norm_guard_unify(X,Y,Ans)-Vars-CCT-P. -norm_guard_goal(atom(generic):G,Ans)-Vars-CCT-P :- - norm_guard_generic(G)-Vars+Ans-CCT-P. -norm_guard_goal(atom(inline):Format0,Ans)-Vars-CCT-P :- - ( Format0=functor(Format:Args0) -> - norm_inline(Args0,Args,Args,[],Format,Ans)-Vars-CCT-P - ; otherwise ; true -> - norm_inline(atom([]),Args,Args,[],Format0,Ans)-Vars-CCT-P ). -otherwise. -norm_guard_goal(X,Ans)-Vars-CCT-P :- - klic_comp_gb:is_guard_builtin(X,Ans0), - ( Ans0=yes(Blts) -> - norm_guard_builts(Blts)-Vars+Ans-CCT-P - ; Ans0=no(XX) -> - klic_comp_message:report_error("Unrecognized guard goal: ~w",[XX])-P - ). - - norm_inline(atom([]),Args0,Args,Info,Format,Ans)-Vars-CCT-P :- - Args0 = [], CCT <= il(Format,Args,Info), Ans=normal. - norm_inline(list([A0|Rest0]),Args0,Args,Info0,Format,Ans)-Vars-CCT-P :- - Args0 = [A|Rest], - norm_inline_arg(A0,A,Ans0,Info0,Info)-Vars-CCT-P, - ( Ans0=normal -> - norm_inline(Rest0,Rest,Args,Info,Format,Ans)-Vars-CCT-P - ; Ans0\=normal-> Ans=Ans0 ). - - norm_inline_arg(functor(variable(K)+Type0),A,Ans,Info0,Info,Vars0,Vars) - -CCT-P :- - A = +X, Info = Info0, Vars = Vars0, - inline_arg_type(Type0,Type), - norm_gblt_arg(variable(K),Type,X,Vars,Ans)-CCT-P. - norm_inline_arg(functor(variable(K)-Type0),A,Ans,Info0,Info,Vars0,Vars) - +CCT0+CCT-P :- - A = -var(K), Info = [K:Type|Info0],Vars = [K=var(K)|Vars0], CCT = CCT0, - klic_comp_util:assoc(Vars0,K,AssocAns), - inline_arg_type(Type0,Type), - norm_inline_arg_1(AssocAns,Vars0,K,Type,Ans)-P. -otherwise. - norm_inline_arg(Arg,_X,Ans,_Info0,_Info,_Vars0,_Vars)-CCT-P :- - _Info = _Info0, - klic_comp_message:warning("Invalid argument to inline: ~w",[Arg])-P, - Ans=abnormal. - - norm_inline_arg_1(yes(_),Vars0,K,Type,Ans)-P :- - Arg = variable(K)-Type, - klic_comp_message:warning( - "Non-first variable occurrence as inline output: ~w",[Arg])-P, - Ans=abnormal. - norm_inline_arg_1(no,Vars0,K,Type,Ans)-P :- - Ans=normal. - - inline_arg_type(atom(T0), T) :- T=T0. - inline_arg_type(functor(F0), F) :- - functor(F0,P,1), arg(1,F0,A0) | - inline_arg_type(A0,A), - functor_table:(F=..[P,A]). - inline_arg_type(functor(F0), F) :- - functor(F0,P,2), arg(1,F0,A0), arg(1,F0,B0) | - inline_arg_type(A0,A), inline_arg_type(B0,B), - functor_table:(F=..[P,A,B]). - -% Norm Guard Unify -norm_guard_unify(Const,Const,Ans)-Vars-CCT-P :- Ans=normal. -otherwise. -norm_guard_unify(variable(K),X,Ans)-Vars-CCT-P :- - klic_comp_util:assoc(Vars,K,AssocAns), - ( AssocAns=yes(Pos) -> - ( Pos=rename(J) -> - norm_guard_unify(variable(J),X,Ans)-Vars-CCT-P - ; otherwise ; true -> - Ans = normal, - norm_guard_term(X,Pos)-Vars-CCT ) - ; AssocAns=no -> - Ans = normal, - norm_guard_unify_new(X,K)-Vars-P ). -norm_guard_unify(list([HX|TX]),list([HY|TY]),Ans)-Vars-CCT-P :- - norm_guard_unify(HX,HY,Ans0)-Vars-CCT-P, - ( Ans0=normal -> - norm_guard_unify(TX,TY,Ans)-Vars-CCT-P - ; Ans0\=normal -> Ans=Ans0 ). -norm_guard_unify(functor(X),functor(Y),Ans)-Vars-CCT-P :- - functor(X,F,A), functor(Y,F,A) | - klic_comp_util:univ(X,LX), - klic_comp_util:univ(Y,LY), - norm_guard_unify_args(LX,LY)-Vars+normal+Ans-CCT-P. -norm_guard_unify(vector(X), vector(Y), Ans)-Vars-CCT-P :- - vector(X,N), vector(Y,N) | - klic_comp_util:vector_to_list(X,LX), - klic_comp_util:vector_to_list(Y,LY), - norm_guard_unify_args(LX,LY)-Vars+normal+Ans-CCT-P. -otherwise. -norm_guard_unify(X,variable(K),Ans)-Vars-CCT-P :- - norm_guard_unify(variable(K),X,Ans)-Vars-CCT-P. -otherwise. -norm_guard_unify(X,Y,Ans)-Vars-CCT-P :- - klic_comp_message:warning("Unification always fails: ~w=~w",[X,Y])-P, - Ans=abnormal. +norm_head( atom( H ))-Vars-Cond. +norm_head( functor( H ))-Vars-Cond :- functor( H, _, NA ) | + norm_args( 0, NA, H, head )-Vars-Cond. + +norm_args( K, N, _, _ )-Vars-C :- K>=N | + true. +norm_args( K, N, F, Fid )-Vars-C :- K + klic_comp_util:append( Y0, Rest, Y ), + klic_comp_util:append( CC, CCYT, CCY ), + norm_guard( Y, Vars0, B, CCY, CT1, CT, CCYT, Ans )-P + ; Ans0\=normal -> + Ans=Ans0 ). +otherwise. +norm_guard( [], Vars, B, CC, Clauses, CT, Cond, Ans )-P :- + Clauses = [CC-Body|CT], Cond = [], + norm_body( B, Body, Vars, Ans )-P. +norm_guard( [Guard|Rest], Vars0, B, CC, C, CT, CCT, Ans )-P :- + ( Guard=functor( One ); Guard=atom( One )) | + norm_guard_goal( One, Ans0, Vars0, Vars, CCT, CCT1 )-P, + ( Ans0=normal -> norm_guard( Rest, Vars, B, CC, C, CT, CCT1, Ans )-P + ; Ans0\=normal -> Ans=Ans0 ). - norm_guard_unify_new(variable(K),J,Vars0,Vars)-P :- - klic_comp_util:assoc(Vars0,K,Ans), - ( Ans=yes(Pos) -> Vars=[J=Pos|Vars0] - ; Ans=no -> Vars=[J=rename(K)|Vars0] ). - norm_guard_unify_new(T,J,Vars,Vars1)-P :- - (T=atom(X); T=float(X); T=predicate(M,F,A)) | - Vars1 = [J=T|Vars]. - norm_guard_unify_new(T,J,Vars,Vars1)-P :- T=integer(X) | - Vars1 = [J=int(X)|Vars]. +% ----- Norm Guard Goal ----- +norm_guard_goal( X=Y, Ans )-Vars-CCT-P :- + norm_guard_unify( X, Y, Ans )-Vars-CCT-P. +norm_guard_goal( atom( generic ):G, Ans )-Vars-CCT-P :- + norm_guard_generic( G )-Vars+Ans-CCT-P. +norm_guard_goal( atom( inline ):Format0, Ans )-Vars-CCT-P :- + ( Format0=functor( Format:Args0 ) -> + norm_inline( Args0, Args, Args, [], Format, Ans )-Vars-CCT-P + ; otherwise ; true -> + norm_inline( atom( [] ), Args, Args, [], Format0, Ans )-Vars-CCT-P ). +otherwise. +norm_guard_goal( X, Ans )-Vars-CCT-P :- + klic_comp_gb:is_guard_builtin( X, Ans0 ), + ( Ans0=yes( Blts ) -> + norm_guard_builts( Blts )-Vars+Ans-CCT-P + ; Ans0=no( XX ) -> + klic_comp_message:report_error( "Unrecognized guard goal: ~w", [XX] )-P + ). + + norm_inline( atom( [] ), Args0, Args, Info, Format, Ans )-Vars-CCT-P :- + Args0 = [], CCT <= il( Format, Args, Info ), Ans=normal. + norm_inline( list( [A0|Rest0] ), Args0, Args, Info0, Format, Ans ) + -Vars-CCT-P :- + Args0 = [A|Rest], + norm_inline_arg( A0, A, Ans0, Info0, Info )-Vars-CCT-P, + ( Ans0=normal -> + norm_inline( Rest0, Rest, Args, Info, Format, Ans )-Vars-CCT-P + ; Ans0\=normal -> + Ans=Ans0 ). + + norm_inline_arg( functor( variable( K )+Type0 ), + A, Ans, Info0, Info, Vars0, Vars )-CCT-P :- + A = +X, + Info = Info0, + Vars = Vars0, + inline_arg_type( Type0, Type ), + norm_gblt_arg( variable( K ), Type, X, Vars, Ans )-CCT-P. + norm_inline_arg( functor( variable( K )-Type0 ), + A, Ans, Info0, Info, Vars0, Vars )+CCT0+CCT-P :- + A = -var( K ), + Info = [K:Type|Info0], + Vars = [K=var( K )|Vars0], + CCT = CCT0, + klic_comp_util:assoc( Vars0, K, AssocAns ), + inline_arg_type( Type0, Type ), + norm_inline_arg_1( AssocAns, Vars0, K, Type, Ans )-P. otherwise. - norm_guard_unify_new(X,_J)-Vars-P :- - klic_comp_message:report_error( - "Structure allocation not allowed in guard: ~w", [X])-P. - -norm_guard_unify_args([],_)-Vars-Ans-CCT-P. -norm_guard_unify_args([HX|TX],[HY|TY])-Vars+Ans0+Ans-CCT-P :- Ans0\=normal | - Ans=Ans0. -norm_guard_unify_args([HX|TX],[HY|TY])-Vars+Ans0+Ans-CCT-P :- Ans0=normal | - norm_guard_unify(HX,HY,Ans1)-Vars-CCT-P, - norm_guard_unify_args(TX,TY)-Vars+Ans1+Ans-CCT-P. - -% ----- NORM GUARD GENERIC ----- -norm_guard_generic(G0,Vars0,Vars,Ans)-CCT-P :- - norm_gg_in_out(G0,Funct,Obj0,In0,NumOuts,Out,Ans0), - norm_guard_generic_1(G0,Vars0,Vars,Ans,Funct,Obj0,In0,NumOuts,Out,Ans0) - -CCT-P. - -norm_guard_generic_1(G0,Vars0,Vars,Ans,Funct,Obj0,In0,NumOuts,Out,Ans00) - -CCT-P :- Ans00=normal | - norm_gg_in(Obj0,object,Obj,Vars0,Ans0)-CCT-P, - norm_guard_generic_2(In0,In,Vars0,Vars,Ans,Funct,Obj,NumOuts,Out,Ans0) - -CCT-P. -norm_guard_generic_1(G0,Vars0,Vars,Ans,Funct,Obj0,In0,NumOuts,Out,Ans00) - -CCT-P :- Ans00\=normal | - Ans=Ans00. - -norm_guard_generic_2(In0,In,Vars0,Vars,Ans,Funct,Obj,NumOuts,Out,Ans00) - -CCT-P :- Ans00=normal | - norm_gg_ins(In0,In,Vars0,Ans0)-CCT-P, - norm_guard_generic_3(Ans0,In,Vars0,Vars,Ans,Funct,Obj,NumOuts,Out)-CCT-P. -norm_guard_generic_2(In0,In,Vars0,Vars,Ans,Funct,Obj,NumOuts,Out,Ans00) - -CCT-P :- Ans00\=normal | - Ans=Ans00. - -norm_guard_generic_3(Ans0,In,Vars0,Vars,Ans,Funct,Obj,NumOuts,Out) - -CCT-P :- Ans0=normal | - Call=gg(Funct,Obj,In), - CCT <= gg(Call,NumOuts), - klic_comp_util:length(In,Nin), - norm_gg_outs(Out,Nin,Call,Vars0,Vars)-CCT-P, - Ans=normal. -norm_guard_generic_3(Ans0,In,Vars0,Vars,Ans,Funct,Obj,NumOuts,Out) - -CCT-P :- Ans0\=normal | - Ans=Ans0. - -norm_gg_in_out(functor(Goal:Out0),Funct,Obj,In,NumO,Outs,Ans) :- - norm_gg_count_out(Out0,Outs,0,NumO), - norm_gg(Goal,Funct,Obj,In,Ans). -otherwise. -norm_gg_in_out(Goal,Funct,Obj,In,NumO,Outs,Ans) :- - NumO = 0, Outs = [], - norm_gg(Goal,Funct,Obj,In,Ans). - -norm_gg_count_out(functor(One:Rest0),Outs,N0,N) :- - Outs = [One|Rest], - N1 := N0+1, - norm_gg_count_out(Rest0,Rest,N1,N). -otherwise. -norm_gg_count_out(Last,Outs,N0,N) :- - Outs = [Last], - N := N0+1. - -norm_gg(functor(Goal),Funct,Obj,In,Ans) :- functor(Goal,F0,A0) | - Funct = F/A, - norm_gg_1(F,A,Obj,In,Goal,F0,A0,Ans). -otherwise. -norm_gg(_,_Funct,_Obj,_In,Ans) :- Ans = abnormal. - -norm_gg_1(F,A,Obj,In,Goal,generic,2,Ans) :- - arg(1,Goal,Obj), arg(2,Goal,Term), - norm_gg_2(F,A,Obj,In,Term,Ans). -otherwise. -norm_gg_1(F,A,Obj,In,Goal,F0,A0,Ans) :- - F=F0, A=A0, Ans = normal, - klic_comp_util:univ(Goal,[_,Obj|In]). - -norm_gg_2(F,A,Obj,In,functor(Term),Ans) :- functor(Term,F0,A0) | - F = F0, A = A0, Ans = normal, - klic_comp_util:univ(Term,[_|In]). -otherwise. -norm_gg_2(F,A,Obj,In,_Term,Ans) :- Ans = abnormal. - -norm_gg_ins([],In,_,Ans)-CCT-P :- - In = [], Ans=normal. -norm_gg_ins([In0|Ins0],In1,Vars,Ans)-CCT-P :- - In1 = [In|Ins], - norm_gg_in(In0,bound,In,Vars,Ans0)-CCT-P, - norm_gg_ins_1(Ins0,Ins,Vars,Ans,Ans0)-CCT-P. - -norm_gg_ins_1(Ins0,Ins,Vars,Ans,Ans0)-CCT-P :- Ans0=normal | - norm_gg_ins(Ins0,Ins,Vars,Ans)-CCT-P. -norm_gg_ins_1(Ins0,Ins,Vars,Ans,Ans0)-CCT-P :- Ans0\=normal | - Ans=Ans0. - -norm_gg_in(variable(K),Type,In,Vars,Ans)-CCT-P :- - klic_comp_util:assoc(Vars,K,AssocAns), - norm_gg_in_1(K,Type,In,Vars,Ans,AssocAns)-CCT-P. -otherwise. -norm_gg_in(C0,Type,C,_Vars,Ans)-CCT-P :- - is_const(C0,C,_Type,yes,IsAns), - norm_gg_in_2(C0,Type,Ans,IsAns)-CCT-P. - -norm_gg_in_1(K,Type,In,Vars,Ans,yes(rename(J)))-CCT-P :- - norm_gg_in(variable(J),Type,In,Vars,Ans)-CCT-P. -norm_gg_in_1(K,Type,In,Vars,Ans,no)-CCT-P :- - klic_comp_message:warning("Never proceeding guard generic call", [])-P, - Ans=abnormal. -otherwise. -norm_gg_in_1(K,Type,In,Vars,Ans,yes(Value))-CCT-P :- - In=Value, CCT <= (Value:Type), Ans=normal. - -norm_gg_in_2(C0,object, Ans,yes)-CCT-P :- - klic_comp_message:warning("Non-object given as generic call arg: ~w", - [C0])-P, - Ans=normal. -norm_gg_in_2(C0,object(_),Ans,yes)-CCT-P :- - klic_comp_message:warning("Non-object given as generic call arg: ~w", - [C0])-P, - Ans=normal. -norm_gg_in_2(C0,Type,Ans,no)-CCT-P :- - klic_comp_message:warning( - "Non-const structure in guard generic call arg: ~w", [C0])-P, - Ans=abnormal. -otherwise. -norm_gg_in_2(C0,_ ,Ans,yes)-CCT-P :- - Ans=normal. - -norm_gg_outs([],_,_,Vars0,Vars)+CCT0+CCT+P0+P :- - Vars = Vars0, CCT = CCT0, P = P0. -norm_gg_outs([Out|Outs],K,Call,Vars0,Vars)-CCT-P :- - norm_guard_term(Out,gg(Call,K),Vars0,Vars1)-CCT, - K1 := K+1, - norm_gg_outs(Outs,K1,Call,Vars1,Vars)-CCT-P. - -norm_guard_builts([],Vars0,Vars,Ans)-CCT-P :- - Vars = Vars0, Ans=normal. -norm_guard_builts([$(In,Out,PredName)|Blts],Vars0,Vars,Ans)-CCT-P :- - norm_gblt_args(In,Inputs,Vars0,Ans0)-CCT-P, - norm_guard_builts_1(Blts,Vars0,Vars,Ans,Out,PredName,Inputs,Ans0)-CCT-P. - -norm_guard_builts_1(Blts,Vars0,Vars,Ans,Out,PredName,Inputs,Ans0)-CCT-P :- - Ans0=normal, Out = none | - functor_table:(Call=..[PredName|Inputs]), - CCT <= gp(Call), - norm_guard_builts(Blts,Vars0,Vars,Ans)-CCT-P. -norm_guard_builts_1(Blts,Vars0,Vars,Ans,Out,PredName,Inputs,Ans0)-CCT-P :- - Ans0=normal, Out = (O:OType) | - functor_table:(Call=..[PredName|Inputs]), - CCT <= gb(Call,OType), - norm_guard_term(O,gb(Call),Vars0,Vars1)-CCT, - norm_guard_builts(Blts,Vars1,Vars,Ans)-CCT-P. -norm_guard_builts_1(Blts,Vars0,Vars,Ans,Out,PredName,Inputs,Ans0)-CCT-P :- - Ans0\=normal | - Ans=Ans0. - -norm_gblt_args([],Inputs,_Vars,Ans)-CCT-P :- - Inputs = [], Ans=normal. -norm_gblt_args([X0:Type|T],Inputs,Vars,Ans)-CCT-P :- - Inputs = [X|VT], - norm_gblt_arg(X0,Type,X,Vars,Ans0)-CCT-P, - norm_gblt_args_1(T,VT,Vars,Ans,Ans0)-CCT-P. - -norm_gblt_args_1(T,VT,Vars,Ans,Ans0)-CCT-P :- Ans0=normal | - norm_gblt_args(T,VT,Vars,Ans)-CCT-P. -norm_gblt_args_1(T,VT,Vars,Ans,Ans0)-CCT-P :- Ans0\=normal | - Ans=Ans0. - -norm_gblt_arg(variable(K),Type,Pos,Vars,Ans)-CCT-P :- - klic_comp_util:assoc(Vars,K,AAns), - norm_gblt_arg_1(K,Type,Pos,Vars,Ans,AAns)-CCT-P. -otherwise. -norm_gblt_arg(C0,Type,C,_Vars,Ans)-CCT-P :- - is_const(C0,C,Type0,yes,CAns), - norm_gblt_arg_2(CAns,Type,C,Type0,Ans,C0)-P. - -norm_gblt_arg_1(K,Type,Pos,Vars,Ans,yes(rename(J)))-CCT-P :- - norm_gblt_arg(variable(J),Type,Pos,Vars,Ans)-CCT-P. -otherwise. -norm_gblt_arg_1(K,Type,Pos,Vars,Ans,yes(Value))-CCT-P :- - Pos = Value, CCT <= (Value:Type), Ans=normal. -norm_gblt_arg_1(K,Type,Pos,Vars,Ans,no)-CCT-P :- - klic_comp_message:warning("Never proceeding guard builtin", [])-P, + norm_inline_arg( Arg, _X, Ans, _Info0, _Info, _Vars0, _Vars )-CCT-P :- + _Info = _Info0, + klic_comp_message:warning( "Invalid argument to inline: ~w", [Arg] )-P, Ans=abnormal. -norm_gblt_arg_2(yes,Type,C,Type0,Ans,C0)-P :- - klic_comp_insert:subsumed_type(Type0,Type,SAns), - check_gblt_input(SAns,Ans,C0)-P. -norm_gblt_arg_2(no ,Type,C,Type0,Ans,C0)-P :- - klic_comp_message:warning( - "Non-const structure in guard builtin arg: ~w", [C0])-P, - Ans=abnormal. - -check_gblt_input(Ans0,Ans,_)-P :- Ans0=normal | Ans=Ans0. -check_gblt_input(Ans0,Ans,C)-P :- Ans0\=normal | - klic_comp_message:warning("Guard builtin arg type mismatch: ~w", [C])-P, - Ans=Ans0. + norm_inline_arg_1( yes( _ ), Vars0, K, Type, Ans )-P :- + Arg = variable( K )-Type, + klic_comp_message:warning( + "Non-first variable occurrence as inline output: ~w", [Arg] )-P, + Ans=abnormal. + norm_inline_arg_1( no, Vars0, K, Type, Ans )-P :- + Ans=normal. + + inline_arg_type( atom( T0 ), T ) :- + T=T0. + inline_arg_type( functor( F0 ), F ) :- + functor( F0, P, 1 ), arg( 1, F0, A0 ) | + inline_arg_type( A0, A ), + functor_table:( F=..[P, A] ). + inline_arg_type( functor( F0 ), F ) :- + functor( F0, P, 2 ), arg( 1, F0, A0 ), arg( 1, F0, B0 ) | + inline_arg_type( A0, A ), inline_arg_type( B0, B ), + functor_table:( F=..[P, A, B] ). + +% Norm Guard Unify +norm_guard_unify( Const, Const, Ans )-Vars-CCT-P :- + Ans=normal. +otherwise. +norm_guard_unify( variable( K ), X, Ans )-Vars-CCT-P :- + klic_comp_util:assoc( Vars, K, AssocAns ), + ( AssocAns=yes( Pos ) -> + ( Pos=rename( J ) -> + norm_guard_unify( variable( J ), X, Ans )-Vars-CCT-P + ; otherwise ; true -> + Ans = normal, + norm_guard_term( X, Pos )-Vars-CCT ) + ; AssocAns=no -> + Ans = normal, + norm_guard_unify_new( X, K )-Vars-P ). +norm_guard_unify( list( [HX|TX] ), list( [HY|TY] ), Ans )-Vars-CCT-P :- + norm_guard_unify( HX, HY, Ans0 )-Vars-CCT-P, + ( Ans0=normal -> norm_guard_unify( TX, TY, Ans )-Vars-CCT-P + ; Ans0\=normal -> Ans=Ans0 ). +norm_guard_unify( functor( X ), functor( Y ), Ans )-Vars-CCT-P :- + functor( X, F, A ), functor( Y, F, A ) | + klic_comp_util:univ( X, LX ), + klic_comp_util:univ( Y, LY ), + norm_guard_unify_args( LX, LY )-Vars+normal+Ans-CCT-P. +norm_guard_unify( vector( X ), vector( Y ), Ans )-Vars-CCT-P :- + vector( X, N ), vector( Y, N ) | + klic_comp_util:vector_to_list( X, LX ), + klic_comp_util:vector_to_list( Y, LY ), + norm_guard_unify_args( LX, LY )-Vars+normal+Ans-CCT-P. +otherwise. +norm_guard_unify( X, variable( K ), Ans )-Vars-CCT-P :- + norm_guard_unify( variable( K ), X, Ans )-Vars-CCT-P. +otherwise. +norm_guard_unify( X, Y, Ans )-Vars-CCT-P :- + klic_comp_message:warning( "Unification always fails: ~w=~w", [X, Y] )-P, + Ans=abnormal. + + norm_guard_unify_new( variable( K ), J, Vars0, Vars )-P :- + klic_comp_util:assoc( Vars0, K, Ans ), + ( Ans=yes( Pos ) -> Vars=[J=Pos|Vars0] + ; Ans=no -> Vars=[J=rename( K )|Vars0] ). + norm_guard_unify_new( T, J, Vars, Vars1 )-P :- + ( T=atom( X ); T=float( X ); T=predicate( M, F, A )) | + Vars1 = [J=T|Vars]. + norm_guard_unify_new( T, J, Vars, Vars1 )-P :- T=integer( X ) | + Vars1 = [J=int( X )|Vars]. + otherwise. + norm_guard_unify_new( X, _J )-Vars-P :- + klic_comp_message:report_error( + "Structure allocation not allowed in guard: ~w", [X] )-P. + +norm_guard_unify_args( [], _ )-Vars-Ans-CCT-P. +norm_guard_unify_args( [HX|TX], [HY|TY] )-Vars+Ans0+Ans-CCT-P :- Ans0\=normal | + Ans=Ans0. +norm_guard_unify_args( [HX|TX], [HY|TY] )-Vars+Ans0+Ans-CCT-P :- Ans0=normal | + norm_guard_unify( HX, HY, Ans1 )-Vars-CCT-P, + norm_guard_unify_args( TX, TY )-Vars+Ans1+Ans-CCT-P. + +% ----- NORM GUARD GENERIC ----- +norm_guard_generic( G0, Vars0, Vars, Ans )-CCT-P :- + norm_gg_in_out( G0, Funct, Obj0, In0, NumOuts, Out, Ans0 ), + norm_guard_generic_1( + G0, Vars0, Vars, Ans, Funct, Obj0, In0, NumOuts, Out, Ans0 )-CCT-P. + +norm_guard_generic_1( + G0, Vars0, Vars, Ans, Funct, Obj0, In0, NumOuts, Out, Ans00 )-CCT-P :- + Ans00=normal | + norm_gg_in( Obj0, object, Obj, Vars0, Ans0 )-CCT-P, + norm_guard_generic_2( + In0, In, Vars0, Vars, Ans, Funct, Obj, NumOuts, Out, Ans0 )-CCT-P. +norm_guard_generic_1( + G0, Vars0, Vars, Ans, Funct, Obj0, In0, NumOuts, Out, Ans00 )-CCT-P :- + Ans00\=normal | + Ans=Ans00. + +norm_guard_generic_2( + In0, In, Vars0, Vars, Ans, Funct, Obj, NumOuts, Out, Ans00 )-CCT-P :- + Ans00=normal | + norm_gg_ins( In0, In, Vars0, Ans0 )-CCT-P, + norm_guard_generic_3( + Ans0, In, Vars0, Vars, Ans, Funct, Obj, NumOuts, Out )-CCT-P. +norm_guard_generic_2( + In0, In, Vars0, Vars, Ans, Funct, Obj, NumOuts, Out, Ans00 )-CCT-P :- + Ans00\=normal | + Ans=Ans00. + +norm_guard_generic_3( Ans0, In, Vars0, Vars, Ans, Funct, Obj, NumOuts, Out ) + -CCT-P :- Ans0=normal | + Call=gg( Funct, Obj, In ), + CCT <= gg( Call, NumOuts ), + klic_comp_util:length( In, Nin ), + norm_gg_outs( Out, Nin, Call, Vars0, Vars )-CCT-P, + Ans=normal. +norm_guard_generic_3( Ans0, In, Vars0, Vars, Ans, Funct, Obj, NumOuts, Out ) + -CCT-P :- Ans0\=normal | + Ans=Ans0. + +norm_gg_in_out( functor( Goal:Out0 ), Funct, Obj, In, NumO, Outs, Ans ) :- + norm_gg_count_out( Out0, Outs, 0, NumO ), + norm_gg( Goal, Funct, Obj, In, Ans ). +otherwise. +norm_gg_in_out( Goal, Funct, Obj, In, NumO, Outs, Ans ) :- + NumO = 0, Outs = [], + norm_gg( Goal, Funct, Obj, In, Ans ). + +norm_gg_count_out( functor( One:Rest0 ), Outs, N0, N ) :- + Outs = [One|Rest], + N1 := N0+1, + norm_gg_count_out( Rest0, Rest, N1, N ). +otherwise. +norm_gg_count_out( Last, Outs, N0, N ) :- + Outs = [Last], + N := N0+1. + +norm_gg( functor( Goal ), Funct, Obj, In, Ans ) :- functor( Goal, F0, A0 ) | + Funct = F/A, + norm_gg_1( F, A, Obj, In, Goal, F0, A0, Ans ). +otherwise. +norm_gg( _, _Funct, _Obj, _In, Ans ) :- + Ans = abnormal. + +norm_gg_1( F, A, Obj, In, Goal, generic, 2, Ans ) :- + arg( 1, Goal, Obj ), arg( 2, Goal, Term ), + norm_gg_2( F, A, Obj, In, Term, Ans ). +otherwise. +norm_gg_1( F, A, Obj, In, Goal, F0, A0, Ans ) :- + F=F0, A=A0, Ans = normal, + klic_comp_util:univ( Goal, [_, Obj|In] ). + +norm_gg_2( F, A, Obj, In, functor( Term ), Ans ) :- functor( Term, F0, A0 ) | + F = F0, A = A0, Ans = normal, + klic_comp_util:univ( Term, [_|In] ). +otherwise. +norm_gg_2( F, A, Obj, In, _Term, Ans ) :- + Ans = abnormal. + +norm_gg_ins( [], In, _, Ans )-CCT-P :- + In = [], Ans=normal. +norm_gg_ins( [In0|Ins0], In1, Vars, Ans )-CCT-P :- + In1 = [In|Ins], + norm_gg_in( In0, bound, In, Vars, Ans0 )-CCT-P, + norm_gg_ins_1( Ins0, Ins, Vars, Ans, Ans0 )-CCT-P. + +norm_gg_ins_1( Ins0, Ins, Vars, Ans, Ans0 )-CCT-P :- Ans0=normal | + norm_gg_ins( Ins0, Ins, Vars, Ans )-CCT-P. +norm_gg_ins_1( Ins0, Ins, Vars, Ans, Ans0 )-CCT-P :- Ans0\=normal | + Ans=Ans0. + +norm_gg_in( variable( K ), Type, In, Vars, Ans )-CCT-P :- + klic_comp_util:assoc( Vars, K, AssocAns ), + norm_gg_in_1( K, Type, In, Vars, Ans, AssocAns )-CCT-P. +otherwise. +norm_gg_in( C0, Type, C, _Vars, Ans )-CCT-P :- + is_const( C0, C, _Type, yes, IsAns ), + norm_gg_in_2( C0, Type, Ans, IsAns )-CCT-P. + +norm_gg_in_1( K, Type, In, Vars, Ans, yes( rename( J )))-CCT-P :- + norm_gg_in( variable( J ), Type, In, Vars, Ans )-CCT-P. +norm_gg_in_1( K, Type, In, Vars, Ans, no )-CCT-P :- + klic_comp_message:warning( "Never proceeding guard generic call", [] )-P, + Ans=abnormal. +otherwise. +norm_gg_in_1( K, Type, In, Vars, Ans, yes( Value ))-CCT-P :- + In=Value, CCT <= ( Value:Type ), Ans=normal. + +norm_gg_in_2( C0, object, Ans, yes )-CCT-P :- + klic_comp_message:warning( + "Non-object given as generic call arg: ~w", [C0] )-P, + Ans=normal. +norm_gg_in_2( C0, object( _ ), Ans, yes )-CCT-P :- + klic_comp_message:warning( + "Non-object given as generic call arg: ~w", [C0] )-P, + Ans=normal. +norm_gg_in_2( C0, Type, Ans, no )-CCT-P :- + klic_comp_message:warning( + "Non-const structure in guard generic call arg: ~w", [C0] )-P, + Ans=abnormal. +otherwise. +norm_gg_in_2( C0, _ , Ans, yes )-CCT-P :- + Ans=normal. + +norm_gg_outs( [], _, _, Vars0, Vars )+CCT0+CCT+P0+P :- + Vars = Vars0, CCT = CCT0, P = P0. +norm_gg_outs( [Out|Outs], K, Call, Vars0, Vars )-CCT-P :- + norm_guard_term( Out, gg( Call, K ), Vars0, Vars1 )-CCT, + K1 := K+1, + norm_gg_outs( Outs, K1, Call, Vars1, Vars )-CCT-P. + +norm_guard_builts( [], Vars0, Vars, Ans )-CCT-P :- + Vars = Vars0, Ans=normal. +norm_guard_builts( [$( In, Out, PredName )|Blts], Vars0, Vars, Ans )-CCT-P :- + norm_gblt_args( In, Inputs, Vars0, Ans0 )-CCT-P, + norm_guard_builts_1( + Blts, Vars0, Vars, Ans, Out, PredName, Inputs, Ans0 )-CCT-P. + +norm_guard_builts_1( + Blts, Vars0, Vars, Ans, Out, PredName, Inputs, Ans0 )-CCT-P :- + Ans0=normal, Out = none | + functor_table:( Call=..[PredName|Inputs] ), + CCT <= gp( Call ), + norm_guard_builts( Blts, Vars0, Vars, Ans )-CCT-P. +norm_guard_builts_1( + Blts, Vars0, Vars, Ans, Out, PredName, Inputs, Ans0 )-CCT-P :- + Ans0=normal, Out = ( O:OType ) | + functor_table:( Call=..[PredName|Inputs] ), + CCT <= gb( Call, OType ), + norm_guard_term( O, gb( Call ), Vars0, Vars1 )-CCT, + norm_guard_builts( Blts, Vars1, Vars, Ans )-CCT-P. +norm_guard_builts_1( + Blts, Vars0, Vars, Ans, Out, PredName, Inputs, Ans0 )-CCT-P :- + Ans0\=normal | + Ans=Ans0. + +norm_gblt_args( [], Inputs, _Vars, Ans )-CCT-P :- + Inputs = [], Ans=normal. +norm_gblt_args( [X0:Type|T], Inputs, Vars, Ans )-CCT-P :- + Inputs = [X|VT], + norm_gblt_arg( X0, Type, X, Vars, Ans0 )-CCT-P, + norm_gblt_args_1( T, VT, Vars, Ans, Ans0 )-CCT-P. + +norm_gblt_args_1( T, VT, Vars, Ans, Ans0 )-CCT-P :- Ans0=normal | + norm_gblt_args( T, VT, Vars, Ans )-CCT-P. +norm_gblt_args_1( T, VT, Vars, Ans, Ans0 )-CCT-P :- Ans0\=normal | + Ans=Ans0. + +norm_gblt_arg( variable( K ), Type, Pos, Vars, Ans )-CCT-P :- + klic_comp_util:assoc( Vars, K, AAns ), + norm_gblt_arg_1( K, Type, Pos, Vars, Ans, AAns )-CCT-P. +otherwise. +norm_gblt_arg( C0, Type, C, _Vars, Ans )-CCT-P :- + is_const( C0, C, Type0, yes, CAns ), + norm_gblt_arg_2( CAns, Type, C, Type0, Ans, C0 )-P. + +norm_gblt_arg_1( K, Type, Pos, Vars, Ans, yes( rename( J )))-CCT-P :- + norm_gblt_arg( variable( J ), Type, Pos, Vars, Ans )-CCT-P. +otherwise. +norm_gblt_arg_1( K, Type, Pos, Vars, Ans, yes( Value ))-CCT-P :- + Pos = Value, CCT <= ( Value:Type ), Ans=normal. +norm_gblt_arg_1( K, Type, Pos, Vars, Ans, no )-CCT-P :- + klic_comp_message:warning( "Never proceeding guard builtin", [] )-P, + Ans=abnormal. + +norm_gblt_arg_2( yes, Type, C, Type0, Ans, C0 )-P :- + klic_comp_insert:subsumed_type( Type0, Type, SAns ), + check_gblt_input( SAns, Ans, C0 )-P. +norm_gblt_arg_2( no , Type, C, Type0, Ans, C0 )-P :- + klic_comp_message:warning( + "Non-const structure in guard builtin arg: ~w", [C0] )-P, + Ans=abnormal. + +check_gblt_input( Ans0, Ans, _ )-P :- Ans0=normal | + Ans=Ans0. +check_gblt_input( Ans0, Ans, C )-P :- Ans0\=normal | + klic_comp_message:warning( "Guard builtin arg type mismatch: ~w", [C] )-P, + Ans=Ans0. % ----- NORM BODY ----- -norm_body([], Body,_V,Ans)-P :- Body = [], Ans=normal. -norm_body([G0|Rest],Body,V0,Ans)-P :- G0 = functor(F) | - norm_top_goal(F,G,V0,V1,Ans0)-P, - norm_body_1([G0|Rest],Body,V0,V1,Ans,G,Ans0)-P. -otherwise. -norm_body(Goals,Body,V0,Ans)-P :- - norm_body_tail(Goals,Body,[],V0,Ans)-P. - -norm_body_1([_|Rest],Body,V0,V1,Ans,G,Ans0)-P :- Ans0=normal | - Body = [G|L], - norm_body(Rest,L,V1,Ans)-P. -norm_body_1(Goals,Body,V0,V1,Ans,G,Ans0)-P :- Ans0\=normal | - norm_body_tail(Goals,Body,[],V0,Ans)-P. - -norm_body_tail([], Rest,L,_V,Ans)-P :- Rest = L, Ans=normal. -norm_body_tail([G0|Rest0],Rest,L,V0,Ans)-P :- - norm_tail_goal(G0,G,V0,V1,Ans0)-P, - norm_body_tail_1(Rest0,Rest,[G|L],V1,Ans,Ans0)-P. - -norm_body_tail_1(Rest0,Rest,L,V1,Ans,Ans0)-P :- Ans0=normal | - norm_body_tail(Rest0,Rest,L,V1,Ans)-P. -norm_body_tail_1(Rest0,Rest,L,V1,Ans,Ans0)-P :- Ans0\=normal | Ans=Ans0. - -norm_top_goal((X=Y),G,V0,V,Ans)-P :- - G = (PosX=PosY), - norm_body_arg(X,PosX,V0,V1,Ans0)-P, - norm_top_goal_unify(Y,PosY,V1,V,Ans,Ans0)-P. -norm_top_goal((AG:functor(G0@Prio)),G,V0,V,Ans)-P:- AG=atom(generic) | - klic_comp_message:warning("Ignored pragma for a generic call: ~w", - [generic:G0@Prio])-P, - norm_top_goal(functor(AG:G0),G,V0,V,Ans)-P. -otherwise. -norm_top_goal((AG:G),Goal,V0,V,Ans)-P :- AG=atom(generic) | - Goal = gcall(F,A,Args), - norm_body_args(G,F,A,Args,V0,V,Ans)-P. -otherwise. -norm_top_goal(G0,Goal,V0,V,Ans)-P :- - klic_comp_bb:is_body_builtin(G0,Ans0), - norm_top_goal_builtin(Ans0,Goal,V0,V,Ans)-P. -otherwise. -norm_top_goal(G0,Goal,V0,V,Ans)-P :- - Ans=abnormal. - -norm_top_goal_unify(Y,PosY,V1,V,Ans,Ans0)-P :- Ans0=normal | - norm_body_arg(Y,PosY,V1,V,Ans)-P. -norm_top_goal_unify(Y,PosY,V1,V,Ans,Ans0)-P :- Ans0\=normal | Ans=Ans0. - -norm_top_goal_builtin(yes(G,_Module,IInfo,OInfo),Goal,V0,V,Ans)-P :- - Goal = builtin(F,A,Args,IInfo,OInfo), - norm_body_args(functor(G),F,A,Args,V0,V,Ans)-P. -norm_top_goal_builtin(no,Goal,V0,V,Ans)-P :- - Ans=abnormal. - -norm_tail_goal(functor(X=Y),Goal,V0,V,Ans)-P :- - Goal = (PosX=PosY), - norm_body_arg(X,PosX,V0,V1,Ans0)-P, - norm_tail_goal_unify(Y,PosY,V1,V,Ans,Ans0)-P. -norm_tail_goal('$macroexpanded'(Name,[]),Goal,V0,V,Ans)-P :- - norm_tail_goal(atom(Name),Goal,V0,V,Ans)-P. -norm_tail_goal(functor(AG:functor(G0@P)),G,V0,V,Ans)+Po0+Po :- - AG=atom(generic) | - klic_comp_message:warning("Ignored pragma for a generic call: ~w", - [generic:G0@P],Po0,Po1), - norm_tail_goal(functor(AG:G0),G,V0,V,Ans)+Po1+Po. -otherwise. -norm_tail_goal('$macroexpanded'(Name,Args),Goal,V0,V,Ans)-P :- - functor_table:(Goal0=..[Name|Args]), - norm_tail_goal(functor(Goal0),Goal,V0,V,Ans)-P. -norm_tail_goal(functor(AG:T),Call,V0,V,Ans)-P :- - AG=atom(generic), T=functor(G) | - klic_comp_util:univ(G,[F|Args0]), - norm_tail_goal_generic(T,Call,V0,V,Ans,F,Args0)-P. -norm_tail_goal(functor(AG:T),Call,V0,V,Ans)-P :- - AG=atom(generic), T=atom(G) | - norm_tail_goal_generic(T,Call,V0,V,Ans,G,[])-P. -otherwise. -norm_tail_goal(functor(M:T),G,V0,V,Ans)-Pool :- M=atom(Mod), T=functor(G0@P) | - norm_pragma(functor(M:G0),G,V0,V,P,Ans)-Pool. -otherwise. -norm_tail_goal(functor(M:G0),Call,V0,V,Ans)-P :- M=atom(Mod) | - Call = xcall(Mod,F,A,Args), - norm_body_args(G0,F,A,Args,V0,V,Ans)-P. -norm_tail_goal(functor(G0@P),G,V0,V,Ans)-Pool :- - norm_pragma(G0,G,V0,V,P,Ans)-Pool. -otherwise. -norm_tail_goal(T,Call,V0,V,Ans)-P :- T=functor(G0) | - klic_comp_bb:is_body_builtin(G0,Ans0), - norm_tail_goal_builtin(Ans0,T,Call,V0,V,Ans)-P. -otherwise. -norm_tail_goal(G0,Call,V0,V,Ans)-P :- - Call = call(F,A,Args), - norm_body_args(G0,F,A,Args,V0,V,Ans)-P. - -norm_tail_goal_unify(Y,PosY,V1,V,Ans,Ans0)-P :- Ans0=normal | - norm_body_arg(Y,PosY,V1,V,Ans)-P. -norm_tail_goal_unify(Y,PosY,V1,V,Ans,Ans0)-P :- Ans0\=normal | Ans=Ans0. - -norm_tail_goal_generic(G,Call,V0,V,Ans,new,Args0)-P :- - norm_body_args(G,F,A,Args,V0,V,Ans)-P, - Call=gcall(F,A,Args). -norm_tail_goal_generic(G,Call,V0,V,Ans,generic,[_Obj,_Funct])-P :- - norm_body_args(G,F,A,Args,V0,V,Ans)-P, - Args = [Obj,Funct], - Call=xcall(generic,generic,2,[Funct,Obj]). -otherwise. -norm_tail_goal_generic(G,Call,V0,V,Ans,F,[Obj])-P :- - norm_body_args(functor($(atom(F),Obj)),_,_,RealArgs,V0,V,Ans)-P, - Call=xcall(generic,generic,2,RealArgs). -otherwise. -norm_tail_goal_generic(G,Call,V0,V,Ans,F,[Obj|Rest])-P :- - functor_table:(Funct=..[F|Rest]), - norm_body_args(functor($(functor(Funct),Obj)),_,_,RealArgs,V0,V,Ans)-P, - Call=xcall(generic,generic,2,RealArgs). - -norm_tail_goal_builtin(yes(_,Module,_,_),G0,Call,V0,V,Ans)-P :- - Call = xcall(Module,F,A,Args), - norm_body_args(G0,F,A,Args,V0,V,Ans)-P. -norm_tail_goal_builtin(no,G0,Call,V0,V,Ans)-P :- - Call = call(F,A,Args), - norm_body_args(G0,F,A,Args,V0,V,Ans)-P. - -norm_pragma(T,G,V0,V,P,Ans)-Pool :- T=functor(G0) | - klic_comp_bb:is_body_builtin(G0,Ans0), - norm_pragma_0(Ans0,T,G,V0,V,P,Ans)-Pool. -norm_pragma(T,G,V0,V,P,Ans)-Pool :- T=atom(G0) | - klic_comp_bb:is_body_builtin(G0,Ans0), - norm_pragma_0(Ans0,T,G,V0,V,P,Ans)-Pool. - -norm_pragma_0(yes(_,Module,_,_),G0,G,V0,V,P,Ans)-Pool :- - norm_pragma_1(functor(atom(Module):G0),G,V0,V,P,Ans)-Pool. -norm_pragma_0(no,G0,G,V0,V,P,Ans)-Pool :- - norm_pragma_1(G0,G,V0,V,P,Ans)-Pool. - -norm_pragma_1(G0,G,V0,V,atom(lower_priority), Ans)-Pool :- - norm_pragma_1(G0,G,V0,V,functor(lower_priority(integer(1))),Ans)-Pool. -norm_pragma_1(G0,G,V0,V,functor(priority(P0)), Ans)-Pool :- - norm_pragma_priority(G0,G,V0,V,P0,Ans)-Pool. -norm_pragma_1(G0,G,V0,V,functor(lower_priority(P0)),Ans)-Pool :- - norm_pragma_lower_priority(G0,G,V0,V,P0,Ans)-Pool. -norm_pragma_1(G0,G,V0,V,functor(node(N0)), Ans)-Pool :- - norm_pragma_node(G0,G,V0,V,N0,Ans)-Pool. -otherwise. -norm_pragma_1(G0,G,V0,V,Pragma,Ans)-Pool :- - klic_comp_message:report_error( - "Invalid pragma: ~w attached to goal: ~w", [Pragma,G0])-Pool. - -norm_pragma_priority(functor(atom(M):G1),G,V0,V,P0,Ans)-Pool :- - G=xpcall(P,M,F,A,Args), - norm_body_args(G1,F,A,Args,V0,V1,Ans0)-Pool, - norm_pragma_pragma_arg(P0,P,V1,V,Ans,Ans0) -Pool. -norm_pragma_priority(atom(F),G,V0,V,P0,Ans)-Pool :- - G = pcall(P,F,0,[]), - norm_pragma_pragma_arg(P0,P,V0,V,Ans,normal) -Pool. -otherwise. -norm_pragma_priority(functor(G1),G,V0,V,P0,Ans)-Pool :- - G = pcall(P,F,A,Args), - norm_body_args(functor(G1),F,A,Args,V0,V1,Ans0)-Pool, - norm_pragma_pragma_arg(P0,P,V1,V,Ans,Ans0) -Pool. - -norm_pragma_lower_priority(functor(atom(M):G1),G,V0,V,P0,Ans)-Pool :- - G = xlcall(P,M,F,A,Args), - norm_body_args(G1,F,A,Args,V0,V1,Ans0)-Pool, - norm_pragma_pragma_arg(P0,P,V1,V,Ans,Ans0) -Pool. -norm_pragma_lower_priority(atom(F),G,V0,V,P0,Ans)-Pool :- - G = lcall(P,F,0,[]), - norm_pragma_pragma_arg(P0,P,V0,V,Ans,normal) -Pool. -otherwise. -norm_pragma_lower_priority(FG1,G,V0,V,P0,Ans)-Pool :- FG1=functor(G1) | - G = lcall(P,F,A,Args), - norm_body_args(FG1,F,A,Args,V0,V1,Ans0)-Pool, - norm_pragma_pragma_arg(P0,P,V1,V,Ans,Ans0) -Pool. - -norm_pragma_node(functor(atom(M):G1),G,V0,V,N0,Ans)-Pool :- - G=xthrow(N,M,F,A,Args), - norm_body_args(G1,F,A,Args,V0,V1,Ans0)-Pool, - norm_pragma_pragma_arg(N0,N,V1,V,Ans,Ans0) -Pool. -norm_pragma_node(atom(F),G,V0,V,N0,Ans)-Pool :- - G=throw(N,F,0,[]), - norm_pragma_pragma_arg(N0,N,V0,V,Ans,normal) -Pool. -otherwise. -norm_pragma_node(FG1,G,V0,V,N0,Ans)-Pool :- FG1=functor(G1) | - G=throw(N,F,A,Args), - norm_body_args(FG1,F,A,Args,V0,V1,Ans0)-Pool, - norm_pragma_pragma_arg(N0,N,V1,V,Ans,Ans0) -Pool. - -norm_pragma_pragma_arg(P0,P,V1,V,Ans,Ans0)-Pool :- Ans0=normal | - norm_body_arg(P0,P,V1,V,Ans)-Pool. -norm_pragma_pragma_arg(P0,P,V1,V,Ans,Ans0)-Pool :- Ans0\=normal | Ans=Ans0. +norm_body( [], Body, _V, Ans )-P :- + Body = [], Ans=normal. +norm_body( [G0|Rest], Body, V0, Ans )-P :- G0 = functor( F ) | + norm_top_goal( F, G, V0, V1, Ans0 )-P, + norm_body_1( [G0|Rest], Body, V0, V1, Ans, G, Ans0 )-P. +otherwise. +norm_body( Goals, Body, V0, Ans )-P :- + norm_body_tail( Goals, Body, [], V0, Ans )-P. + +norm_body_1( [_|Rest], Body, V0, V1, Ans, G, Ans0 )-P :- Ans0=normal | + Body = [G|L], + norm_body( Rest, L, V1, Ans )-P. +norm_body_1( Goals, Body, V0, V1, Ans, G, Ans0 )-P :- Ans0\=normal | + norm_body_tail( Goals, Body, [], V0, Ans )-P. + +norm_body_tail( [], Rest, L, _V, Ans )-P :- + Rest = L, Ans=normal. +norm_body_tail( [G0|Rest0], Rest, L, V0, Ans )-P :- + norm_tail_goal( G0, G, V0, V1, Ans0 )-P, + norm_body_tail_1( Rest0, Rest, [G|L], V1, Ans, Ans0 )-P. + +norm_body_tail_1( Rest0, Rest, L, V1, Ans, Ans0 )-P :- Ans0=normal | + norm_body_tail( Rest0, Rest, L, V1, Ans )-P. +norm_body_tail_1( Rest0, Rest, L, V1, Ans, Ans0 )-P :- Ans0\=normal | + Ans=Ans0. + +norm_top_goal( ( X=Y ), G, V0, V, Ans )-P :- + G = ( PosX=PosY ), + norm_body_arg( X, PosX, V0, V1, Ans0 )-P, + norm_top_goal_unify( Y, PosY, V1, V, Ans, Ans0 )-P. +norm_top_goal( (AG:functor( G0@Prio )), G, V0, V, Ans )-P:- + AG=atom( generic ) | + klic_comp_message:warning( + "Ignored pragma for a generic call: ~w", [generic:G0@Prio] )-P, + norm_top_goal( functor( AG:G0 ), G, V0, V, Ans )-P. +otherwise. +norm_top_goal( ( AG:G ), Goal, V0, V, Ans )-P :- AG=atom( generic ) | + Goal = gcall( F, A, Args ), + norm_body_args( G, F, A, Args, V0, V, Ans )-P. +otherwise. +norm_top_goal( G0, Goal, V0, V, Ans )-P :- + klic_comp_bb:is_body_builtin( G0, Ans0 ), + norm_top_goal_builtin( Ans0, Goal, V0, V, Ans )-P. +otherwise. +norm_top_goal( G0, Goal, V0, V, Ans )-P :- + Ans=abnormal. + +norm_top_goal_unify( Y, PosY, V1, V, Ans, Ans0 )-P :- Ans0=normal | + norm_body_arg( Y, PosY, V1, V, Ans )-P. +norm_top_goal_unify( Y, PosY, V1, V, Ans, Ans0 )-P :- Ans0\=normal | + Ans=Ans0. + +norm_top_goal_builtin( yes( G, _Module, IInfo, OInfo ), Goal, V0, V, Ans )-P :- + Goal = builtin( F, A, Args, IInfo, OInfo ), + norm_body_args( functor( G ), F, A, Args, V0, V, Ans )-P. +norm_top_goal_builtin( no, Goal, V0, V, Ans )-P :- + Ans=abnormal. + +norm_tail_goal( functor( X=Y ), Goal, V0, V, Ans )-P :- + Goal = ( PosX=PosY ), + norm_body_arg( X, PosX, V0, V1, Ans0 )-P, + norm_tail_goal_unify( Y, PosY, V1, V, Ans, Ans0 )-P. +norm_tail_goal( '$macroexpanded'( Name, [] ), Goal, V0, V, Ans )-P :- + norm_tail_goal( atom( Name ), Goal, V0, V, Ans )-P. +norm_tail_goal( functor( AG:functor( G0@P )), G, V0, V, Ans )+Po0+Po :- + AG=atom( generic ) | + klic_comp_message:warning( + "Ignored pragma for a generic call: ~w", [generic:G0@P], Po0, Po1 ), + norm_tail_goal( functor( AG:G0 ), G, V0, V, Ans )+Po1+Po. +otherwise. +norm_tail_goal( '$macroexpanded'( Name, Args ), Goal, V0, V, Ans )-P :- + functor_table:( Goal0=..[Name|Args] ), + norm_tail_goal( functor( Goal0 ), Goal, V0, V, Ans )-P. +norm_tail_goal( functor( AG:T ), Call, V0, V, Ans )-P :- + AG=atom( generic ), T=functor( G ) | + klic_comp_util:univ( G, [F|Args0] ), + norm_tail_goal_generic( T, Call, V0, V, Ans, F, Args0 )-P. +norm_tail_goal( functor( AG:T ), Call, V0, V, Ans )-P :- + AG=atom( generic ), T=atom( G ) | + norm_tail_goal_generic( T, Call, V0, V, Ans, G, [] )-P. +otherwise. +norm_tail_goal( functor( M:T ), G, V0, V, Ans )-Pool :- + M=atom( Mod ), T=functor( G0@P ) | + norm_pragma( functor( M:G0 ), G, V0, V, P, Ans )-Pool. +otherwise. +norm_tail_goal( functor( M:G0 ), Call, V0, V, Ans )-P :- M=atom( Mod ) | + Call = xcall( Mod, F, A, Args ), + norm_body_args( G0, F, A, Args, V0, V, Ans )-P. +norm_tail_goal( functor( G0@P ), G, V0, V, Ans )-Pool :- + norm_pragma( G0, G, V0, V, P, Ans )-Pool. +otherwise. +norm_tail_goal( T, Call, V0, V, Ans )-P :- T=functor( G0 ) | + klic_comp_bb:is_body_builtin( G0, Ans0 ), + norm_tail_goal_builtin( Ans0, T, Call, V0, V, Ans )-P. +otherwise. +norm_tail_goal( G0, Call, V0, V, Ans )-P :- + Call = call( F, A, Args ), + norm_body_args( G0, F, A, Args, V0, V, Ans )-P. + +norm_tail_goal_unify( Y, PosY, V1, V, Ans, Ans0 )-P :- Ans0=normal | + norm_body_arg( Y, PosY, V1, V, Ans )-P. +norm_tail_goal_unify( Y, PosY, V1, V, Ans, Ans0 )-P :- Ans0\=normal | + Ans=Ans0. + +norm_tail_goal_generic( G, Call, V0, V, Ans, new, Args0 )-P :- + norm_body_args( G, F, A, Args, V0, V, Ans )-P, + Call=gcall( F, A, Args ). +norm_tail_goal_generic( G, Call, V0, V, Ans, generic, [_Obj, _Funct] )-P :- + norm_body_args( G, F, A, Args, V0, V, Ans )-P, + Args = [Obj, Funct], + Call=xcall( generic, generic, 2, [Funct, Obj] ). +otherwise. +norm_tail_goal_generic( G, Call, V0, V, Ans, F, [Obj] )-P :- + norm_body_args( + functor( $( atom( F ), Obj )), _, _, RealArgs, V0, V, Ans )-P, + Call=xcall( generic, generic, 2, RealArgs ). +otherwise. +norm_tail_goal_generic( G, Call, V0, V, Ans, F, [Obj|Rest] )-P :- + functor_table:( Funct=..[F|Rest] ), + norm_body_args( + functor( $( functor( Funct ), Obj )), _, _, RealArgs, V0, V, Ans )-P, + Call=xcall( generic, generic, 2, RealArgs ). + +norm_tail_goal_builtin( yes( _, Module, _, _ ), G0, Call, V0, V, Ans )-P :- + Call = xcall( Module, F, A, Args ), + norm_body_args( G0, F, A, Args, V0, V, Ans )-P. +norm_tail_goal_builtin( no, G0, Call, V0, V, Ans )-P :- + Call = call( F, A, Args ), + norm_body_args( G0, F, A, Args, V0, V, Ans )-P. + +norm_pragma( T, G, V0, V, P, Ans )-Pool :- T=functor( G0 ) | + klic_comp_bb:is_body_builtin( G0, Ans0 ), + norm_pragma_0( Ans0, T, G, V0, V, P, Ans )-Pool. +norm_pragma( T, G, V0, V, P, Ans )-Pool :- T=atom( G0 ) | + klic_comp_bb:is_body_builtin( G0, Ans0 ), + norm_pragma_0( Ans0, T, G, V0, V, P, Ans )-Pool. + +norm_pragma_0( yes( _, Module, _, _ ), G0, G, V0, V, P, Ans )-Pool :- + norm_pragma_1( functor( atom( Module ):G0 ), G, V0, V, P, Ans )-Pool. +norm_pragma_0( no, G0, G, V0, V, P, Ans )-Pool :- + norm_pragma_1( G0, G, V0, V, P, Ans )-Pool. + +norm_pragma_1( G0, G, V0, V, atom( lower_priority ), Ans )-Pool :- + norm_pragma_1( + G0, G, V0, V, functor( lower_priority( integer( 1 ))), Ans )-Pool. +norm_pragma_1( G0, G, V0, V, functor( priority( P0 )), Ans )-Pool :- + norm_pragma_priority( G0, G, V0, V, P0, Ans )-Pool. +norm_pragma_1( G0, G, V0, V, functor( lower_priority( P0 )), Ans )-Pool :- + norm_pragma_lower_priority( G0, G, V0, V, P0, Ans )-Pool. +norm_pragma_1( G0, G, V0, V, functor( node( N0 )), Ans )-Pool :- + norm_pragma_node( G0, G, V0, V, N0, Ans )-Pool. +otherwise. +norm_pragma_1( G0, G, V0, V, Pragma, Ans )-Pool :- + klic_comp_message:report_error( + "Invalid pragma: ~w attached to goal: ~w", [Pragma, G0] )-Pool. + +norm_pragma_priority( functor( atom( M ):G1 ), G, V0, V, P0, Ans )-Pool :- + G=xpcall( P, M, F, A, Args ), + norm_body_args( G1, F, A, Args, V0, V1, Ans0 )-Pool, + norm_pragma_pragma_arg( P0, P, V1, V, Ans, Ans0 ) -Pool. +norm_pragma_priority( atom( F ), G, V0, V, P0, Ans )-Pool :- + G = pcall( P, F, 0, [] ), + norm_pragma_pragma_arg( P0, P, V0, V, Ans, normal ) -Pool. +otherwise. +norm_pragma_priority( functor( G1 ), G, V0, V, P0, Ans )-Pool :- + G = pcall( P, F, A, Args ), + norm_body_args( functor( G1 ), F, A, Args, V0, V1, Ans0 )-Pool, + norm_pragma_pragma_arg( P0, P, V1, V, Ans, Ans0 ) -Pool. + +norm_pragma_lower_priority( functor( atom( M ):G1 ), + G, V0, V, P0, Ans )-Pool :- + G = xlcall( P, M, F, A, Args ), + norm_body_args( G1, F, A, Args, V0, V1, Ans0 )-Pool, + norm_pragma_pragma_arg( P0, P, V1, V, Ans, Ans0 ) -Pool. +norm_pragma_lower_priority( atom( F ), G, V0, V, P0, Ans )-Pool :- + G = lcall( P, F, 0, [] ), + norm_pragma_pragma_arg( P0, P, V0, V, Ans, normal ) -Pool. +otherwise. +norm_pragma_lower_priority( FG1, G, V0, V, P0, Ans )-Pool :- + FG1=functor( G1 ) | + G = lcall( P, F, A, Args ), + norm_body_args( FG1, F, A, Args, V0, V1, Ans0 )-Pool, + norm_pragma_pragma_arg( P0, P, V1, V, Ans, Ans0 ) -Pool. + +norm_pragma_node( functor( atom( M ):G1 ), G, V0, V, N0, Ans )-Pool :- + G=xthrow( N, M, F, A, Args ), + norm_body_args( G1, F, A, Args, V0, V1, Ans0 )-Pool, + norm_pragma_pragma_arg( N0, N, V1, V, Ans, Ans0 ) -Pool. +norm_pragma_node( atom( F ), G, V0, V, N0, Ans )-Pool :- + G=throw( N, F, 0, [] ), + norm_pragma_pragma_arg( N0, N, V0, V, Ans, normal ) -Pool. +otherwise. +norm_pragma_node( FG1, G, V0, V, N0, Ans )-Pool :- FG1=functor( G1 ) | + G=throw( N, F, A, Args ), + norm_body_args( FG1, F, A, Args, V0, V1, Ans0 )-Pool, + norm_pragma_pragma_arg( N0, N, V1, V, Ans, Ans0 ) -Pool. + +norm_pragma_pragma_arg( P0, P, V1, V, Ans, Ans0 )-Pool :- Ans0=normal | + norm_body_arg( P0, P, V1, V, Ans )-Pool. +norm_pragma_pragma_arg( P0, P, V1, V, Ans, Ans0 )-Pool :- Ans0\=normal | + Ans=Ans0. % ----- Norm Body Args ---- -norm_body_args(functor(G0),F,A,Args,Vars0,Vars,Ans)-Pool :- functor(G0,F0,A0) | - F = F0, A = A0, - klic_comp_util:univ(G0,[_|L0]), - norm_body_args(L0,Args,Vars0,Vars,Ans)-Pool. -norm_body_args(atom(G0),F,A,Args,Vars0,Vars,Ans)-Pool :- - F = G0, A = 0, Args = [], Vars = Vars0, Ans=normal. -otherwise. -norm_body_args(G,F,A,Args,Vars0,Vars,Ans)-Pool :- - klic_comp_message:report_error("Invalid body goal: ~w", [G])-Pool, - Ans=abnormal. - -norm_body_args([], Args,Vars0,Vars,Ans)-Pool :- - Args = [], Vars = Vars0, Ans=normal. -norm_body_args([H0|T0],Args,Vars0,Vars,Ans)-Pool :- - Args = [H|T], - norm_body_arg(H0,H,Vars0,Vars1,Ans0)-Pool, - norm_body_args_1(T0,T,Vars1,Vars,Ans,Ans0)-Pool. - -norm_body_args_1(T0,T,Vars1,Vars,Ans,Ans0)-Pool :- Ans0=normal | - norm_body_args(T0,T,Vars1,Vars,Ans)-Pool. -norm_body_args_1(T0,T,Vars1,Vars,Ans,Ans0)-Pool :- Ans0\=normal | Ans=Ans0. - -norm_body_arg(X,Pos,Vars0,Vars,Ans)-P :- X=variable(K) | - klic_comp_util:assoc(Vars0,K,AAns), - norm_body_arg_1(K,Pos,Vars0,Vars,Ans,AAns)-P. -otherwise. -norm_body_arg(A,Pos,Vars0,Vars,Ans)-P :- - norm_body_arg_2(A,Pos,Vars0,Vars,Ans)-P. - -norm_body_arg_1(_K,Pos,Vars0,Vars,Ans,yes(Value))-P :- Value=rename(J) | - norm_body_arg(variable(J),Pos,Vars0,Vars,Ans)-P. -norm_body_arg_1(K,Pos,Vars0,Vars,Ans,no)-P :- - Pos=var(K), Vars=[K=var(K)|Vars0], Ans=normal. -otherwise. -norm_body_arg_1(_K,Pos,Vars0,Vars,Ans,yes(Value))-P :- - Pos=Value, Vars=Vars0, Ans=normal. - -norm_body_arg_2(variable(K),C,Vars,Vars1,Ans)-P :- - C = var(K), Vars1 = [K=var(K)|Vars], Ans=normal. -otherwise. -norm_body_arg_2(C0, C,Vars0,Vars,Ans)-P :- - is_const(C0,C,_,yes,Ans0), - norm_body_arg_3(C0,C,Vars0,Vars,Ans,Ans0)-P. - -norm_body_arg_3(C0, C,Vars0,Vars,Ans,yes)-P :- - Vars = Vars0, Ans=normal. -norm_body_arg_3(C0,C,Vars0,Vars,Ans,no)-P :- C0=list([H|T]) | - norm_body_arg(H,Vcar,Vars0,Vars1,Ans0)-P, - norm_body_arg_3_1(T,Vcar,Vcdr,Vars1,Vars,Ans,C,Ans0)-P. -norm_body_arg_3(C0,C,Vars0,Vars,Ans,no)-P :- C0=functor(S), functor(S,F,A) | - klic_comp_util:univ(S,[_|L0]), - norm_body_args(L0,L,Vars0,Vars,Ans0)-P, - norm_body_arg_3_2(C,mkfunct(F/A,L),Ans,Ans0)-P. -norm_body_arg_3(C0,C,Vars0,Vars,Ans,no)-P :- C0=vector(S), vector(S,N) | - klic_comp_util:vector_to_list(S,L0), - norm_body_args(L0,L,Vars0,Vars,Ans0)-P, - norm_body_arg_3_2(C,mkvect(N,L),Ans,Ans0)-P. - -norm_body_arg_3_1(T,Vcar,Vcdr,Vars1,Vars,Ans,C,Ans00)-P :- Ans00=normal | - norm_body_arg(T,Vcdr,Vars1,Vars,Ans0)-P, - norm_body_arg_3_2(C,cons(Vcar,Vcdr),Ans,Ans0)-P. -norm_body_arg_3_1(T,Vcar,Vcdr,Vars1,Vars,Ans,C,Ans00)-P :- Ans00\=normal | - Ans=Ans00. +norm_body_args( functor( G0 ), F, A, Args, Vars0, Vars, Ans )-Pool :- + functor( G0, F0, A0 ) | + F = F0, A = A0, + klic_comp_util:univ( G0, [_|L0] ), + norm_body_args( L0, Args, Vars0, Vars, Ans )-Pool. +norm_body_args( atom( G0 ), F, A, Args, Vars0, Vars, Ans )-Pool :- + F = G0, A = 0, Args = [], Vars = Vars0, Ans=normal. +otherwise. +norm_body_args( G, F, A, Args, Vars0, Vars, Ans )-Pool :- + klic_comp_message:report_error( "Invalid body goal: ~w", [G] )-Pool, + Ans=abnormal. + +norm_body_args( [], Args, Vars0, Vars, Ans )-Pool :- + Args = [], Vars = Vars0, Ans=normal. +norm_body_args( [H0|T0], Args, Vars0, Vars, Ans )-Pool :- + Args = [H|T], + norm_body_arg( H0, H, Vars0, Vars1, Ans0 )-Pool, + norm_body_args_1( T0, T, Vars1, Vars, Ans, Ans0 )-Pool. + +norm_body_args_1( T0, T, Vars1, Vars, Ans, Ans0 )-Pool :- Ans0=normal | + norm_body_args( T0, T, Vars1, Vars, Ans )-Pool. +norm_body_args_1( T0, T, Vars1, Vars, Ans, Ans0 )-Pool :- Ans0\=normal | + Ans=Ans0. + +norm_body_arg( X, Pos, Vars0, Vars, Ans )-P :- X=variable( K ) | + klic_comp_util:assoc( Vars0, K, AAns ), + norm_body_arg_1( K, Pos, Vars0, Vars, Ans, AAns )-P. +otherwise. +norm_body_arg( A, Pos, Vars0, Vars, Ans )-P :- + norm_body_arg_2( A, Pos, Vars0, Vars, Ans )-P. + +norm_body_arg_1( _K, Pos, Vars0, Vars, Ans, yes( Value ))-P :- + Value=rename( J ) | + norm_body_arg( variable( J ), Pos, Vars0, Vars, Ans )-P. +norm_body_arg_1( K, Pos, Vars0, Vars, Ans, no )-P :- + Pos=var( K ), Vars=[K=var( K )|Vars0], Ans=normal. +otherwise. +norm_body_arg_1( _K, Pos, Vars0, Vars, Ans, yes( Value ))-P :- + Pos=Value, Vars=Vars0, Ans=normal. + +norm_body_arg_2( variable( K ), C, Vars, Vars1, Ans )-P :- + C = var( K ), Vars1 = [K=var( K )|Vars], Ans=normal. +otherwise. +norm_body_arg_2( C0, C, Vars0, Vars, Ans )-P :- + is_const( C0, C, _, yes, Ans0 ), + norm_body_arg_3( C0, C, Vars0, Vars, Ans, Ans0 )-P. + +norm_body_arg_3( C0, C, Vars0, Vars, Ans, yes )-P :- + Vars = Vars0, Ans=normal. +norm_body_arg_3( C0, C, Vars0, Vars, Ans, no )-P :- C0=list( [H|T] ) | + norm_body_arg( H, Vcar, Vars0, Vars1, Ans0 )-P, + norm_body_arg_3_1( T, Vcar, Vcdr, Vars1, Vars, Ans, C, Ans0 )-P. +norm_body_arg_3( C0, C, Vars0, Vars, Ans, no )-P :- + C0=functor( S ), functor( S, F, A ) | + klic_comp_util:univ( S, [_|L0] ), + norm_body_args( L0, L, Vars0, Vars, Ans0 )-P, + norm_body_arg_3_2( C, mkfunct( F/A, L ), Ans, Ans0 )-P. +norm_body_arg_3( C0, C, Vars0, Vars, Ans, no )-P :- + C0=vector( S ), vector( S, N ) | + klic_comp_util:vector_to_list( S, L0 ), + norm_body_args( L0, L, Vars0, Vars, Ans0 )-P, + norm_body_arg_3_2( C, mkvect( N, L ), Ans, Ans0 )-P. + +norm_body_arg_3_1( T, Vcar, Vcdr, Vars1, Vars, Ans, C, Ans00 )-P :- + Ans00=normal | + norm_body_arg( T, Vcdr, Vars1, Vars, Ans0 )-P, + norm_body_arg_3_2( C, cons( Vcar, Vcdr ), Ans, Ans0 )-P. +norm_body_arg_3_1( T, Vcar, Vcdr, Vars1, Vars, Ans, C, Ans00 )-P :- + Ans00\=normal | + Ans=Ans00. -norm_body_arg_3_2(C,R,Ans,Ans0)-P :- Ans0=normal | C=R, Ans=Ans0. -norm_body_arg_3_2(C,R,Ans,Ans0)-P :- Ans0\=normal | Ans=Ans0. +norm_body_arg_3_2( C, R, Ans, Ans0 )-P :- Ans0=normal | C=R, Ans=Ans0. +norm_body_arg_3_2( C, R, Ans, Ans0 )-P :- Ans0\=normal | Ans=Ans0. % -- -is_const(T,B,C,yes,Ans) :- T=atom(A) | yes_const(T,B,C,atom,Ans). -is_const(T,B,C,yes,Ans) :- T=integer(N) | yes_const(int(N),B,C,int,Ans). -is_const(T,B,C,yes,Ans) :- T=float(N) | yes_const(T,B,C,float,Ans). -is_const(T,B,C,yes,Ans) :- T=predicate(M,F,A) | yes_const(T,B,C,predicate,Ans). -is_const(X,B,C,yes,Ans) :- X=list([H|T]) | - is_const(H,_,_,yes,Ans1), is_const(T,_,_,Ans1,Ans2), - is_const_1(X,B,C,Ans2,Ans,list). -is_const(T,B,C,yes,Ans) :- T=functor(F) | - klic_comp_util:univ(F,[_|L]), - is_const_args(yes,L,Ans1), - is_const_1(T,B,C,Ans1,Ans,functor). -is_const(T,B,C,yes,Ans) :- T=string(S) | yes_const(T,B,C,string,Ans). -is_const(T,B,C,yes,Ans) :- T=vector(V) | - klic_comp_util:vector_to_list(V,L), - is_const_args(yes,L,Ans0), - is_const_1(T,B,C,Ans0,Ans,vector). -otherwise. -is_const(X,B,C,YorN,Ans) :- Ans = no. - -is_const_1(B0,B,C,no ,Ans,C0) :- Ans = no. -is_const_1(B0,B,C,yes,Ans,C0) :- yes_const(B0,B,C,C0,Ans). - -is_const_args(Ans0,_,Ans) :- Ans0=no | Ans=Ans0. -is_const_args(Ans0,L,Ans) :- Ans0=yes, L=[] | Ans=Ans0. -is_const_args(Ans0,L,Ans) :- Ans0=yes, L=[H|T] | - is_const(H,_,_,Ans0,AnsH), - is_const_args(AnsH,T,Ans). +is_const( T, B, C, yes, Ans ) :- T=atom( A ) | + yes_const( T, B, C, atom, Ans ). +is_const( T, B, C, yes, Ans ) :- T=integer( N ) | + yes_const( int( N ), B, C, int, Ans ). +is_const( T, B, C, yes, Ans ) :- T=float( N ) | + yes_const( T, B, C, float, Ans ). +is_const( T, B, C, yes, Ans ) :- T=predicate( M, F, A ) | + yes_const( T, B, C, predicate, Ans ). +is_const( X, B, C, yes, Ans ) :- X=list( [H|T] ) | + is_const( H, _, _, yes, Ans1 ), is_const( T, _, _, Ans1, Ans2 ), + is_const_1( X, B, C, Ans2, Ans, list ). +is_const( T, B, C, yes, Ans ) :- T=functor( F ) | + klic_comp_util:univ( F, [_|L] ), + is_const_args( yes, L, Ans1 ), + is_const_1( T, B, C, Ans1, Ans, functor ). +is_const( T, B, C, yes, Ans ) :- T=string( S ) | + yes_const( T, B, C, string, Ans ). +is_const( T, B, C, yes, Ans ) :- T=vector( V ) | + klic_comp_util:vector_to_list( V, L ), + is_const_args( yes, L, Ans0 ), + is_const_1( T, B, C, Ans0, Ans, vector ). +otherwise. +is_const( X, B, C, YorN, Ans ) :- + Ans = no. + +is_const_1( B0, B, C, no , Ans, C0 ) :- Ans = no. +is_const_1( B0, B, C, yes, Ans, C0 ) :- yes_const( B0, B, C, C0, Ans ). + +is_const_args( Ans0, _, Ans ) :- Ans0=no | + Ans=Ans0. +is_const_args( Ans0, L, Ans ) :- Ans0=yes, L=[] | + Ans=Ans0. +is_const_args( Ans0, L, Ans ) :- Ans0=yes, L=[H|T] | + is_const( H, _, _, Ans0, AnsH ), + is_const_args( AnsH, T, Ans ). -yes_const(T,B,C,Type,Ans) :- B=T, C=Type, Ans=yes. +yes_const( T, B, C, Type, Ans ) :- B=T, C=Type, Ans=yes. diff -ruN klic-3.003-2002-01-22/compiler/obj.kl1 klic-3.003-2002-01-23/compiler/obj.kl1 --- klic-3.003-2002-01-22/compiler/obj.kl1 Thu Dec 27 19:15:58 2001 +++ klic-3.003-2002-01-23/compiler/obj.kl1 Wed Jan 23 15:20:50 2002 @@ -1,8 +1,8 @@ -% /* ---------------------------------------------------------- -% % (C)1993, 1994 Institute for New Generation Computer Technology -% % (Read COPYRIGHT for detailed information.) -% ----------------------------------------------------------- */ -% +/* ---------------------------------------------------------- +% (C)1993, 1994 Institute for New Generation Computer Technology +% (Read COPYRIGHT for detailed information.) +----------------------------------------------------------- */ + % referring modules. % klic_comp_util, klic_comp_kl1cmp, kl1_comp_write % shoen, atom_table, klic_comp_message @@ -11,562 +11,591 @@ :- module klic_comp_obj. -write_object(Obj,Info)-Out :- write_object(Obj,Info,0)-Out. - -write_object([],_,_)-Out. -write_object([unify(X1,Y1,Q),unify(X2,Y2,_)|T2],Info,H)-Out :- - write_adjust(Q,H)-Out, - ( T2=[unify(X3,Y3,_)|T3] -> - ( T3=[unify(X4,Y4,_)|T4] -> - klicformat( - " unify4(~k, ~k, ~k, ~k, ~k, ~k, ~k, ~k);\n", - [X1,Y1,X2,Y2,X3,Y3,X4,Y4])-Out, - T=T4 - ; otherwise ; true -> - klicformat( - " unify3(~k, ~k, ~k, ~k, ~k, ~k);\n", - [X1,Y1,X2,Y2,X3,Y3])-Out, - T=T3 - ) +% called in kl1cmp.kl1, msg.kl1, write.kl1 +:- public klicformat/3, klicformat/4, klicformat_stderr/2, + write_object/4, write_inline/6, flush/3, nl/2. + +write_object( Obj, Info )-Out :- write_object( Obj, Info, 0 )-Out. + +write_object( [], _, _ )-Out. +write_object( [unify( X1, Y1, Q ), unify( X2, Y2, _ )|T2], Info, H )-Out :- + write_adjust( Q, H )-Out, + ( T2=[unify( X3, Y3, _ )|T3] -> + ( T3=[unify( X4, Y4, _ )|T4] -> + klicformat( + " unify4( ~k, ~k, ~k, ~k, ~k, ~k, ~k, ~k );\n", + [X1, Y1, X2, Y2, X3, Y3, X4, Y4] )-Out, + T = T4 ; otherwise ; true -> - klicformat(" unify2(~k, ~k, ~k, ~k);\n",[X1,Y1,X2,Y2])-Out, - T=T2 - ), - write_object(T,Info,0)-Out. + klicformat( + " unify3( ~k, ~k, ~k, ~k, ~k, ~k );\n", + [X1, Y1, X2, Y2, X3, Y3] )-Out, + T = T3 ) + ; otherwise ; true -> + klicformat( " unify2( ~k, ~k, ~k, ~k );\n", [X1, Y1, X2, Y2] )-Out, + T = T2 ), + write_object( T, Info, 0 )-Out. otherwise. -write_object([H|T],Info,H0)-Out :- - write_one(H,Info,H0,Heap)-Out, - write_object(T,Info,Heap)-Out. +write_object( [H|T], Info, H0 )-Out :- + write_one( H, Info, H0, Heap )-Out, + write_object( T, Info, Heap )-Out. /* Labels */ -write_one(label(Lab),Info)-H-Out :- - klicformat(" ~l:\n",[Info,Lab])-Out. +write_one( label( Lab ), Info )-H-Out :- + klicformat( " ~l:\n", [Info, Lab] )-Out. /* Register transfer */ -write_one(move(To,From),_)-H-Out :- - write_one_move(To,From)-Out. +write_one( move( To, From ), _ )-H-Out :- + write_one_move( To, From )-Out. /* Element access */ -write_one(get_elem(To,From,Pos),_)-H-Out :- - klicformat(" ~r = ~e;\n",[To,From,Pos])-Out. +write_one( get_elem( To, From, Pos ), _ )-H-Out :- + klicformat( " ~r = ~e;\n", [To, From, Pos] )-Out. /* Indexing */ -write_one(deref(X,Lloop,Lsusp),Info)-H-Out :- - klicformat( - " deref_and_jump(~r,~l);\n" - " *reasonp++ = ~r;\n" - " goto ~l;\n", - [X,Info,Lloop, X, Info,Lsusp])-Out. -write_one(goto(Label),Info)-H-Out :- - klicformat(" goto ~l;\n",[Info,Label])-Out. -write_one(sw_tag(X),_)-H-Out :- - klicformat(" switch (ptagof(~r)) {\n",[X])-Out. -write_one(sw_sym(X),_)-H-Out :- - klicformat(" switch (symval(~r)) {\n",[X])-Out. -write_one(sw_int(X),_)-H-Out :- - klicformat(" switch ((unsigned long)~r) {\n",[X])-Out. -write_one(sw_funct(X),_)-H-Out :- - klicformat(" switch (symval(functor_of(~r))) {\n",[X])-Out. -write_one(case_label(S),_)-H-Out :- - klicformat(" case ~s:\n",[S])-Out. -write_one(case_sym(Atom),_)-H-Out :- - klicformat(" case symval(~a):\n",[Atom])-Out. -write_one(case_int(Atom),_)-H-Out :- - klicformat(" case (unsigned long) ~a:\n",[Atom])-Out. -write_one(case_funct(Funct),_)-H-Out :- - klicformat(" case ~f:\n",[Funct])-Out. -write_one(case_default,_)-H-Out :- - klicformat(" default:\n")-Out. -write_one(end_sw,_)-H-Out :- - klicformat(" };\n")-Out. -write_one(eq(X,Y,Lab,FailLab,SuspLab),Info)-H-Out :- - klicformat(" if_equal(~r, ~r, ~l, ~l, ~l);\n", - [X,Y,Info,Lab,Info,FailLab,Info,SuspLab])-Out. -write_one(if_not_eq(X,Y,Lab),Info)-H-Out :- - klicformat(" if_not_equal(~r, ~r, ~l);\n", [X,Y,Info,Lab])-Out. -write_one(if_int(X,ElseLab),Info)-H-Out :- - klicformat(" if (isint(~r)) goto ~l;\n",[X,Info,ElseLab])-Out. -write_one(if_not_int(X,ElseLab),Info)-H-Out :- - klicformat(" if (!isint(~r)) goto ~l;\n",[X,Info,ElseLab])-Out. -write_one(if_list(X,ElseLab),Info)-H-Out :- - klicformat(" if (iscons(~r)) goto ~l;\n",[X,Info,ElseLab])-Out. -write_one(if_not_list(X,ElseLab),Info)-H-Out :- - klicformat(" if (!iscons(~r)) goto ~l;\n",[X,Info,ElseLab])-Out. -write_one(if_funct(X,ElseLab),Info)-H-Out :- - klicformat(" if (isfunctor(~r)) goto ~l;\n",[X,Info,ElseLab])-Out. -write_one(if_not_funct(X,ElseLab),Info)-H-Out :- - klicformat(" if (!isfunctor(~r)) goto ~l;\n",[X,Info,ElseLab])-Out. -write_one(if_not_gobj(X,ElseLab),Info)-H-Out :- - klicformat(" if (!isgobj(~r)) goto ~l;\n",[X,Info,ElseLab])-Out. -write_one(if_not_class(X,Class,ElseLab),Info)-H-Out :- - klicformat(" if (!isclass(~r,~q)) goto ~l;\n",[X,Class,Info,ElseLab])-Out. -write_one(if_ref(X,ElseLab),Info)-H-Out :- - klicformat(" if (isref(~r)) goto ~l;\n",[X,Info,ElseLab])-Out. -write_one(if_not_ref(X,ElseLab),Info)-H-Out :- - klicformat(" if (!isref(~r)) goto ~l;\n",[X,Info,ElseLab])-Out. -write_one(if_funct_not(X,F,ElseLab),Info)-H-Out :- - klicformat(" if (functor_of(~r) != makesym(~f)) goto ~l;\n", - [X,F,Info,ElseLab])-Out. -write_one(if_not(X,Value,ElseLab),Info)-H-Out :- - klicformat(" if (~r != ~k) goto ~l;\n",[X,Value,Info,ElseLab])-Out. +write_one( deref( X, Lloop, Lsusp ), Info )-H-Out :- + klicformat( + " deref_and_jump( ~r, ~l );\n" + " *reasonp++ = ~r;\n" + " goto ~l;\n", + [X, Info, Lloop, X, Info, Lsusp] )-Out. +write_one( goto( Label ), Info )-H-Out :- + klicformat( " goto ~l;\n", [Info, Label] )-Out. +write_one( sw_tag( X ), _ )-H-Out :- + klicformat( " switch( ptagof( ~r ) ){\n", [X] )-Out. +write_one( sw_sym( X ), _ )-H-Out :- + klicformat( " switch( symval( ~r ) ){\n", [X] )-Out. +write_one( sw_int( X ), _ )-H-Out :- + klicformat( " switch( (unsigned long) ~r ){\n", [X] )-Out. +write_one( sw_funct( X ), _ )-H-Out :- + klicformat( " switch( symval( functor_of( ~r ) ) ){\n", [X] )-Out. +write_one( case_label( S ), _ )-H-Out :- + klicformat( " case ~s:\n", [S] )-Out. +write_one( case_sym( Atom ), _ )-H-Out :- + klicformat( " case symval( ~a ):\n", [Atom] )-Out. +write_one( case_int( Atom ), _ )-H-Out :- + klicformat( " case (unsigned long) ~a:\n", [Atom] )-Out. +write_one( case_funct( Funct ), _ )-H-Out :- + klicformat( " case ~f:\n", [Funct] )-Out. +write_one( case_default, _ )-H-Out :- + klicformat( " default:\n" )-Out. +write_one( end_sw, _ )-H-Out :- + klicformat( " };\n" )-Out. +write_one( eq( X, Y, Lab, FailLab, SuspLab ), Info )-H-Out :- + klicformat( " if_equal( ~r, ~r, ~l, ~l, ~l );\n", + [X, Y, Info, Lab, Info, FailLab, Info, SuspLab] )-Out. +write_one( if_not_eq( X, Y, Lab ), Info )-H-Out :- + klicformat( " if_not_equal( ~r, ~r, ~l );\n", [X, Y, Info, Lab] )-Out. +write_one( if_int( X, ElseLab ), Info )-H-Out :- + klicformat( " if( isint( ~r ) ) goto ~l;\n", [X, Info, ElseLab] )-Out. +write_one( if_not_int( X, ElseLab ), Info )-H-Out :- + klicformat( " if( !isint( ~r ) ) goto ~l;\n", [X, Info, ElseLab] )-Out. +write_one( if_list( X, ElseLab ), Info )-H-Out :- + klicformat( " if( iscons( ~r ) ) goto ~l;\n", [X, Info, ElseLab] )-Out. +write_one( if_not_list( X, ElseLab ), Info )-H-Out :- + klicformat( " if( !iscons( ~r ) ) goto ~l;\n", [X, Info, ElseLab] )-Out. +write_one( if_funct( X, ElseLab ), Info )-H-Out :- + klicformat( " if( isfunctor( ~r ) ) goto ~l;\n", [X, Info, ElseLab] )-Out. +write_one( if_not_funct( X, ElseLab ), Info )-H-Out :- + klicformat( " if( !isfunctor( ~r ) ) goto ~l;\n", [X, Info, ElseLab] )-Out. +write_one( if_not_gobj( X, ElseLab ), Info )-H-Out :- + klicformat( " if( !isgobj( ~r ) ) goto ~l;\n", [X, Info, ElseLab] )-Out. +write_one( if_not_class( X, Class, ElseLab ), Info )-H-Out :- + klicformat( " if( !isclass( ~r, ~q ) ) goto ~l;\n", + [X, Class, Info, ElseLab] )-Out. +write_one( if_ref( X, ElseLab ), Info )-H-Out :- + klicformat( " if( isref( ~r ) ) goto ~l;\n", [X, Info, ElseLab] )-Out. +write_one( if_not_ref( X, ElseLab ), Info )-H-Out :- + klicformat( " if( !isref( ~r ) ) goto ~l;\n", [X, Info, ElseLab] )-Out. +write_one( if_funct_not( X, F, ElseLab ), Info )-H-Out :- + klicformat( " if( functor_of( ~r ) != makesym( ~f ) ) goto ~l;\n", + [X, F, Info, ElseLab] )-Out. +write_one( if_not( X, Value, ElseLab ), Info )-H-Out :- + klicformat( " if( ~r != ~k ) goto ~l;\n", [X, Value, Info, ElseLab] )-Out. /* Inline expansion */ -write_one(inline(Format,Args,ElseLab),Info)-H-Out :- - klicformat(" ")-Out, - write_inline(Format,Args,Info,ElseLab)-Out. +write_one( inline( Format, Args, ElseLab ), Info )-H-Out :- + klicformat( " " )-Out, + write_inline( Format, Args, Info, ElseLab )-Out. /* Constant loading */ -write_one(load_const(X,Const),_)-H-Out :- - klicformat(" ~r = ~k;\n",[X,Const])-Out. +write_one( load_const( X, Const ), _ )-H-Out :- + klicformat( " ~r = ~k;\n", [X, Const] )-Out. /* Variable loading */ -write_one(load_newvar(V),_)-H-Out :- - klicformat(" allocp[~d] = ~r = makeref(&allocp[~d]);\n",[H,V,H])-Out, - H+=1. +write_one( load_newvar( V ), _ )-H-Out :- + klicformat( " allocp[~d] = ~r = makeref( &allocp[~d] );\n", [H, V, H] )-Out, + H += 1. /* Allocation */ -write_one(make_cons(X),_)-H-Out :- - klicformat(" ~r = makecons(&allocp[~d]);\n",[X,H])-Out, - H+=2. -write_one(make_functor(X,N),_)-H-Out :- - klicformat(" ~r = makefunctor(&allocp[~d]);\n",[X,H])-Out, - H+=N. -write_one(make_vector(X,L),_)-H-Out :- - klicformat(" ~r = create_vector(&allocp[~d], ~d, allocp);\n", - [X,H,L])-Out, - H+=L. -write_one(alloc_functor_id(F,A),_)-H-Out :- - klicformat(" allocp[~d] = makesym(~f);\n",[H,F/A])-Out. -write_one(alloc_value(X,K),_)-H-Out :- - Off := H+K, - klicformat(" allocp[~d] = ~r;\n",[Off,X])-Out. -write_one(alloc_var(X,K),_)-H-Out :- - Off := H+K, - klicformat(" allocp[~d] = ~r = makeref(&allocp[~d]);\n",[Off,X,Off])-Out. -write_one(alloc_elem(X,K,KK),_)-H-Out :- - Off := H+KK, - klicformat(" allocp[~d] = ~e;\n",[Off,X,K])-Out. -write_one(alloc_const(Id,K),_)-H-Out :- - Off := H+K, - klicformat(" allocp[~d] = ~k;\n",[Off,Id])-Out. -write_one(make_space(N),_)-H-Out :- - H += N. +write_one( make_cons( X ), _ )-H-Out :- + klicformat( " ~r = makecons( &allocp[~d] );\n", [X, H] )-Out, + H += 2. +write_one( make_functor( X, N ), _ )-H-Out :- + klicformat( " ~r = makefunctor( &allocp[~d] );\n", [X, H] )-Out, + H += N. +write_one( make_vector( X, L ), _ )-H-Out :- + klicformat( " ~r = create_vector( &allocp[~d], ~d, allocp );\n", + [X, H, L] )-Out, + H += L. +write_one( alloc_functor_id( F, A ), _ )-H-Out :- + klicformat( " allocp[~d] = makesym( ~f );\n", [H, F/A] )-Out. +write_one( alloc_value( X, K ), _ )-H-Out :- + Off := H+K, + klicformat( " allocp[~d] = ~r;\n", [Off, X] )-Out. +write_one( alloc_var( X, K ), _ )-H-Out :- + Off := H+K, + klicformat( " allocp[~d] = ~r = makeref( &allocp[~d] );\n", + [Off, X, Off] )-Out. +write_one( alloc_elem( X, K, KK ), _ )-H-Out :- + Off := H+KK, + klicformat( " allocp[~d] = ~e;\n", [Off, X, K] )-Out. +write_one( alloc_const( Id, K ), _ )-H-Out :- + Off := H+K, + klicformat( " allocp[~d] = ~k;\n", [Off, Id] )-Out. +write_one( make_space( N ), _ )-H-Out :- + H += N. /* Unificaiton */ -write_one(unify(X,Y,Q),_)-H-Out :- - write_adjust(Q,H)-Out, - H <== 0, - klicformat(" unify(~k, ~k);\n",[X,Y])-Out. -write_one(unify_value(X,Y,Q),_)-H-Out :- - write_adjust(Q,H)-Out, - H <== 0, - klicformat(" unify_value(~k, ~k);\n",[X,Y])-Out. +write_one( unify( X, Y, Q ), _ )-H-Out :- + write_adjust( Q, H )-Out, + H <== 0, + klicformat( " unify( ~k, ~k );\n", [X, Y] )-Out. +write_one( unify_value( X, Y, Q ), _ )-H-Out :- + write_adjust( Q, H )-Out, + H <== 0, + klicformat( " unify_value( ~k, ~k );\n", [X, Y] )-Out. /* Execution control */ -write_one(execute(Name,Arity,Susp,Q),_)-H-Out :- - write_adjust(Q,H)-Out, - H <== 0, - write_one_execute(Name,Arity,Susp)-Out. - -write_one(proceed(Q),_)-H-Out :- - write_adjust(Q,H)-Out, - H <== 0, - klicformat(" proceed();\n")-Out. -write_one(set_pred(Name,Arity),info(M,_,_))-H-Out :- - H1 := H+1, - klicformat(" allocp[~d] = (q)(&~p);\n",[H1,M,Name,Arity])-Out. -write_one(set_ext_pred(Module,Name,Arity),_)-H-Out :- - H1 := H+1, - klicformat(" allocp[~d] = (q)(&~p);\n",[H1,Module,Name,Arity])-Out. -write_one(heappos(HP),_)-H-Out :- - HP = H. -write_one(push_goal(Q0,HP),_)-H-Out :- - HP = H, - klicformat(" allocp[~d] = (q)~Q;\n",[H,Q0])-Out. -write_one(throw_goal(Node,Q0,Q),_)-H-Out :- - klicformat(" throw_goal(~r,~r,~r);\n",[Node,Q0,Q])-Out. -write_one(enq_at_prio(P,Q0,Q),_)-H-Out :- - klicformat(" enqueue_at_priority(~k,~r,~r);\n",[P,Q0,Q])-Out. -write_one(enq_at_lower_prio(P,Q0,Q),_)-H-Out :- - klicformat(" enqueue_at_lower_priority(~k,~r,~r);\n",[P,Q0,Q])-Out. -write_one(enq_at_prio_no_check(P,Q0,Q),_)-H-Out :- - klicformat(" enqueue_at_priority_no_check(~k,~r,~r);\n",[P,Q0,Q])-Out. -write_one(enq_at_lower_prio_no_check(P,Q0,Q),_)-H-Out :- - klicformat(" enqueue_at_lower_priority_no_check(~k,~r,~r);\n", - [P,Q0,Q])-Out. -write_one(set_qp(X,Q),_)-H-Out :- - klicformat(" ~r = (q)~Q;\n", [X, Q])-Out. - -write_one(set_value(P,X),_)-H-Out :- - PP := P+H+2, - klicformat(" allocp[~d] = ~r;\n",[PP,X])-Out. -write_one(set_newvar(P,X),_)-H-Out :- - PP := P+H+2, - klicformat(" allocp[~d] = ~r = makeref(&allocp[~d]);\n",[PP,X,PP])-Out. -write_one(set_elem(P,X,K),_)-H-Out :- - PP := P+H+2, - klicformat(" allocp[~d] = ~e;\n",[PP,X,K])-Out. -write_one(set_const(P,Id),_)-H-Out :- - PP := P+H+2, - klicformat(" allocp[~d] = ~k;\n",[PP,Id])-Out. +write_one( execute( Name, Arity, Susp, Q ), _ )-H-Out :- + write_adjust( Q, H )-Out, + H <== 0, + write_one_execute( Name, Arity, Susp )-Out. + +write_one( proceed( Q ), _ )-H-Out :- + write_adjust( Q, H )-Out, + H <== 0, + klicformat( " proceed();\n" )-Out. +write_one( set_pred( Name, Arity ), info( M, _, _ ))-H-Out :- + H1 := H+1, + klicformat( " allocp[~d] = (q) &~p;\n", [H1, M, Name, Arity] )-Out. +write_one( set_ext_pred( Module, Name, Arity ), _ )-H-Out :- + H1 := H+1, + klicformat( " allocp[~d] = (q) &~p;\n", [H1, Module, Name, Arity] )-Out. +write_one( heappos( HP ), _ )-H-Out :- + HP = H. +write_one( push_goal( Q0, HP ), _ )-H-Out :- + HP = H, + klicformat( " allocp[~d] = (q) ~Q;\n", [H, Q0] )-Out. +write_one( throw_goal( Node, Q0, Q ), _ )-H-Out :- + klicformat( " throw_goal( ~r, ~r, ~r );\n", [Node, Q0, Q] )-Out. +write_one( enq_at_prio( P, Q0, Q ), _ )-H-Out :- + klicformat( " enqueue_at_priority( ~k, ~r, ~r );\n", [P, Q0, Q] )-Out. +write_one( enq_at_lower_prio( P, Q0, Q ), _ )-H-Out :- + klicformat( " enqueue_at_lower_priority( ~k, ~r, ~r );\n", [P, Q0, Q] )-Out. +write_one( enq_at_prio_no_check( P, Q0, Q ), _ )-H-Out :- + klicformat( " enqueue_at_priority_no_check( ~k, ~r, ~r );\n", + [P, Q0, Q] )-Out. +write_one( enq_at_lower_prio_no_check( P, Q0, Q ), _ )-H-Out :- + klicformat( " enqueue_at_lower_priority_no_check( ~k, ~r, ~r );\n", + [P, Q0, Q] )-Out. +write_one( set_qp( X, Q ), _ )-H-Out :- + klicformat( " ~r = (q) ~Q;\n", [X, Q] )-Out. + +write_one( set_value( P, X ), _ )-H-Out :- + PP := P+H+2, + klicformat( " allocp[~d] = ~r;\n", [PP, X] )-Out. +write_one( set_newvar( P, X ), _ )-H-Out :- + PP := P+H+2, + klicformat( " allocp[~d] = ~r = makeref( &allocp[~d] );\n", + [PP, X, PP] )-Out. +write_one( set_elem( P, X, K ), _ )-H-Out :- + PP := P+H+2, + klicformat( " allocp[~d] = ~e;\n", [PP, X, K] )-Out. +write_one( set_const( P, Id ), _ )-H-Out :- + PP := P+H+2, + klicformat( " allocp[~d] = ~k;\n", [PP, Id] )-Out. /* Builtin */ -write_one(bblt(L,NF,Args,OArgs),_)-H-Out :- - klic_comp_util:append(Args,OArgs,AArgs), - klic_comp_util:length(Args,ArgsLength), - write_one_bblt(L,ArgsLength,NF,AArgs)-Out. +write_one( bblt( L, NF, Args, OArgs ), _ )-H-Out :- + klic_comp_util:append( Args, OArgs, AArgs ), + klic_comp_util:length( Args, ArgsLength ), + write_one_bblt( L, ArgsLength, NF, AArgs )-Out. /* Guard builtin */ -write_one(gblt(F,_,Args,Value,Lint),Info)-H-Out :- - klicformat(" ~w(~,,~k,~l);\n",[F,Args,Value,Info,Lint])-Out. -write_one(gblt_pred(F,_,Args,Lint),Info)-H-Out :- - klicformat(" ~w(~,,~l);\n",[F,Args,Info,Lint])-Out. - -write_one(otherwise,Info)-H-Out :- - klicformat(" otherwise(~l);\n",[Info,interrupt])-Out. -write_one(alternatively,Info)-H-Out :- - klicformat(" alternative(~l);\n",[Info,clear_reason])-Out. +write_one( gblt( F, _, Args, Value, Lint ), Info )-H-Out :- + klicformat( " ~w( ~, , ~k, ~l );\n", [F, Args, Value, Info, Lint] )-Out. +write_one( gblt_pred( F, _, Args, Lint ), Info )-H-Out :- + klicformat( " ~w( ~, , ~l );\n", [F, Args, Info, Lint] )-Out. + +write_one( otherwise, Info )-H-Out :- + klicformat( " otherwise( ~l );\n", [Info, interrupt] )-Out. +write_one( alternatively, Info )-H-Out :- + klicformat( " alternative( ~l );\n", [Info, clear_reason] )-Out. -write_one(equiv(R1,R0),_)-H-Out :- - klicformat(" ~r = ~r;\n",[R0,R1])-Out. +write_one( equiv( R1, R0 ), _ )-H-Out :- + klicformat( " ~r = ~r;\n", [R0, R1] )-Out. /* Generic Objects */ -write_one(new_generic(Class,Arity,Obj,Q),_)-H-Out :- - write_adjust_qp(Q)-Out, - klicformat(" new_generic(~q_g_new, ~d, ~r, ~d);\n", - [Class,Arity,Obj,H])-Out, - H <== 0. -write_one(call_generic(Obj,FA,Q),_)-H-Out :- - write_adjust_qp(Q)-Out, - klicformat(" call_generic(~k, ~f, ~d);\n",[Obj,FA,H])-Out, - H <== 0. -write_one(guard_generic(Obj,FA,Nin,Lint),Info)-H-Out :- - klicformat(" guard_generic(~k, ~f, ~d, ~l);\n", - [Obj,FA,Nin,Info,Lint])-Out. -write_one(store_generic_arg(X,K),_)-H-Out :- - klicformat(" generic_arg[~d] = ~k;\n",[K,X])-Out. -write_one(load_generic_arg(R,K),_)-H-Out :- - klicformat(" ~r = generic_arg[~d];\n",[R,K])-Out. +write_one( new_generic( Class, Arity, Obj, Q ), _ )-H-Out :- + write_adjust_qp( Q )-Out, + klicformat( " new_generic( ~q_g_new, ~d, ~r, ~d );\n", + [Class, Arity, Obj, H] )-Out, + H <== 0. +write_one( call_generic( Obj, FA, Q ), _ )-H-Out :- + write_adjust_qp( Q )-Out, + klicformat( " call_generic( ~k, ~f, ~d );\n", [Obj, FA, H] )-Out, + H <== 0. +write_one( guard_generic( Obj, FA, Nin, Lint ), Info )-H-Out :- + klicformat( " guard_generic( ~k, ~f, ~d, ~l );\n", + [Obj, FA, Nin, Info, Lint] )-Out. +write_one( store_generic_arg( X, K ), _ )-H-Out :- + klicformat( " generic_arg[~d] = ~k;\n", [K, X] )-Out. +write_one( load_generic_arg( R, K ), _ )-H-Out :- + klicformat( " ~r = generic_arg[~d];\n", [R, K] )-Out. otherwise. -write_one(Object,_)-H-Out :- - klic_comp_message:warning("Failed to write out object: ~w", [Object]). +write_one( Object, _ )-H-Out :- + klic_comp_message:warning( "Failed to write out object: ~w", [Object] ). -write_one_move(X,X)-Out. +write_one_move( X, X )-Out. otherwise. -write_one_move(To,From)-Out :- - klicformat(" ~r = ~r;\n",[To,From])-Out. +write_one_move( To, From )-Out :- + klicformat( " ~r = ~r;\n", [To, From] )-Out. -write_one_execute(Name,Arity,Susp)-Out :- Susp=:=0 | - klicformat( - " execute(~q_~d_0);\n" - " goto ~q_~d_ext_interrupt;\n", - [Name,Arity, Name,Arity])-Out. -write_one_execute(Name,Arity,Susp)-Out :- Susp=\=0 | - klicformat( - " execute(~q_~d_clear_reason);\n" - " goto ~q_~d_ext_interrupt;\n", - [Name,Arity, Name,Arity])-Out. - -write_one_bblt([],_,NF,AArgs)-Out :- - klicformat(" ~w_no_check(~,);\n",[NF,AArgs])-Out. -write_one_bblt([1],1,NF,AArgs)-Out :- - klicformat(" ~w(~,);\n",[NF,AArgs])-Out. -write_one_bblt([1],2,NF,AArgs)-Out :- - klicformat(" ~w_no_check_y(~,);\n",[NF,AArgs])-Out. -write_one_bblt([2],_,NF,AArgs)-Out :- - klicformat(" ~w_no_check_x(~,);\n",[NF,AArgs])-Out. +write_one_execute( Name, Arity, Susp )-Out :- Susp=:=0 | + klicformat( + " execute( ~q_~d_0 );\n" + " goto ~q_~d_ext_interrupt;\n", + [Name, Arity, Name, Arity] )-Out. +write_one_execute( Name, Arity, Susp )-Out :- Susp=\=0 | + klicformat( + " execute( ~q_~d_clear_reason );\n" + " goto ~q_~d_ext_interrupt;\n", + [Name, Arity, Name, Arity] )-Out. + +write_one_bblt( [], _, NF, AArgs )-Out :- + klicformat( " ~w_no_check( ~, );\n", [NF, AArgs] )-Out. +write_one_bblt( [1], 1, NF, AArgs )-Out :- + klicformat( " ~w( ~, );\n", [NF, AArgs] )-Out. +write_one_bblt( [1], 2, NF, AArgs )-Out :- + klicformat( " ~w_no_check_y( ~, );\n", [NF, AArgs] )-Out. +write_one_bblt( [2], _, NF, AArgs )-Out :- + klicformat( " ~w_no_check_x( ~, );\n", [NF, AArgs] )-Out. otherwise. -write_one_bblt(_,_,NF,AArgs)-Out :- - klicformat(" ~w(~,);\n",[NF,AArgs])-Out. +write_one_bblt( _, _, NF, AArgs )-Out :- + klicformat( " ~w( ~, );\n", [NF, AArgs] )-Out. %%%%%%% -write_adjust(Q,H)-Out :- - write_adjust_qp(Q)-Out, - write_adjust_allocp(H)-Out. - -write_adjust_qp(qp)-Out. -write_adjust_qp(Q)-Out :- Q\=qp | klicformat(" qp = ~Q;\n",[Q])-Out. - -write_adjust_allocp(Off)-Out :- Off=:=0 | true. -write_adjust_allocp(Off)-Out :- Off=\=0 | - klicformat(" allocp += ~d;\n",[Off])-Out. +write_adjust( Q, H )-Out :- + write_adjust_qp( Q )-Out, + write_adjust_allocp( H )-Out. + +write_adjust_qp( qp )-Out. +write_adjust_qp( Q )-Out :- Q\=qp | klicformat( " qp = ~Q;\n", [Q] )-Out. + +write_adjust_allocp( Off )-Out :- Off=:=0 | + true. +write_adjust_allocp( Off )-Out :- Off=\=0 | + klicformat( " allocp += ~d;\n", [Off] )-Out. /* Formatting routine */ -klicformat_stderr(Format,Args) :- - klicio:klicio([stderr(normal(STD_ERR))]), - klicformat(Format,Args)+STD_ERR+[]. - -flush(user_error,Status) :- - klicio:klicio([stderr(normal([fflush(Status)]))]). -flush(Status)-Out :- Out <= fflush(Status). - -klicformat(Format)-Out :- Out <= fwrite(Format). - -klicformat(Format,Args)-Out :- string(Format,Length,8) | - klicformat(0,Length,Format,Args,OutB,OutT), - wait_and_out(OutB,OutT)-Out. - -wait_and_out(OutB,OutT)-Out :- - Out=OutB, Out<==OutT. - -klicformat(K,N,_Format,_Args)-Out :- K>=N | true. -klicformat(K,N,Format,Args)-Out :- - K=N | + true. +klicformat( K, N, Format, Args )-Out :- + K=0, I<10 | Out <= ~(#"0"+I). -write_int(I)-Out :- I>=10 | - C:= #"0"+I mod 10, - write_int(~(I/10))-Out, - Out <= C. -write_int(I)-Out :- I<0, N:= -I, I=:=N | % I = 0x800...00 - Out<= #"-", - I1:= -(I/10), I2:= -(I+I1*10), C:= #"0"+I2, - write_int(I1)-Out, Out <= C. -write_int(I)-Out :- I<0, N:= -I, I=\=N | - Out<= #"-", - write_int(N)-Out. +format_special_D( From, To )-Out :- + klicformat( "HALFWORD( " )-Out, + format_special_D_1( From, To )-Out, + klicformat( " )" )-Out. + +format_special_D_1( From, To )-Out :- integer( From ), integer( To ) | + N := To - From, + write_int( N )-Out. +format_special_D_1( From, F/A )-Out :- integer( From ) | + klicformat( "LABELDIFF( ~d, ", [From] )-Out, + format_special_L( F/A )-Out, + klicformat( " )" )-Out. +format_special_D_1( F/A, To )-Out :- integer( To ) | + klicformat( "KLICLABELDIFF( " )-Out, + format_special_L( F/A )-Out, + klicformat( ", ~d )", [To] )-Out. +format_special_D_1( F0/A0, F1/A1 )-Out :- + klicformat( "KLICLABELDIFF( " )-Out, + format_special_L( F0/A0 )-Out, + klicformat( ", " )-Out, + format_special_L( F1/A1 )-Out, + klicformat( " )" )-Out. + +format_special_L( F/A )-Out :- atom( F ), integer( A ) | + klicformat( "kliclabel_~f", [F/A] )-Out. +format_special_L( F/A/N )-Out :- integer( N ) | + klicformat( "kliclabel_~f__~d", [F/A, N] )-Out. +format_special_L( F/A/N )-Out :- atom( N ) | + klicformat( "kliclabel_~f__~q", [F/A, N] )-Out. + +write_params( [] )-Out. +write_params( [H] )-Out:- + write_param( H )-Out. +write_params( [H|T] )-Out:- T\=[] | + write_param( H )-Out, + Out <= #",", + write_params( T )-Out. + +write_param( int( Int ))-Out :- + klicformat( "makeint( ~dL )", [Int] )-Out. +write_param( atom( Atom ))-Out :- + klic_comp_write:write_atom( Atom )-Out. +write_param( const( float( Id )))-Out :- + klicformat( "makefloat( float_const_~d )", [Id] )-Out. +write_param( const( predicate( Id )))-Out :- + klicformat( "makepred( pred_const_~d )", [Id] )-Out. +write_param( const( list( Id )))-Out :- + klicformat( "makecons( cons_const_~d )", [Id] )-Out. +write_param( const( functor( Id )))-Out :- + klicformat( "makefunctor( funct_const_~d )", [Id] )-Out. +write_param( const( string( Id )))-Out :- + klicformat( "makefunctor( &string_const_~d )", [Id] )-Out. +write_param( const( vector( Id )))-Out :- + klicformat( "makefunctor( &vector_const_~d )", [Id] )-Out. +write_param( r( E ))-Out :- + write_reg( E )-Out. +write_param( arg( Reg, E ))-Out :- + write_elem_access( Reg, E )-Out. + +write_params_blt( [] )-Out. +write_params_blt( [H] )-Out :- + write_param( H )-Out. +write_params_blt( [H|T] )-Out :- T\=[] | + write_param_blt( H )-Out, + Out <= #",", + write_params( T )-Out. + +write_param_blt( r( E ))-Out :- write_reg( E )-Out. + +write_int( I )-Out :- 0==10 | + C := #"0" + (I mod 10), + write_int( ~( I/10 ))-Out, + Out <= C. +write_int( I )-Out :- I<0, N:= -I, I=:=N | % I = 0x800...00 + Out <= #"-", + I1 := -( I/10 ), I2 := -( I+I1*10 ), C := #"0"+I2, + write_int( I1 )-Out, + Out <= C. +write_int( I )-Out :- I<0, N:= -I, I=\=N | + Out <= #"-", + write_int( N )-Out. /* Element access */ -write_elem_access(X, car)-Out :- klicformat("car_of(~r)", [X])-Out. -write_elem_access(X, cdr)-Out :- klicformat("cdr_of(~r)", [X])-Out. -write_elem_access(X, Pos)-Out :- integer(Pos) | - klicformat("arg(~r, ~d)", [X,Pos])-Out. - -write_reg(a(N))-Out :- Out <= #"a", write_int(N)-Out. -write_reg(x(N))-Out :- Out <= #"x", write_int(N)-Out. -write_reg(r(R))-Out :- write_reg(R)-Out. - -write_reg_int(a(N))-Out :- write_int(N)-Out. -write_reg_int(x(N))-Out :- N1 := N + 128, write_int(N1)-Out. -write_reg_int(r(R))-Out :- write_reg_int(R)-Out. - -write_short(N)-Out :- wait(N) | klicformat("HALFWORD(~d)", [N])-Out. - -write_qp(qp)-Out :- klicformat("qp")-Out. -write_qp(N) -Out :- integer(N) | - klicformat("(struct goalrec*)&allocp[~d]", [N])-Out. +write_elem_access( X, car )-Out :- + klicformat( "car_of( ~r )", [X] )-Out. +write_elem_access( X, cdr )-Out :- + klicformat( "cdr_of( ~r )", [X] )-Out. +write_elem_access( X, Pos )-Out :- integer( Pos ) | + klicformat( "arg( ~r, ~d )", [X, Pos] )-Out. + +write_reg( a( N ))-Out :- Out <= #"a", write_int( N )-Out. +write_reg( x( N ))-Out :- Out <= #"x", write_int( N )-Out. +write_reg( r( R ))-Out :- write_reg( R )-Out. + +write_reg_int( a( N ))-Out :- write_int( N )-Out. +write_reg_int( x( N ))-Out :- N1 := N + 128, write_int( N1 )-Out. +write_reg_int( r( R ))-Out :- write_reg_int( R )-Out. + +write_short( N )-Out :- wait( N ) | klicformat( "HALFWORD( ~d )", [N] )-Out. + +write_qp( qp )-Out :- + klicformat( "qp" )-Out. +write_qp( N ) -Out :- integer( N ) | + klicformat( "(struct goalrec*) &allocp[~d]", [N] )-Out. /* Inline expansion */ -write_inline(string(Format),Args,Info,ElseLab)-Out :- - string(Format,L,8) | - write_inline(0,L,Format,Args,Info,ElseLab)-Out. - -write_inline(K,L,_Format,_Args,_Info,_ElseLab)-Out :- K>= L | - Out <= key#lf. -write_inline(K,L,Format,Args,Info,ElseLab)-Out :- K=N | true. -write_atom_name_string(K,N,S)-Out :- - K= L | + Out <= key#lf. +write_inline( K, L, Format, Args, Info, ElseLab )-Out :- + K=N | + true. +write_atom_name_string( K, N, S )-Out :- K>4, - L := C/\15, - hexchar(U, Upper), - hexchar(L, Lower), - Out <= Upper, - Out <= Lower. +write_atom_name_char( C )-Out :- C =:= #"_" | + Out <= C, Out <= C. +write_atom_name_char( C )-Out :- C =\= #"_" | + Out <= #"_", + U := C >> 4, + L := C /\ 15, + hexchar( U, Upper ), + hexchar( L, Lower ), + Out <= Upper, + Out <= Lower. -hexchar(C, N) :- C < 10 | N := #"0" + C. -hexchar(C, N) :- C >= 10 | N := #"A" - 10 + C. +hexchar( C, N ) :- C < 10 | N := #"0" + C. +hexchar( C, N ) :- C >= 10 | N := #"A" - 10 + C. diff -ruN klic-3.003-2002-01-22/compiler/util.kl1 klic-3.003-2002-01-23/compiler/util.kl1 --- klic-3.003-2002-01-22/compiler/util.kl1 Thu Dec 27 19:15:58 2001 +++ klic-3.003-2002-01-23/compiler/util.kl1 Wed Jan 23 15:38:01 2002 @@ -1,13 +1,19 @@ -% /* ---------------------------------------------------------- -% % (C)1993,1994,1995 Institute for New Generation Computer Technology -% % (Read COPYRIGHT for detailed information.) +/* ---------------------------------------------------------- +% (C)1993,1994,1995 Institute for New Generation Computer Technology +% (Read COPYRIGHT for detailed information.) % (C)1996, 1997, 1998, 1999 Japan Information Processing Development Center % (Read COPYRIGHT-JIPDEC for detailed information.) % ----------------------------------------------------------- */ :- module klic_comp_util. -append([], Y, Z ) :- Y = Z. +% called in generate.kl1, insert.kl1, kl1cmp.kl1, +% macro.kl1, normalize.kl1, obj.kl1, write.kl1 +:- public min/3, max/3, max_vect/2, member/3, univ/2, univ/3, append/3, + length/2, assoc/3, name/2, remove/4, make_atom/2, + vector_to_list/2, string_to_char_list/2, numbervars/6, nth/3, qsort/2. + +append([], Y, Z ) :- Y = Z. append([W|X], Y, Z0) :- Z0 =[W|Z], append(X, Y, Z). assoc([H=T|_], H,Ans) :- Ans = yes(T). @@ -25,9 +31,12 @@ qsort(L, R) :- true | qsort(L, R, []). +qsort([],R,R0) :- true | + R = R0. qsort([X|L],R,R0) :- true | - partition(L, X, L1, L2), qsort(L2, R1, R0), qsort(L1, R, [X|R1]). -qsort([],R,R0) :- true | R = R0. + partition(L, X, L1, L2), + qsort(L2, R1, R0), + qsort(L1, R, [X|R1]). partition([X|L],Y,L1,L2) :- X=Y | partition(L,Y,L1,L2). partition([X|L],Y,XL1,L2) :- X@0, N1:=N-1, vector_element(V,N1,E) | - max(E,M0,M1), max_vect(N1,V,M1,M). +max_vect(N,V,M0,M) :- N=<0 | + M = M0. +max_vect(N,V,M0,M) :- N>0 | + N1 := N-1, + vector_element(V,N1,E), + max(E,M0,M1), + max_vect(N1,V,M1,M). remove([H|T], H, L0, L) :- remove(T, H, L0, L). remove([], _, L0, L) :- L0 = L. @@ -54,96 +67,105 @@ %%%%%%%%%%%%% length(List,N) :- length(List,N,0). -length([_|L],N,K) :- K1 := K+1,length(L,N,K1). +length([_|L],N,K) :- K1 := K+1, length(L,N,K1). length([],N,K) :- N = K. vector_to_list(V,L) :- vector(V,N) | vector_to_list(V,L,[],N). -vector_to_list(V,L,T,K) :- K=<0 | L=T. -vector_to_list(V,L,T,K) :- K>0, - K1 := K-1, - vector_element(V,K1,X) | - vector_to_list(V,L,[X|T],K1). +vector_to_list(V,L,T,K) :- K=<0 | + L = T. +vector_to_list(V,L,T,K) :- K>0 | + K1 := K-1, + vector_element(V,K1,X), + vector_to_list(V,L,[X|T],K1). %%% =.. UNIV Functor => List / RUNIV Functor <= List univ(Funct,List) :- univ(Funct,List,[]). univ(Funct,List,Tail) :- functor(Funct,F,A) | - List = [F|List1], - univ_funct_to_list(Funct,List1,1,A,Tail). + List = [F|List1], + univ_funct_to_list(Funct,List1,1,A,Tail). -univ_funct_to_list(Funct,List,K,Max,Tail) :- K > Max | List = Tail. -univ_funct_to_list(Funct,List,K,Max,Tail) :- K =< Max, arg(K,Funct,X) | - List = [X|List1], - K1 := K+1, - univ_funct_to_list(Funct,List1,K1,Max,Tail). +univ_funct_to_list(Funct,List,K,Max,Tail) :- K > Max | + List = Tail. +univ_funct_to_list(Funct,List,K,Max,Tail) :- K =< Max | + arg(K,Funct,X), + List = [X|List1], + K1 := K+1, + univ_funct_to_list(Funct,List1,K1,Max,Tail). %%% name name(X, CharList) :- atom(X) | - atom_table:get_atom_string(X,S), - string_to_char_list(S,CharList). -name(X, CharList) :- integer(X) | - name_integer(X,CharList). - -name_integer(X,CharList) :- X >= 0 | name_integer(X,CharList,[]). -name_integer(X,CharList) :- X < 0 | - CharList = [#"-"|L], - XX := -X, - name_integer(XX,L,[]). - -name_integer(X,CharList,L) :- X < 10 | - C := #"0" + X, - CharList = [C|L]. + atom_table:get_atom_string(X,S), + string_to_char_list(S,CharList). +name(X, CharList) :- integer(X) | + name_integer(X,CharList). + +name_integer(X,CharList) :- X >= 0 | + name_integer(X,CharList,[]). +name_integer(X,CharList) :- X < 0 | + CharList = [#"-"|L], + XX := -X, + name_integer(XX,L,[]). + +name_integer(X,CharList,L) :- X < 10 | + C := #"0" + X, + CharList = [C|L]. name_integer(X,CharList,L) :- X>=10 | - X1 := X / 10, - C := (X mod 10) + #"0", - name_integer(X1,CharList,[C|L]). + X1 := X / 10, + C := (X mod 10) + #"0", + name_integer(X1,CharList,[C|L]). string_to_char_list(S,CharList) :- string(S,L,8) | - string_to_char_list(S,CharList,[],L). + string_to_char_list(S,CharList,[],L). -string_to_char_list(S,CharList,T,K) :- K =< 0 | CharList=T. +string_to_char_list(S,CharList,T,K) :- K =< 0 | + CharList=T. string_to_char_list(S,CharList,T,K) :- K > 0 | - K1 := K-1, - string_element(S,K1,X), - string_to_char_list(S,CharList,[X|T],K1). + K1 := K-1, + string_element(S,K1,X), + string_to_char_list(S,CharList,[X|T],K1). %%% numbervars(Term0,Term)-N :- numbervars(Term0,Term)-N+[]+_. -numbervars(variable("_"), R)-N-Vars :- - R = variable(N), N+=1. +numbervars(variable("_"), R)-N-Vars :- + R = variable(N), N+=1. otherwise. numbervars(variable(X), R)-N-Vars :- string(X,_,_) | - assoc(Vars,X,Ans), - numbervars_1(Ans,R,X)-N-Vars. + assoc(Vars,X,Ans), + numbervars_1(Ans,R,X)-N-Vars. numbervars(floating_point(X), R)-N-Vars :- float(X) | - R=float(X). + R=float(X). otherwise. numbervars(Term0,Term)-N-Vars :- vector(Term0,Size) | - numbervars_vector(Size,Term0,Term)-N-Vars. + numbervars_vector(Size,Term0,Term)-N-Vars. otherwise. numbervars(Term0,Term)-N-Vars :- functor(Term0,F,A) | - numbervars_funct(A,Term0,F,[],Term)-N-Vars. + numbervars_funct(A,Term0,F,[],Term)-N-Vars. -numbervars_1(yes(K), R, X)-N-V :- R = variable(K). +numbervars_1(yes(K), R, X)-N-V :- + R = variable(K). numbervars_1(no, R, X)-N-V :- - R = variable(N), (X=N) => V, N += 1. + R = variable(N), + (X=N) => V, N += 1. numbervars_vector(K,Vect0,Vect)-N-V :- K =< 0 | - Vect=Vect0. -numbervars_vector(K,Vect0,Vect)-N-V :- K > 0, K1:=K-1 | - set_vector_element(Vect0,K1,X,X1,Vect1), - numbervars(X,X1)-N-V, - numbervars_vector(K1,Vect1,Vect)-N-V. + Vect=Vect0. +numbervars_vector(K,Vect0,Vect)-N-V :- K > 0 | + K1 := K-1, + set_vector_element(Vect0,K1,X,X1,Vect1), + numbervars(X,X1)-N-V, + numbervars_vector(K1,Vect1,Vect)-N-V. numbervars_funct(K,_Term0,F,L,Term)-N-Vars :- K=<0 | - functor_table:(Term=..[F|L]). -numbervars_funct(K,Term0,F,L,Term)-N-Vars :- K>=0, arg(K,Term0,X) | - K1:=K-1, - numbervars(X,X1)-N-Vars, - numbervars_funct(K1,Term0,F,[X1|L],Term)-N-Vars. + functor_table:(Term=..[F|L]). +numbervars_funct(K,Term0,F,L,Term)-N-Vars :- K>=0 | + K1 := K-1, + arg(K,Term0,X), + numbervars(X,X1)-N-Vars, + numbervars_funct(K1,Term0,F,[X1|L],Term)-N-Vars. make_atom(List,Atom) :- - new_string(Str,List,8), - atom_table:make_atom(Str,Atom). + new_string(Str,List,8), + atom_table:make_atom(Str,Atom). diff -ruN klic-3.003-2002-01-22/compiler/version.kl1.tmplt klic-3.003-2002-01-23/compiler/version.kl1.tmplt --- klic-3.003-2002-01-22/compiler/version.kl1.tmplt Thu Dec 27 19:15:57 2001 +++ klic-3.003-2002-01-23/compiler/version.kl1.tmplt Wed Jan 23 15:41:21 2002 @@ -1,3 +1,6 @@ :- module klic_comp_version. + +:- public compiler_version/1, compiler_date/1. % called in kl1cmp.kl1 + compiler_version(V) :- V = 'version ##VERSION'. compiler_date(Date) :- Date = '##DATE'. diff -ruN klic-3.003-2002-01-22/compiler/write.kl1 klic-3.003-2002-01-23/compiler/write.kl1 --- klic-3.003-2002-01-22/compiler/write.kl1 Thu Dec 27 19:15:57 2001 +++ klic-3.003-2002-01-23/compiler/write.kl1 Wed Jan 23 16:19:34 2002 @@ -1,10 +1,10 @@ -% /* ---------------------------------------------------------- -% % (C)1993,1994,1995 Institute for New Generation Computer Technology -% % (Read COPYRIGHT for detailed information.) +/* ---------------------------------------------------------- +% (C)1993,1994,1995 Institute for New Generation Computer Technology +% (Read COPYRIGHT for detailed information.) % (C)1996, 1997, 1998, 1999 Japan Information Processing Development Center % (Read COPYRIGHT-JIPDEC for detailed information.) -% ----------------------------------------------------------- */ -% +----------------------------------------------------------- */ + % referring modules % klic_comp_util, klic_comp_obj, klic_comp_extern, % klic_comp_kl1cmp @@ -13,409 +13,438 @@ :- module klic_comp_write. -write_out(module(Name,Preds,Info))-Out :- - /* write head part */ - klic_comp_obj:klicformat("module module_~q();\n", [Name])-Out, - write_pred_structs(Preds, Name)-Out, - sort_info(Info,InfoSorted), - declare_externals(InfoSorted)-Out, - Out <= #"\n", - klic_comp_obj:klicformat( - "module module_~q(glbl, qp, allocp, toppred)\n" - " struct global_variables *glbl;\n" - " struct goalrec *qp;\n" - " register q *allocp;\n" - " const struct predicate *toppred;\n{\n", - [Name])-Out, - declare_const(InfoSorted)+0+_-Out, - pred_min_max(Preds,99999,MinArity,0,MaxArity), - declare_registers(MaxArity, "a")-Out, - klic_comp_obj:klicformat( - "\n" - " q *reasonp;\n" - " module_top:\n")-Out, - write_get_args(0, MinArity)-Out, - klic_comp_obj:klicformat(" switch_on_pred() {\n")-Out, - write_pred_dispatch(Preds)-Out, - klic_comp_obj:klicformat(" }\n")-Out, - - /* write all predicates */ - write_predicates(Preds,Name,MinArity,Info)-Out, - - /* write tail part */ - write_interrupt_call(MaxArity, MaxArity)-Out, - klic_comp_obj:klicformat( - " proceed_label:\n" - " loop_within_module(module_~q);\n" - "}\n", - [Name])-Out. - - -declare_const([])-K-Out. -declare_const([const(Id,Struct)|T])-K-Out :- - declare_const(Struct,Id)-K-Out, - declare_const(T)-K-Out. +:- public write_out/3, write_header_file/3, % called in kl1cmp.kl1 + write_atom/3, write_funct_name/4, write_pred_name/5. % called in obj.kl1 + +write_out( module( Name, Preds, Info ))-Out :- + /* write head part */ + klic_comp_obj:klicformat( "module module_~q();\n", [Name] )-Out, + write_pred_structs( Preds, Name )-Out, + sort_info( Info, InfoSorted ), + declare_externals( InfoSorted )-Out, + Out <= #"\n", + klic_comp_obj:klicformat( + "module module_~q( glbl, qp, allocp, toppred )\n" + " struct global_variables* glbl;\n" + " struct goalrec* qp;\n" + " register q* allocp;\n" + " const struct predicate* toppred;\n{\n", + [Name] )-Out, + declare_const( InfoSorted )+0+_-Out, + pred_min_max( Preds, 99999, MinArity, 0, MaxArity ), + declare_registers( MaxArity, "a" )-Out, + klic_comp_obj:klicformat( + "\n" + " q* reasonp;\n" + " module_top:\n" )-Out, + write_get_args( 0, MinArity )-Out, + klic_comp_obj:klicformat( " switch_on_pred() {\n" )-Out, + write_pred_dispatch( Preds )-Out, + klic_comp_obj:klicformat( " }\n" )-Out, + + /* write all predicates */ + write_predicates( Preds, Name, MinArity, Info )-Out, + + /* write tail part */ + write_interrupt_call( MaxArity, MaxArity )-Out, + klic_comp_obj:klicformat( + " proceed_label:\n" + " loop_within_module( module_~q );\n" + "}\n", + [Name] )-Out. + + +declare_const( [] )-K-Out. +declare_const( [const( Id, Struct )|T] )-K-Out :- + declare_const( Struct, Id )-K-Out, + declare_const( T )-K-Out. otherwise. -declare_const([_|T])-K-Out :- declare_const(T)-K-Out. +declare_const( [_|T] )-K-Out :- + declare_const( T )-K-Out. -declare_const(string(S),Id)-K-Out :- string(S,L,E), L=<0 | - Id=string(K), - klic_comp_obj:klicformat( - " declare_method_table_of(byte__string);\n" - " static const string_structure_type_~d string_const_~d =\n" - " declare_string_constant_~d(0,0);\n", - [E,K, E])-Out, - K += 1. -declare_const(string(S),Id)-K-Out :- string(S,L,E), L>0 | - Id=string(K), - L4 := (L+3)/4*4, - klic_comp_obj:klicformat( - " static const unsigned char strconst_body_~d[~d] =\n ", - [K,L4])-Out, - write_string_body(L,S)-Out, - Out <= fwrite(";\n"), - klic_comp_obj:klicformat( - " declare_method_table_of(byte__string);\n" - " static const string_structure_type_~d string_const_~d =\n" - " declare_string_constant_~d(strconst_body_~d,~d);\n", - [E,K, E,K,L])-Out, - K += 1. -declare_const(vector(V),Id)-K-Out :- vector(V,L), L=<0 | - Id=vector(K), - klic_comp_obj:klicformat( - " declare_method_table_of(vector);\n" - " static const vector_structure_type vector_const_~d =\n" - " declare_vector_constant(0,0);\n", - [K])-Out, - K += 1. -declare_const(vector(V),Id)-K-Out :- vector(V,L), L>0 | - klic_comp_util:vector_to_list(V,Elems0), - declare_const_list(Elems0,Elems)-K-Out, - Id=vector(K), - klic_comp_obj:klicformat( - " static const q vectconst_body_~d[] = {\n", - [K])-Out, - write_const_elems(Elems)-Out, - Out <= fwrite(" };\n"), - klic_comp_obj:klicformat( - " declare_method_table_of(vector);\n" - " static const vector_structure_type vector_const_~d =\n" - " declare_vector_constant(vectconst_body_~d,~d);\n", - [K, K,L])-Out, - K += 1. -declare_const(float(X),Id)-K-Out :- - Id=float(K), - klic_comp_obj:klicformat( - " declare_method_table_of(float);\n" - " static const float_structure_type float_const_~d =\n" - " declare_float_constant(~g);\n", - [K, X])-Out, - K += 1. -declare_const(module(M),Id)-K-Out :- - Id=module(K), - klic_comp_obj:klicformat( - " declare_method_table_of(module);\n" - " extern module module_~q();\n" - " static const module_structure_type mod_const_~d =\n" - " declare_module_constant(module_~q, ~a);\n", - [M, K, M,M])-Out, - K += 1. -declare_const(predicate(M,F,A),Id)-K-Out :- - declare_const(module(M),module(Mid))-K-Out, - Id=predicate(K), - klic_comp_obj:klicformat( - " declare_method_table_of(predicate);\n" - " static const predicate_structure_type pred_const_~d =\n" - " declare_pred_constant(~p, mod_const_~d, ~a);\n", - [K, M,F,A,Mid,F])-Out, - K += 1. -declare_const(list([H0|T0]),Id)-K-Out :- - declare_const(T0,T)-K-Out, - declare_const(H0,H)-K-Out, - Id=list(K), - klic_comp_obj:klicformat( - " static const q cons_const_~d[] = {\n", - [K])-Out, - write_const_elems([T,H])-Out, - klic_comp_obj:klicformat(" };\n")-Out, - K += 1. -declare_const(functor(X0),Id)-K-Out :- functor(X0,F,A) | - klic_comp_util:univ(X0,[F|Args]), - declare_const_list(Args,Elems)-K-Out, - Id=functor(K), - klic_comp_obj:klicformat( - " static const q funct_const_~d[] = {\n" - " makesym(~f),\n", - [K, F/A])-Out, - write_const_elems(Elems)-Out, - klic_comp_obj:klicformat(" };\n")-Out, - K += 1. +declare_const( string( S ), Id )-K-Out :- string( S, L, E ), L=<0 | + Id = string( K ), + klic_comp_obj:klicformat( + " declare_method_table_of( byte__string );\n" + " static const string_structure_type_~d string_const_~d =\n" + " declare_string_constant_~d( 0, 0 );\n", + [E, K, E] )-Out, + K += 1. +declare_const( string( S ), Id )-K-Out :- string( S, L, E ), L>0 | + Id = string( K ), + L4 := (L+3)/4*4, + klic_comp_obj:klicformat( + " static const unsigned char strconst_body_~d[~d] =\n ", + [K, L4] )-Out, + write_string_body( L, S )-Out, + Out <= fwrite( ";\n" ), + klic_comp_obj:klicformat( + " declare_method_table_of( byte__string );\n" + " static const string_structure_type_~d string_const_~d =\n" + " declare_string_constant_~d( strconst_body_~d, ~d );\n", + [E, K, E, K, L] )-Out, + K += 1. +declare_const( vector( V ), Id )-K-Out :- vector( V, L ), L=<0 | + Id = vector( K ), + klic_comp_obj:klicformat( + " declare_method_table_of( vector );\n" + " static const vector_structure_type vector_const_~d =\n" + " declare_vector_constant( 0, 0 );\n", + [K] )-Out, + K += 1. +declare_const( vector( V ), Id )-K-Out :- vector( V, L ), L>0 | + klic_comp_util:vector_to_list( V, Elems0 ), + declare_const_list( Elems0, Elems )-K-Out, + Id = vector( K ), + klic_comp_obj:klicformat( + " static const q vectconst_body_~d[] = {\n", + [K] )-Out, + write_const_elems( Elems )-Out, + Out <= fwrite( " };\n" ), + klic_comp_obj:klicformat( + " declare_method_table_of( vector );\n" + " static const vector_structure_type vector_const_~d =\n" + " declare_vector_constant( vectconst_body_~d, ~d );\n", + [K, K, L] )-Out, + K += 1. +declare_const( float( X ), Id )-K-Out :- + Id = float( K ), + klic_comp_obj:klicformat( + " declare_method_table_of( float );\n" + " static const float_structure_type float_const_~d =\n" + " declare_float_constant( ~g );\n", + [K, X] )-Out, + K += 1. +declare_const( module( M ), Id )-K-Out :- + Id = module( K ), + klic_comp_obj:klicformat( + " declare_method_table_of( module );\n" + " extern module module_~q();\n" + " static const module_structure_type mod_const_~d =\n" + " declare_module_constant( module_~q, ~a );\n", + [M, K, M, M] )-Out, + K += 1. +declare_const( predicate( M, F, A ), Id )-K-Out :- + declare_const( module( M ), module( Mid ))-K-Out, + Id = predicate( K ), + klic_comp_obj:klicformat( + " declare_method_table_of( predicate );\n" + " static const predicate_structure_type pred_const_~d =\n" + " declare_pred_constant( ~p, mod_const_~d, ~a );\n", + [K, M, F, A, Mid, F] )-Out, + K += 1. +declare_const( list( [H0|T0] ), Id )-K-Out :- + declare_const( T0, T )-K-Out, + declare_const( H0, H )-K-Out, + Id = list( K ), + klic_comp_obj:klicformat( + " static const q cons_const_~d[] = {\n", + [K] )-Out, + write_const_elems( [T, H] )-Out, + klic_comp_obj:klicformat( " };\n" )-Out, + K += 1. +declare_const( functor( X0 ), Id )-K-Out :- functor( X0, F, A ) | + klic_comp_util:univ( X0, [F|Args] ), + declare_const_list( Args, Elems )-K-Out, + Id = functor( K ), + klic_comp_obj:klicformat( + " static const q funct_const_~d[] = {\n" + " makesym( ~f ),\n", + [K, F/A] )-Out, + write_const_elems( Elems )-Out, + klic_comp_obj:klicformat( " };\n" )-Out, + K += 1. otherwise. -declare_const(X,Id)-K-Out :- Id=X. +declare_const( X, Id )-K-Out :- + Id = X. -declare_const_list([],L)-K-Out :- L=[]. -declare_const_list([H0|T0],L)-K-Out :- - L=[H|T], - declare_const(H0,H)-K-Out, - declare_const_list(T0,T)-K-Out. - -write_const_elems([])-Out. -write_const_elems([H|T])-Out :- - write_const_elem(H)-Out, - write_const_elems(T)-Out. - -write_const_elem(atom(A))-Out :- - klic_comp_obj:klicformat(" ~a,\n",[A])-Out. -write_const_elem(integer(N))-Out :- - klic_comp_obj:klicformat(" makeint(~d),\n",[N])-Out. -write_const_elem(float(K))-Out :- - klic_comp_obj:klicformat(" makefloat(float_const_~d),\n",[K])-Out. -write_const_elem(predicate(K))-Out :- - klic_comp_obj:klicformat(" makepred(pred_const_~d),\n",[K])-Out. -write_const_elem(module(K))-Out :- - klic_comp_obj:klicformat(" makepred(mod_const_~d),\n",[K])-Out. -write_const_elem(list(K))-Out :- - klic_comp_obj:klicformat(" makecons(cons_const_~d),\n",[K])-Out. -write_const_elem(functor(K))-Out :- - klic_comp_obj:klicformat(" makefunctor(funct_const_~d),\n",[K])-Out. -write_const_elem(string(K))-Out :- - klic_comp_obj:klicformat(" makefunctor(&string_const_~d),\n",[K])-Out. -write_const_elem(vector(K))-Out :- - klic_comp_obj:klicformat(" makefunctor(&vector_const_~d),\n",[K])-Out. - -/* Some C compilers give an error to something like: - char *str[4] = "abcd"; - that there are too many initializers */ -write_string_body(L,S)-Out :- L mod 4 =\= 0 | - Out <= fwrite("\""), - write_string_elements(0,L,S)-Out, - Out <= fwrite("\""). -write_string_body(L,S)-Out :- L mod 4 =:= 0 | - Out <= fwrite("{"), - write_character_constants(0,L,S)-Out, - Out <= fwrite("}"). - -write_character_constants(K,N,_S)-Out :- K>=N | true. -write_character_constants(K,N,S)-Out :- K=N | true. -write_string_elements(K,N,S)-Out :- K=N | + true. +write_character_constants( K, N, S )-Out :- K=N | + true. +write_string_elements( K, N, S )-Out :- K>6) + 0'0, - E1 := ((E>>3) /\ 7) + 0'0, - E2 := (E /\ 7) + 0'0 | - Out = [0'\,E0,E1,E2|OutT], Out <== OutT. +write_string_element( E )-Out :- + E0 := (E >> 6) + 0'0, + E1 := ( (E >> 3) /\ 7 ) + 0'0, + E2 := ( E /\ 7 ) + 0'0, + Out = [0'\, E0, E1, E2 | OutT], Out <== OutT. % Predicate information: -% pred(Name, Arity, SeqNum, Works, Object) +% pred( Name, Arity, SeqNum, Works, Object ) -write_pred_structs([], _)-Out. -write_pred_structs([pred(Name, Arity, SeqNum, _, _)|Rest], Module)-Out :- - klic_comp_obj:klicformat( - "const struct predicate ~p =\n" - " { module_~q, ~d, ~d };\n", - [Module,Name,Arity, Module, SeqNum, Arity])-Out, - write_pred_structs(Rest, Module)-Out. - -declare_externals([])-Out. -declare_externals([H|T])-Out :- - declare_one_external(H)-Out, - declare_externals(T)-Out. - -declare_one_external(ext(M,P,A))-Out :- - klic_comp_obj:klicformat("extern const struct predicate ~p;\n", - [M,P,A])-Out. -declare_one_external(gnew(Class))-Out :- - klic_comp_obj:klicformat("extern q ~q_g_new();\n",[Class])-Out. -declare_one_external(guse(Class))-Out :- - klic_comp_obj:klicformat("declare_method_table_of(~q);\n",[Class])-Out. +write_pred_structs( [], _ )-Out. +write_pred_structs( [pred( Name, Arity, SeqNum, _, _ )|Rest], Module )-Out :- + klic_comp_obj:klicformat( + "const struct predicate ~p =\n" + " { module_~q, ~d, ~d };\n", + [Module, Name, Arity, Module, SeqNum, Arity] )-Out, + write_pred_structs( Rest, Module )-Out. + +declare_externals( [] )-Out. +declare_externals( [H|T] )-Out :- + declare_one_external( H )-Out, + declare_externals( T )-Out. + +declare_one_external( ext( M, P, A ))-Out :- + klic_comp_obj:klicformat( + "extern const struct predicate ~p;\n", [M, P, A] )-Out. +declare_one_external( gnew( Class ))-Out :- + klic_comp_obj:klicformat( "extern q ~q_g_new();\n", [Class] )-Out. +declare_one_external( guse( Class ))-Out :- + klic_comp_obj:klicformat( "declare_method_table_of( ~q );\n", [Class] )-Out. otherwise. -declare_one_external(_)-Out. +declare_one_external( _ )-Out. -pred_min_max([], MinA0, MinA, MaxA0, MaxA) :- - MinA = MinA0, MaxA = MaxA0. -pred_min_max([pred(_,Arity,_,_,_)|Rest], MinA0, MinA, MaxA0, MaxA) :- - klic_comp_util:min(Arity, MinA0, MinA1), - klic_comp_util:max(Arity, MaxA0, MaxA1), - pred_min_max(Rest, MinA1, MinA, MaxA1, MaxA). - -declare_registers(N, _)-Out :- N=<0 | true. -declare_registers(N, S)-Out :- N>0 | - write_comma_list(N, S, " q ")-Out, - Out <= fwrite(";\n"). - -write_comma_list(N, _, _)-Out :- N=<0 | true. -write_comma_list(N, S, Header)-Out :- N>0 | - N1 := N-1, - klic_comp_obj:klicformat("~s", [Header])-Out, - write_comma_list1(0, N1, S)-Out, - klic_comp_obj:klicformat("~s~d", [S,N1])-Out. - -write_comma_list1(K, N, _)-Out :- K>= N | true. -write_comma_list1(K, N, S)-Out :- Knext;\n" - " ~q_~d_clear_reason:\n" - " reasonp = reasons;\n", - [Name, Arity])-Out, - klic_comp_obj:write_object(Object, info(Module,Name,Arity))-Out, - klic_comp_obj:klicformat( - " ~q_~d_ext_interrupt:\n" - " reasonp = 0l;\n" - " ~q_~d_interrupt:\n", - [Name,Arity, Name,Arity])-Out, - klic_comp_util:member(Info,exec(Name/Arity),Ans), - write_predicates_1(Ans,Module,Name,Arity)-Out, - klic_comp_obj:klicformat( - " goto interrupt_~d;\n" - " }\n", - [Arity])-Out, - write_predicates(Rest,Module,Min,Info)-Out. - -write_predicates_1(yes,M,P,A)-Out :- - klic_comp_obj:klicformat(" toppred = &~p;\n", [M,P,A])-Out. -write_predicates_1(no,_Mod,_Name,_Arit)-Out. - -write_get_args(K,N)-Out :- K=:=N | true. -write_get_args(K,N)-Out :- Kargs[~d];\n", [K,K])-Out, - K1 := K+1, - write_get_args(K1, N)-Out. - -% /* -% Interrupt labels have the following structure. -% -% interrupt_N_cont: -% Entry for continued from N+1 argument case; -% If at the boundary, -% Store argument #(N-1) to goal record extension; -% Allocate goal record extension if needed; -% Store pointer to extension to qp or newly allocated extension; -% goto interrupt_(N-1)_cont; -% Otherwise, -% goto interrupt_N_common; -% interrupt_N: -% Entry for N argumeng case; -% Allocate goal record extension, if needed; -% interrupt_N_common: -% Store argument #(N-1) to goal record; -% */ - -write_interrupt_call(N, _)-Out :- N=<0 | - klic_comp_obj:klicformat( - " interrupt_0:\n" - " allocp = interrupt_goal(allocp, toppred, reasonp);\n")-Out. -write_interrupt_call(N, Max)-Out :- N>0 | - N1 := N-1, - Off := N1+2, - klic_comp_obj:klicformat( - " interrupt_~d:\n" - " allocp[~d] = a~d;\n", - [N, Off,N1])-Out, - write_interrupt_call(N1, Max)-Out. +pred_min_max( [], MinA0, MinA, MaxA0, MaxA ) :- + MinA = MinA0, MaxA = MaxA0. +pred_min_max( [pred( _, Arity, _, _, _ )|Rest], MinA0, MinA, MaxA0, MaxA ) :- + klic_comp_util:min( Arity, MinA0, MinA1 ), + klic_comp_util:max( Arity, MaxA0, MaxA1 ), + pred_min_max( Rest, MinA1, MinA, MaxA1, MaxA ). + +declare_registers( N, _ )-Out :- N=<0 | + true. +declare_registers( N, S )-Out :- N>0 | + write_comma_list( N, S, " q " )-Out, + Out <= fwrite( ";\n" ). + +write_comma_list( N, _, _ )-Out :- N=<0 | + true. +write_comma_list( N, S, Header )-Out :- N>0 | + N1 := N-1, + klic_comp_obj:klicformat( "~s", [Header] )-Out, + write_comma_list1( 0, N1, S )-Out, + klic_comp_obj:klicformat( "~s~d", [S, N1] )-Out. + +write_comma_list1( K, N, _ )-Out :- K>= N | + true. +write_comma_list1( K, N, S )-Out :- Knext;\n" + " ~q_~d_clear_reason:\n" + " reasonp = reasons;\n", + [Name, Arity] )-Out, + klic_comp_obj:write_object( Object, info( Module, Name, Arity ))-Out, + klic_comp_obj:klicformat( + " ~q_~d_ext_interrupt:\n" + " reasonp = 0L;\n" + " ~q_~d_interrupt:\n", + [Name, Arity, Name, Arity] )-Out, + klic_comp_util:member( Info, exec( Name/Arity ), Ans ), + write_predicates_1( Ans, Module, Name, Arity )-Out, + klic_comp_obj:klicformat( + " goto interrupt_~d;\n" + " }\n", + [Arity] )-Out, + write_predicates( Rest, Module, Min, Info )-Out. + +write_predicates_1( yes, M, P, A )-Out :- + klic_comp_obj:klicformat( " toppred = &~p;\n", [M, P, A] )-Out. +write_predicates_1( no, _Mod, _Name, _Arit )-Out. + +write_get_args( K, N )-Out :- K=:=N | + true. +write_get_args( K, N )-Out :- Kargs[~d];\n", [K, K] )-Out, + K1 := K+1, + write_get_args( K1, N )-Out. + +% Interrupt labels have the following structure. +% +% interrupt_N_cont: +% Entry for continued from N+1 argument case; +% If at the boundary, +% Store argument #( N-1 ) to goal record extension; +% Allocate goal record extension if needed; +% Store pointer to extension to qp or newly allocated extension; +% goto interrupt_( N-1 )_cont; +% Otherwise, +% goto interrupt_N_common; +% interrupt_N: +% Entry for N argumeng case; +% Allocate goal record extension, if needed; +% interrupt_N_common: +% Store argument #( N-1 ) to goal record; + +write_interrupt_call( N, _ )-Out :- N=<0 | + klic_comp_obj:klicformat( + " interrupt_0:\n" + " allocp = interrupt_goal( allocp, toppred, reasonp );\n" )-Out. +write_interrupt_call( N, Max )-Out :- N>0 | + N1 := N-1, + Off := N1+2, + klic_comp_obj:klicformat( + " interrupt_~d:\n" + " allocp[~d] = a~d;\n", + [N, Off, N1] )-Out, + write_interrupt_call( N1, Max )-Out. % Writing out inter-module info to the header file -write_header_file(module(Mod,Preds,Info))-Out :- - klic_comp_obj:klicformat("module_~q\n",[Mod])-Out, - write_defined_preds(Preds,Mod)-Out, - klic_comp_extern:make_ext_table(Info,E,[]), - klic_comp_util:qsort(E,ES), - write_ext_entries(ES)-Out. - -write_ext_entries([])-Out. -write_ext_entries([E|T])-Out :- - write_ext_entry(E)-Out, - write_ext_entries(T)-Out. - -write_ext_entry(atom(A))-Out :- - klic_comp_obj:klicformat("atom_~q\n",[A])-Out. -write_ext_entry(funct(F/A))-Out :- - write_funct_name(F,A)-Out, - Out<= #"\n". -write_ext_entry(module(C))-Out :- - klic_comp_obj:klicformat("ref_module_~q\n",[C])-Out. -write_ext_entry(class(C))-Out :- - klic_comp_obj:klicformat("ref_class_~q\n",[C])-Out. - -write_defined_preds([],_)-Out. -write_defined_preds([pred(Name,Arity,_,_,_)|Rest],Module)-Out :- - klic_comp_obj:klicformat("~p\n", [Module,Name,Arity])-Out, - write_defined_preds(Rest,Module)-Out. +write_header_file( module( Mod, Preds, Info ))-Out :- + klic_comp_obj:klicformat( "module_~q\n", [Mod] )-Out, + write_defined_preds( Preds, Mod )-Out, + klic_comp_extern:make_ext_table( Info, E, [] ), + klic_comp_util:qsort( E, ES ), + write_ext_entries( ES )-Out. + +write_ext_entries( [] )-Out. +write_ext_entries( [E|T] )-Out :- + write_ext_entry( E )-Out, + write_ext_entries( T )-Out. + +write_ext_entry( atom( A ))-Out :- + klic_comp_obj:klicformat( "atom_~q\n", [A] )-Out. +write_ext_entry( funct( F/A ))-Out :- + write_funct_name( F, A )-Out, + Out <= #"\n". +write_ext_entry( module( C ))-Out :- + klic_comp_obj:klicformat( "ref_module_~q\n", [C] )-Out. +write_ext_entry( class( C ))-Out :- + klic_comp_obj:klicformat( "ref_class_~q\n", [C] )-Out. + +write_defined_preds( [], _ )-Out. +write_defined_preds( [pred( Name, Arity, _, _, _ )|Rest], Module )-Out :- + klic_comp_obj:klicformat( "~p\n", [Module, Name, Arity] )-Out, + write_defined_preds( Rest, Module )-Out. % Subroutines for writing atom and functor names in a canonical manner -write_atom([])-Out :- Out <= fwrite("NILATOM"). -write_atom('.')-Out:- Out <= fwrite("PERIODATOM"). -write_atom(N )-Out :- integer(N) | - klic_comp_obj:klicformat("makeint(~dL)", [N])-Out. +write_atom( [] )-Out :- Out <= fwrite( "NILATOM" ). +write_atom( '.' )-Out:- Out <= fwrite( "PERIODATOM" ). +write_atom( N )-Out :- integer( N ) | + klic_comp_obj:klicformat( "makeint( ~dL )", [N] )-Out. otherwise. -write_atom(Atom)-Out :- - klic_comp_obj:klicformat("makesym(atom_~q)", [Atom])-Out. +write_atom( Atom )-Out :- + klic_comp_obj:klicformat( "makesym( atom_~q )", [Atom] )-Out. -write_funct_name(Funct,Arity)-Out :- - klic_comp_obj:klicformat("functor_~q_~d", [Funct,Arity])-Out. +write_funct_name( Funct, Arity )-Out :- + klic_comp_obj:klicformat( "functor_~q_~d", [Funct, Arity] )-Out. -write_pred_name(Module,Pred,Arity)-Out :- - klic_comp_obj:klicformat("predicate_~q_x~q_~d",[Module,Pred,Arity])-Out. +write_pred_name( Module, Pred, Arity )-Out :- + klic_comp_obj:klicformat( "predicate_~q_x~q_~d", [Module, Pred, Arity] )-Out. -sort_info(L, R) :- sort_info(L, R, []). - -sort_info([X|L],R,R0) :- - partition(L, X, L1, L2), - sort_info(L2, R1, R0), - sort_info(L1, R, [X|R1]). -sort_info([],R,R0) :- true | R = R0. - -partition([X|L],Y,L1,L2) :- X=Y | partition(L,Y,L1,L2). -partition([X|L],Y,XL1,L2) :- X@Y | XL2 = [X|L2], partition(L,Y,L1,L2). -partition([X|L],Y,L1,L2) :- X=const(IdX,StructX), Y=const(IdY,StructY), - StructX=StructY | - IdX=IdY, partition(L,Y,L1,L2). -partition([X|L],Y,XL1,L2) :- X=const(IdX,StructX), Y=const(IdY,StructY), - StructX@StructY | - XL2 = [X|L2], partition(L,Y,L1,L2). -partition([],_,L1,L2) :- L1 = [], L2 = []. +sort_info( L, R ) :- sort_info( L, R, [] ). + +sort_info( [X|L], R, R0 ) :- + partition( L, X, L1, L2 ), + sort_info( L2, R1, R0 ), + sort_info( L1, R, [X|R1] ). +sort_info( [], R, R0 ) :- true | + R = R0. + +partition( [], _, L1, L2 ) :- + L1 = [], L2 = []. +partition( [X|L], Y, L1, L2 ) :- X=Y | + partition( L, Y, L1, L2 ). +partition( [X|L], Y, XL1, L2 ) :- X@Y | + XL2 = [X|L2], + partition( L, Y, L1, L2 ). +partition( [X|L], Y, L1, L2 ) :- + X=const( IdX, StructX ), Y=const( IdY, StructY ), StructX=StructY | + IdX = IdY, + partition( L, Y, L1, L2 ). +partition( [X|L], Y, XL1, L2 ) :- + X=const( IdX, StructX ), Y=const( IdY, StructY ), StructX@StructY | + XL2 = [X|L2], + partition( L, Y, L1, L2 ).