...
 
Commits (2)
......@@ -24,7 +24,7 @@ goal2 b = let s free in
s=:=[Deposit 200, Withdraw 100, Deposit 50, Balance b]
-- send a message:
sendMsg :: msg -> [msg] -> [msg]
sendMsg :: Data msg => msg -> [msg] -> [msg]
sendMsg msg obj | obj =:= msg:obj1 = obj1 where obj1 free -- send a message
-- client process for bank account:
......
......@@ -20,7 +20,7 @@ assembler (Jump l : ins) st a
| lookupST l st label st1 = 9:label:assembler ins st1 (a+2)
where label,st1 free
assembler (Label l : ins) st a
| st1 == insertST l a st = assembler ins st1 a
| st1 =:= insertST l a st = assembler ins st1 a
where st1 free
-- insert an address of a labelid in a symboltable:
......
......@@ -24,3 +24,6 @@ tab n = if n==0 then done else putChar ' ' >> tab (n-1)
-- number of characters for the string representation of a number:
size :: Int -> Int
size n = if n<10 then 1 else size (n `div` 10) + 1
done :: IO ()
done = return ()
Subproject commit 04c8a083fcdc1f87c247d7ff475bee0ef8ad8b45
Subproject commit aa2a99463c089b49e65ec5a5ed72bb857f6c01bc
......@@ -562,7 +562,7 @@ writeProg(Mod,Imports,MainTypes,MainFuncs,MainOps,ImpTypes,ImpFuncs,ImpOps) :-
writeGenericClauses(CCs) :-
write('%%%%%%%%%%%% clauses for generic operations %%%%%%%%%%%%%%%%%%%'), nl,
map1M(compiler:transConstrEq,CCs),
map1M(compiler:transBoolEq,CCs),
%map1M(compiler:transBoolEq,CCs), % no longer necessary due to class Eq
map1M(compiler:transNf,CCs),
(compileWithSharing(variable) -> map1M(compiler:transpropshar,CCs) ; true),
(compileWithSharing(function) -> map1M(compiler:genMakeFunctionShare,CCs) ; true),
......@@ -1732,65 +1732,64 @@ genHnfClause(_,_) :- !.
% translation of clauses for solving equational constraints
transConstrEq(Suffix) :-
appendAtom(constrEq,Suffix,ConstrEqOrg),
genBlockDecl(ConstrEqOrg,5,[4],ConstrEq),
appendAtom('Prelude.=:=',Suffix,ConstrEqOrg),
genBlockDecl(ConstrEqOrg,6,[5],ConstrEq),
appendAtom(constrEqHnf,Suffix,ConstrEqHnfOrg),
ConstrEq_A_B_R_E0_E =.. [ConstrEq,A,B,R,E0,E],
ConstrEqHnf_HA_HB_R_E2_E =.. [ConstrEqHnfOrg,HA,HB,R,E2,E],
ConstrEq_A_B_R_E0_E =.. [ConstrEq,Dict,A,B,R,E0,E],
ConstrEqHnf_HA_HB_R_E2_E =.. [ConstrEqHnfOrg,Dict,HA,HB,R,E2,E],
(compileWithDebug ->
writeClause((ConstrEq_A_B_R_E0_E :-
traceCall('Prelude.constrEq'(A,B),Skip),
hnf(A,HA,E0,E1), hnf(B,HB,E1,E2),
ConstrEqHnf_HA_HB_R_E2_E,
traceExit('Prelude.constrEq'(A,B),
'Prelude.True',
E,Skip)))
traceCall('Prelude.=:='(Dict,A,B),Skip),
hnf(A,HA,E0,E1), hnf(B,HB,E1,E2),
ConstrEqHnf_HA_HB_R_E2_E,
traceExit('Prelude.=:='(Dict,A,B),'Prelude.True',
E,Skip)))
; writeClause((ConstrEq_A_B_R_E0_E :- hnf(A,HA,E0,E1),hnf(B,HB,E1,E2),
ConstrEqHnf_HA_HB_R_E2_E))),
nl,
genBlockDecl(ConstrEqHnfOrg,5,[4],ConstrEqHnf),
ConstrEqHnf_X_H_R_E0_E =.. [ConstrEqHnf,X,H,R,E0,E],
ConstrEqHnf_H_X_R_E0_E =.. [ConstrEqHnf,H,X,R,E0,E],
genBlockDecl(ConstrEqHnfOrg,6,[5],ConstrEqHnf),
ConstrEqHnf_X_H_R_E0_E =.. [ConstrEqHnf,Dict,X,H,R,E0,E],
ConstrEqHnf_H_X_R_E0_E =.. [ConstrEqHnf,Dict,H,X,R,E0,E],
appendAtom(bindTryNf,Suffix,BindTryNf),
BindTryNf_X_H_R_E0_E =.. [BindTryNf,X,H,R,E0,E],
writeClause((ConstrEqHnf_X_H_R_E0_E :- var(X),!,BindTryNf_X_H_R_E0_E)),
writeClause((ConstrEqHnf_H_X_R_E0_E :- var(X),!,BindTryNf_X_H_R_E0_E)),
ConstrEqHnf_T1_T2_E0_E =.. [ConstrEqHnf,T1,T2,'Prelude.True',E0,E],
ConstrEqHnf_A_B_R_E0_E =.. [ConstrEqHnf,A,B,R,E0,E],
ConstrEqHnf_T1_T2_E0_E =.. [ConstrEqHnf,Dict,T1,T2,'Prelude.True',E0,E],
ConstrEqHnf_A_B_R_E0_E =.. [ConstrEqHnf,Dict,A,B,R,E0,E],
(printConsFailure(no)
-> writeClause((ConstrEqHnf_T1_T2_E0_E :- number(T1),!,T1=T2,E0=E))
; ConstrEqHnf_FAIL_X_E_E =.. [ConstrEqHnf,'FAIL'(Src),X,
; ConstrEqHnf_FAIL_X_E_E =.. [ConstrEqHnf,Dict,'FAIL'(Src),X,
'FAIL'(Src),E,E],
writeClause((ConstrEqHnf_FAIL_X_E_E :- !)),
ConstrEqHnf_X_FAIL_E_E =.. [ConstrEqHnf,X,'FAIL'(Src),
ConstrEqHnf_X_FAIL_E_E =.. [ConstrEqHnf,Dict,X,'FAIL'(Src),
'FAIL'(Src),E,E],
writeClause((ConstrEqHnf_X_FAIL_E_E :- !)),
writeClause((ConstrEqHnf_A_B_R_E0_E :- number(A), !,
(A=B -> R='Prelude.True', E0=E
; prim_failure(partcall(2,'Prelude.constrEq',[]),[A,B],R,E0,E))))),
; prim_failure(partcall(2,'Prelude.=:=',[Dict]),[A,B],R,E0,E))))),
appendAtom(genConstrEqHnfBody,Suffix,GenConstrEqHnfBody),
GenConstrEqHnfBody_1_NA =.. [GenConstrEqHnfBody,1,NA,A,B,EqBody],
GenConstrEqHnfBody_1_NA =.. [GenConstrEqHnfBody,1,NA,Dict,A,B,EqBody],
writeClause((ConstrEqHnf_A_B_R_E0_E :-
functor(A,FA,NA), functor(B,FB,NB),
FA==FB, NA==NB, !, GenConstrEqHnfBody_1_NA,
hnf(EqBody,R,E0,E))),
(printConsFailure(no) -> true
; ConstrEqHnf_A_B_FAIL_E0_E =.. [ConstrEqHnf,A,B,R,E0,E],
; ConstrEqHnf_A_B_FAIL_E0_E =.. [ConstrEqHnf,Dict,A,B,R,E0,E],
writeClause((ConstrEqHnf_A_B_FAIL_E0_E :-
prim_failure(partcall(2,'Prelude.constrEq',[]),[A,B],R,E0,E)))),
prim_failure(partcall(2,'Prelude.=:=',[Dict]),[A,B],R,E0,E)))),
nl,
GenConstrEqHnfBody_N_NA_Succ =..
[GenConstrEqHnfBody,N,NA,_,_,'Prelude.True'],
[GenConstrEqHnfBody,N,NA,_,_,_,'Prelude.True'],
writeClause((GenConstrEqHnfBody_N_NA_Succ :- N>NA,!)),
appendAtom('Prelude.constrEq',Suffix,Eq),
Eq_ArgA_ArgB =.. [Eq,ArgA,ArgB],
GenConstrEqHnfBody_N_NA_Eq =.. [GenConstrEqHnfBody,N,NA,A,B,Eq_ArgA_ArgB],
appendAtom('Prelude.=:=',Suffix,Eq),
Eq_ArgA_ArgB =.. [Eq,Dict,ArgA,ArgB],
GenConstrEqHnfBody_N_NA_Eq =.. [GenConstrEqHnfBody,N,NA,Dict,A,B,Eq_ArgA_ArgB],
writeClause((GenConstrEqHnfBody_N_NA_Eq :- N=NA, !,
arg(N,A,ArgA), arg(N,B,ArgB))),
appendAtom('Prelude.&',Suffix,ConcAnd),
ConcAnd_Eq =.. [ConcAnd,Eq_ArgA_ArgB,RemBody],
GenConstrEqHnfBody_N_NA_And =.. [GenConstrEqHnfBody,N,NA,A,B,ConcAnd_Eq],
GenConstrEqHnfBody_N1_NA =.. [GenConstrEqHnfBody,N1,NA,A,B,RemBody],
GenConstrEqHnfBody_N_NA_And =.. [GenConstrEqHnfBody,N,NA,Dict,A,B,ConcAnd_Eq],
GenConstrEqHnfBody_N1_NA =.. [GenConstrEqHnfBody,N1,NA,Dict,A,B,RemBody],
writeClause((GenConstrEqHnfBody_N_NA_And :-
arg(N,A,ArgA), arg(N,B,ArgB),
N1 is N+1, GenConstrEqHnfBody_N1_NA)),
......@@ -1820,7 +1819,7 @@ transConstrEq(Suffix) :-
writeClause((BindDirect_X_T_R_E0_E :-
OccursNot_X_T, !, X=T, R='Prelude.True', E0=E)),
writeClause((BindDirect_X_T_R_E0_E :-
prim_failure(partcall(2,'Prelude.constrEq',[]),[X,T],R,E0,E)))),
prim_failure(partcall(2,'Prelude.=:=',[aDict]),[X,T],R,E0,E)))),
nl,
Bind_X_T_E0_E =.. [Bind,X,T,'Prelude.True',E0,E],
writeClause((Bind_X_T_E0_E :- var(T), !, X=T, E0=E)),
......@@ -1841,7 +1840,7 @@ transConstrEq(Suffix) :-
functor(B,FB,NB), OccursNotArgs_1_NB_A_B, !,
functor(A,FB,NB), BindArgs_1_NB_A_B_R_E0_E)),
writeClause((Bind_A_B_R_E0_E :-
prim_failure(partcall(2,'Prelude.constrEq',[]),[A,B],R,E0,E)))),
prim_failure(partcall(2,'Prelude.=:=',[aDict]),[A,B],R,E0,E)))),
nl,
OccursNotArgs_N_NA_A_B =.. [OccursNotArgs,N,NA,A,B],
OccursNotArgs_N1_NA_A_B =.. [OccursNotArgs,N1,NA,A,B],
......@@ -1878,46 +1877,6 @@ transConstrEq(Suffix) :-
writeClause(OccursNot_X_Y),
nl.
transConstrEq_hnf(Cons/Arity) :-
functor(CX,Cons,Arity),
functor(CY,Cons,Arity),
CX =.. [_|Xs],
CY =.. [_|Ys],
(Arity=0 -> writeClause((constrEq_hnf(CX,CY,E,E) :- !))
; gen_constrEq_hnf_body(Xs,Ys,Body),
writeClause((constrEq_hnf(CX,CY,E0,E) :- !, hnf(Body,_,E0,E)))).
gen_constrEq_hnf_body([X],[Y],'Prelude.constrEq'(X,Y)).
gen_constrEq_hnf_body([X1,X2|Xs],[Y1,Y2|Ys],
'Prelude.&'('Prelude.constrEq'(X1,Y1),Body)) :-
gen_constrEq_hnf_body([X2|Xs],[Y2|Ys],Body).
transbind(Cons/Arity) :-
functor(CX,Cons,Arity),
functor(CY,Cons,Arity),
CX =.. [_|Xs],
CY =.. [_|Ys],
gen_bind_body(Xs,Ys,E0,E,HnfBody),
gen_bind_occ_body(X,Ys,(X=CX,HnfBody),occursNot,Body),
writeClause((bind(X,CY,E0,E) :- !, Body)).
gen_bind_body([],[],E,E,true).
gen_bind_body([X|Xs],[Y|Ys],E0,E,(hnf(Y,HY,E0,E1),bind(X,HY,E1,E2),Body)) :-
gen_bind_body(Xs,Ys,E2,E,Body).
gen_bind_occ_body(_,[],RestBody,_,RestBody).
gen_bind_occ_body(X,[Y|Ys],RestBody,OccursNot,(OccursNot_X_Y,Body)) :-
OccursNot_X_Y =.. [OccursNot,X,Y],
gen_bind_occ_body(X,Ys,RestBody,OccursNot,Body).
transocc_not(OccursNot,Cons/Arity) :-
functor(CY,Cons,Arity),
CY =.. [_|Ys],
gen_bind_occ_body(X,Ys,true,OccursNot,Body),
OccursNot_X_CY =.. [OccursNot,X,CY],
writeClause((OccursNot_X_CY :- !, Body)).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% translation of clauses for (Boolean) strict equality test
......
......@@ -568,7 +568,7 @@ revTransFunctor(IntName,Name) :-
revTransFunctor(Name,Name).
% is this a class dictionary?
isInstDict(T) :- var(T), fail.
isInstDict(T) :- var(T), !, fail.
isInstDict(T) :- atom(T), !, isInstDictName(T).
isInstDict(T) :- number(T), !, fail.
isInstDict(T) :- T =.. [Name|_], isInstDictName(Name).
......
......@@ -23,7 +23,7 @@
% prim_try/4, prim_findall/4, waitUntilGround/3, prim_findfirst/4,
% prim_getOneSolution/4,
% prim_allValues/4, prim_someValue/4,, prim_oneValue/4,
% unifEq/5, unifEqLinear/5, prim_ifVar/6]).
% 'Prelude.=:<='/6, unifEqLinear/5, prim_ifVar/6]).
:- (current_module(prologbasics) -> true ; use_module('../prologbasics')).
:- (current_module(basics) -> true ; use_module('../basics')).
......@@ -757,16 +757,17 @@ allUnboundVariables(Vs) :-
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Directed non-strict equality for matching against functional patterns:
% (first argument must be the functional pattern):
:- block unifEq(?,?,?,-,?).
unifEq(A,B,R,E0,E):- user:hnf(A,HA,E0,E1), unifEq1(HA,B,R,E1,E).
:- block 'Prelude.=:<='(?,?,?,?,-,?).
'Prelude.=:<='(Dict,A,B,R,E0,E):-
user:hnf(A,HA,E0,E1), unifEq1(Dict,HA,B,R,E1,E).
:- block unifEq1(?,?,?,-,?).
:- block unifEq1(?,?,?,?,-,?).
% In the following clause, we bind a functional pattern variable to the
% actual argument. This binding of a logical variable against
% a non-constructor term is not problematic since the functional pattern
% variable is a logical variable that is not enclosed
% by a sharing structure (compare definition of makeShare).
unifEq1(FPat,ActArg,'Prelude.True',E0,E) :-
unifEq1(_,FPat,ActArg,'Prelude.True',E0,E) :-
var(FPat), !,
user:occursNot(FPat,ActArg),
%FPat=ActArg, % this would implement run-time choice
......@@ -777,15 +778,15 @@ unifEq1(FPat,ActArg,'Prelude.True',E0,E) :-
makeShare(ActArg,FPat),
%writeErr('BOUND TO: '), removeShares(ActArg,AA), writeErr(AA), nlErr,
E0=E.
unifEq1('FAIL'(Src),_,'FAIL'(Src),E,E):- !.
unifEq1(A,B,R,E0,E) :-
unifEq1(_,'FAIL'(Src),_,'FAIL'(Src),E,E):- !.
unifEq1(Dict,A,B,R,E0,E) :-
replaceMultipleVariables(A,LinA,LinConstraints),
user:hnf(B,HB,E0,E1),
unifEqHnf(LinA,HB,EqR,E1,E2),
unifEq2(EqR,LinConstraints,R,E2,E).
unifEqHnf(Dict,LinA,HB,EqR,E1,E2),
unifEq2(Dict,EqR,LinConstraints,R,E2,E).
:- block unifEq2(?,?,?,-,?).
unifEq2(EqR,LinConstraints,R,E0,E) :-
:- block unifEq2(?,?,?,?,-,?).
unifEq2(_,EqR,LinConstraints,R,E0,E) :-
isFail(EqR)
-> R=EqR, E0=E
; %(LinConstraints='Prelude.True' -> true
......@@ -858,28 +859,29 @@ replaceMultipleVariablesInArgs([Arg|Args],Below,Vars,[LinArg|LinArgs]) :-
LinArg =.. [FC|LinTs],
replaceMultipleVariablesInArgs(Args,Below,Vars,LinArgs).
:- block unifEqHnf(?,?,?,-,?).
unifEqHnf(A,B,Success,E0,E) :- var(B),!,
:- block unifEqHnf(?,?,?,?,-,?).
unifEqHnf(_,A,B,Success,E0,E) :- var(B),!,
user:bind(B,A,Success,E0,E). % in order to evaluate function pattern
unifEqHnf(_,'FAIL'(Src),'FAIL'(Src),E,E) :- !.
unifEqHnf(A,B,R,E0,E) :-
unifEqHnf(_,_,'FAIL'(Src),'FAIL'(Src),E,E) :- !.
unifEqHnf(Dict,A,B,R,E0,E) :-
number(A), !,
(A=B -> R='Prelude.True', E0=E
; prim_failure(partcall(2,'Prelude.unifEq',[]),[A,B],R,E0,E)).
unifEqHnf(A,B,R,E0,E) :-
; prim_failure(partcall(2,'Prelude.=:<=',[Dict]),[A,B],R,E0,E)).
unifEqHnf(Dict,A,B,R,E0,E) :-
functor(A,FuncA,ArA), functor(B,FuncB,ArB), FuncA==FuncB, ArA==ArB, !,
genUnifEqHnfBody(1,ArA,A,B,Con), user:hnf(Con,R,E0,E).
unifEqHnf(A,B,R,E0,E) :-
prim_failure(partcall(2,'Prelude.unifEq',[]),[A,B],R,E0,E).
genUnifEqHnfBody(1,ArA,Dict,A,B,Con), user:hnf(Con,R,E0,E).
unifEqHnf(Dict,A,B,R,E0,E) :-
prim_failure(partcall(2,'Prelude.=:<=',[Dict]),[A,B],R,E0,E).
genUnifEqHnfBody(N,Arity,_,_,'Prelude.True') :- N>Arity, !.
genUnifEqHnfBody(N,Arity,A,B,'Prelude.unifEq'(ArgA,ArgB)):-
genUnifEqHnfBody(N,Arity,_,_,_,'Prelude.True') :- N>Arity, !.
genUnifEqHnfBody(N,Arity,Dict,A,B,'Prelude.=:<='(Dict,ArgA,ArgB)):-
N=Arity, !,
arg(N,A,ArgA), arg(N,B,ArgB).
genUnifEqHnfBody(N,Arity,A,B,'Prelude.&'('Prelude.unifEq'(ArgA,ArgB),G)):-
genUnifEqHnfBody(N,Arity,Dict,A,B,
'Prelude.&'('Prelude.=:<='(Dict,ArgA,ArgB),G)):-
arg(N,A,ArgA), arg(N,B,ArgB),
N1 is N+1,
genUnifEqHnfBody(N1,Arity,A,B,G).
genUnifEqHnfBody(N1,Arity,Dict,A,B,G).
% Directed non-strict equality for matching against linear function patterns,
% i.e., it must be ensured that the first argument is always (after evalutation
......