%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% transformation of Flat-Curry programs into Prolog programs
%
% main predicate: (initializeCompilerState,) c2p(<progname>)

:- module(compiler,
	  [c2p/1, c2p/2,
	   loadMain/1, generateMainPlFile/2, deleteMainPrologFile/1,
	   forbiddenModules/1, writeClause/1,
	   readProg/5,
	   checkProgramHeader/1, deletePrologTarget/1,
	   maxTupleArity/1, tryXml2Fcy/1, varIndex2VarExp/2]).

:- use_module(prologbasics).
:- use_module(pakcsversion).
:- use_module(basics).
:- use_module(version).
:- use_module(pakcsversion).
:- use_module(external). % specification of external functions
:- use_module(readFlcFromFcy).
:- use_module(loader).
:- use_module(readPrimFile).

:- (swi7orHigher -> set_prolog_flag(double_quotes, codes) ; true).

:- dynamic numberOfShares/1,
	   maxTupleArity/1, includePrelude/0,
	   bugInFlcFile/0,
	   allFunctions/1, allConstructors/1,
	   externalFuncs/1, currentFunction/1,
	   newFunctionCounter/2, newAuxFunctions/1,
	   dynamicPredNames/1, forbiddenModules/1.

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Parameters for the transformation:

numberOfShares(0).   % count number of shared variables in a compiled program
includePrelude.      % Uncomment this if prelude should not be included
                     % (in this case, only the main program will be translated
                     %  which is useful for compiler debugging)
hnfTailCallOptim(no).% Should top-level hnf-calls to local functions in right-hand sides
                     % replaced by direct calls to predicates?
completeCases(yes).  % Should case expressions be completed with missing
                     % constructor branches and calls to Prelude.failure?
failForwarding(yes). % Include forward clause for failures in each case branch?
failCheckFunc(yes).  % Should code for forward failures in each function be
                     % included in hnf clauses?
maxTupleArity(15).   % The maximal arity of tuples

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

allModules([]).  % list of all modules (main + imported)
allFunctions([]).     % list of all defined functions
allConstructors([]).  % list of all constructors
externalFuncs([]).    % list of all external functions
currentFunction(unknown). % name of currently translated function (for errors)
newFunctionCounter([],0). % counter for generating new function names
newAuxFunctions([]). % list of generated auxiliary functions
                     % (for nested case/or)
dynamicPredNames([]). % list of pred names/file names for dynamic predicates
forbiddenModules([]). % module names that are not allowed (e.g., Unsafe)

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% for profiling:

% get cost center from function name:
getCostCenterOfName(NameS,CC) :-
	append(_,[123|NCC],NameS), % 123={
	append(CCS,[125|_],NCC), % 125=}
	append([123|CCS],[125],CCD),
	atom_codes(CC,CCD), !.
getCostCenterOfName(_,'').

deleteCostCenterInPrologName(NameCC,Name) :-
	atom_codes(NameCC,NameCCS),
	append(Name0,[39,55,66|NCC],NameCCS), % [39,55,66] = encoding of '{'
	append(_,[39,55,68|Name1],NCC), % [39,55,66] = encoding of '}'
	append(Name0,Name1,NameS),
	atom_codes(Name,NameS), !.
deleteCostCenterInPrologName(Name,Name).

% get all cost centers from list of defined functions:
addCostCenterOfFuncs(CCs,[],CCs).
addCostCenterOfFuncs(CCs,['Func'(Name,_,_,_,_)|Funcs],NewCCs) :-
	getCostCenterOfName(Name,CC),
	(member(CC,CCs) -> CCs1=CCs ; append(CCs,[CC],CCs1)),
	addCostCenterOfFuncs(CCs1,Funcs,NewCCs).

% write a cost center name without decoration:
writeCostCenter(Stream,CC) :-
	atom_codes(CC,CCS),
	append([123|CCNS],[125],CCS),
	atom_codes(CCN,CCNS),
	write(Stream,' '), write(Stream,CCN).


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

reportLiftBug :-
	writeLnErr('> Probably, this is due to a compiler bug in transforming'),
	writeLnErr('> do/let/where expressions. Suggested solution:'),
	writeLnErr('> Simplify dependencies in the do/let/where expression.'),
	setFlcBug.

pleaseReport :-
	writeLnErr('*** Please report this error to the PAKCS developers'),
	writeLnErr('*** if you have used the standard compiler!'),
	setFlcBug.


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

c2p(Prog) :-
	prog2PrologFile(Prog,PrologFile),
	c2p(Prog,PrologFile).

c2p(Prog,PrologFile) :-
	split2dirbase(Prog,ProgDir,ModName),
	loadPath(ProgDir,LoadPath),
	(includePrelude
	 -> readImportedEntities(LoadPath,[ModName],[],
				 [],[],[],_ImpTypes,_ImpFuncs,_ImpOps)
	  ; readProg(LoadPath,ModName,FlatProg,_,PrimPlFile),
	    generateProg(FlatProg,[],[],[],PrologFile,PrimPlFile)),
	!.
c2p(Prog,PrologFile) :-
	writeErr('ERROR during compilation of program "'),
	writeErr(Prog),
	writeLnErr('"!'),
	deleteFileIfExists(PrologFile).

% read all imported entities (types/functions/operators) of a set of modules:
readImportedEntities(_,[],_,ImpTypes,ImpFuncs,ImpOps,ImpTypes,ImpFuncs,ImpOps) :- !.
readImportedEntities(_,[Imp|_],_,_,_,_,_,_,_) :-
	forbiddenModules(ForbiddenModules),
	member(Imp,ForbiddenModules),
	writeErr('Module "'), writeErr(Imp),
	writeLnErr('" not allowed as import!'),
	setExitCode(3),
	!, fail.
readImportedEntities(LoadPath,[Imp|Imps],ProcessedImps,
		     ImpTypes,ImpFuncs,ImpOps,AllImpTypes,AllImpFuncs,AllImpOps) :-
	member(Imp,ProcessedImps),
	!,
	%write('*** already read: '), write(Imp), nl,
	readImportedEntities(LoadPath,Imps,ProcessedImps,
			     ImpTypes,ImpFuncs,ImpOps,AllImpTypes,AllImpFuncs,AllImpOps).
readImportedEntities(LoadPath,[Imp|Imps],ProcessedImps,
		     ImpTypes,ImpFuncs,ImpOps,AllImpTypes,AllImpFuncs,AllImpOps) :-
	%write('*** read next: '), write(Imp), nl,
        readInterface(LoadPath,Imp,ImpInterface,DirProg),
	ImpInterface = 'Prog'(_,ImportStrings,Types,Funcs,Ops),
	map2M(prologbasics:atomCodes,NewImports,ImportStrings),
	union(Imps,NewImports,AllImports),
	append(ImpTypes,Types,NewImpTypes),
	append(ImpFuncs,Funcs,NewImpFuncs),
	append(ImpOps,Ops,NewImpOps),
	readImportedEntities(LoadPath,AllImports,[Imp|ProcessedImps],
			     NewImpTypes,NewImpFuncs,NewImpOps,
			     AllImpTypes,AllImpFuncs,AllImpOps),
	prog2PrologFile(DirProg,PrologFile),
	(doesPrologTranslationExists(DirProg,PrologFile) -> true
	 ; readProg(LoadPath,Imp,ImpProg,AbsFlatProgFile,PrimPlFile),
	   (verbosityIntermediate
             -> appendAtoms(['Compiling \'',AbsFlatProgFile,'\' into \'',
	                     PrologFile,'\'...'],CompileMsg),
                writeErr(CompileMsg)
              ; true),
	   generateProg(ImpProg,AllImpTypes,AllImpFuncs,AllImpOps,PrologFile,
                        PrimPlFile),
	   (verbosityIntermediate -> writeLnErr('done') ; true)
        ).

doesPrologTranslationExists(DirProg,PrologFile) :-
	checkProgramHeader(PrologFile),
	prog2FlatCurryFile(DirProg,DirProgFlatFile),
	% check fcy file for date since interface might be older:
	fileExistsAndNewer(PrologFile,DirProgFlatFile),
        %writeErrNQ('Compiled Curry program \''),
	%writeErrNQ(PrologFile),
	%writeLnErrNQ('\' is up-to-date.'),
	!.


% initialize the state of the compiler, i.e., clean all tables and
% set all parameters to their default values:
initializeCompilerState :-
	%(retract(includePrelude) -> true ; true),
	%asserta(includePrelude),
	(retract(numberOfShares(_)) -> true ; true),
	asserta(numberOfShares(0)),
	(retract(allFunctions(_)) -> true ; true),
	asserta(allFunctions([])),
	(retract(allConstructors(_)) -> true ; true),
	asserta(allConstructors([])),
	(retract(externalFuncs(_)) -> true ; true),
	asserta(externalFuncs([])),
	(retract(newAuxFunctions(_)) -> true ; true),
	asserta(newAuxFunctions([])),
	(retract(dynamicPredNames(_)) -> true ; true),
	asserta(dynamicPredNames([])),
	% remove all non-standard infix declarations to avoid syntax errors
	% in compiled program:
	op(0,xfx,(+#)),
	op(0,xfx,(-#)),
	op(0,xfx,(*#)),
	op(0,xfx,(/#)),
	op(0,xfx,(=#)),
	op(0,xfx,(/=#)),
	op(0,xfx,(<#)),
	op(0,xfx,(<=#)),
	op(0,xfx,(>#)),
	op(0,xfx,(>=#)),
	op(0,xfx,(+.)),
	op(0,xfx,(-.)),
	op(0,xfx,(*.)),
	op(0,xfx,(/.)),
	op(0,xfx,(<.)),
	op(0,xfx,(<=.)),
	op(0,xfx,(>.)),
	op(0,xfx,(>=.)).


generateProg(Prog,ImpTypes,ImpFuncs,ImpOps,PrologFile,PrimPlFile) :-
	initializeCompilerState,
	(compileWithDebug
	 -> writeLnErr('...including code for debugging')
	  ; true),
	(compileWithFailPrint
	 -> writeLnErr('...including code for failure printing')
	  ; true),
	ensureDirOfFile(PrologFile),
        (existsFile(PrologFile)
         -> (isWritableFile(PrologFile)
             -> generateProgOnFile(Prog,ImpTypes,ImpFuncs,ImpOps,PrologFile,PrimPlFile)
              ; writeLnErr('WARNING: target file not updated (exists but not writable):'),
                writeLnErr(PrologFile))
          ; tryWriteFile(PrologFile),
            generateProgOnFile(Prog,ImpTypes,ImpFuncs,ImpOps,PrologFile,PrimPlFile)).


generateProgOnFile('Prog'(Mod,Imports,MainTypes,MainFuncs,MainOps),
             ImpTypes,ImpFuncs,ImpOps,PrologFile,PrimPlFile) :-
	tell(PrologFile),
	writePrologHeader,
	writeClause((:- noSingletonWarnings)),
	writeClause((:- noRedefineWarnings)),
	writeClause((:- noDiscontiguousWarnings)),
	nl,
	map1M(compiler:writeLoadImport,Imports), nl,
	writeProg(Mod,Imports,MainTypes,MainFuncs,MainOps,
		  ImpTypes,ImpFuncs,ImpOps),
	nl,
	dynamicPredNames(DynPreds),
	map1M(compiler:writeDynamicInfoClause,DynPreds),
	nl,
	write('%%%%% Number of shared variables: '),
	numberOfShares(SC), write(SC), nl, nl,
        (PrimPlFile = '' -> true
         ; (verbosityIntermediate
            -> writeErr('Adding code of Prolog file: '), writeLnErr(PrimPlFile)
             ; true),
           readPrimFile(PrimPlFile)),
	told, !.
generateProgOnFile(_,_,_,_,PrologFile,_) :-
	told,
	writeLnErr('ERROR during compiling, no program generated!'),
	deleteFileIfExists(PrologFile).

% write head of generated Prolog file:
writePrologHeader :-
	write('%'),
	compilerVersion(CV),
	write(CV), put_code(32),
	prologMajor(Prolog), write(Prolog),
	(compileWithSharing(variable) -> write(' VARIABLESHARING') ; true),
	(compileWithSharing(function) -> write(' FUNCTIONSHARING') ; true),
	nl, nl.

writeLoadImport(ImpModS) :-
	atom_codes(ImpMod,ImpModS),
	writeClause((:- importModule(ImpMod))).

% compute all external libraries to be included for externally defined functions:
getExternalLibraries([],Libs,Libs) :- !.
getExternalLibraries(['Func'(_,_,_,_,'External'(EStr))|Funcs],Libs,AllLibs) :-
	append(LibS,[32|_],EStr), % ext.names have the form "lib ename"
	!,
	atom_codes(Lib,LibS),
        % LibS=[] if the external function is defined without a specification
        % so that its code must be in a standard Prolog file
	((LibS=[] ; member(Lib,Libs)) -> Libs1=Libs ; Libs1=[Lib|Libs]),
	getExternalLibraries(Funcs,Libs1,AllLibs).
getExternalLibraries([_|Funcs],Libs,AllLibs) :-
	getExternalLibraries(Funcs,Libs,AllLibs).

% write directive for necessary inclusion of standard libraries (ports,...):
writeLibraryInclusion(Lib) :-
	writeClause((:- ensure_lib_loaded(Lib))),
	(Lib = prim_dynamic
	 -> writeClause((:- initializationsInModule(prim_dynamic:initializeDynamic)))
	  ; true).


% try translating XML file into .fcy file:
tryXml2Fcy(Prog) :-
	prog2FlatCurryFile(Prog,FlatFile),
	appendAtom(Prog,'.curry',CurryFile),
	appendAtom(Prog,'_flat.xml',XmlFile),
	\+ existsFile(CurryFile),
	\+ existsFile(FlatFile),
	existsFile(XmlFile),
	% translate XML file into .fcy file:
	installDir(PH),
	appendAtoms([PH,'/tools/curry2xml -fcy ',Prog],Cmd),
	%write('Executing: '), write(Cmd), nl,
	shellCmdWithCurryPath(Cmd),
	!.
tryXml2Fcy(_).


% read a FlatCurry interface (or .fcy file if interface does not exist):
readInterface(LoadPath,Prog,FlatInt,DirProgName) :-
	readInterfaceInLoadPath(LoadPath,Prog,FlatInt,DirProgName), !.
readInterface(LoadPath,Prog,_,_) :-
	write('ERROR: Interface or FlatCurry file '), write(Prog),
	write('.[fcy|fint] not found!'), nl,
	write('Current load path: '), write(LoadPath), nl,
	!, fail.

readInterfaceInLoadPath([Dir|Dirs],Prog,FlatInt,DirProgName) :-
	appendAtoms([Dir,'/',Prog],DirProg),
	prog2InterfaceFile(DirProg,DirProgFint),
	(existsFile(DirProgFint)
	 -> DirProgFile=DirProgFint
	  ; prog2FlatCurryFile(DirProg,DirProgFile)),
	(existsFile(DirProgFile)
	 -> readFlcFromFcy(DirProgFile,FlatInt),
	    DirProgName = DirProg,
	    (verbosityIntermediate
	     -> checkForFurtherFcyProgs(Dir,Dirs,Prog)
	      ; true)
	  ; readInterfaceInLoadPath(Dirs,Prog,FlatInt,DirProgName)).

% read a FlatCurry program:
readProg(LoadPath,Prog,FlatProg,AbsFlatProgFile,PrimPlFile) :-
	readProgInLoadPath(LoadPath,Prog,FlatProg,AbsFlatProgFile,PrimPlFile), !.
readProg(LoadPath,Prog,_,_,_) :-
	write('ERROR: FlatCurry file '), write(Prog),
	write('.fcy not found!'), nl,
	write('Current load path: '), write(LoadPath), nl,
	!, fail.

readProgInLoadPath([Dir|Dirs],Prog,FlatProg,AbsFlatProgFile,PrimPlFile) :-
	appendAtoms([Dir,'/',Prog],DirProg),
	prog2FlatCurryFile(DirProg,DirProgFile),
	tryXml2Fcy(DirProg),
	(existsFile(DirProgFile)
	 -> preprocessFcyFile(DirProgFile),
            readFlcFromFcy(DirProgFile,PlainFlatProg),
	    AbsFlatProgFile = DirProgFile,
	    mergeWithPrimitiveSpecs(PlainFlatProg,DirProg,FlatProg),
	    (verbosityIntermediate
	     -> checkForFurtherFcyProgs(Dir,Dirs,Prog) ; true),
            findPrimPrologFile(DirProg,PrimPlFile)
	  ; readProgInLoadPath(Dirs,Prog,FlatProg,AbsFlatProgFile,PrimPlFile)).

% Pre-process the FlatCurry program before loading for compilation.
% Currently, the binding optimizer (replace =:=/2 by ==/2) is applied.
preprocessFcyFile(_) :- pakcsrc(bindingoptimization,no), !.
preprocessFcyFile(FcyFile) :-
    installDir(PH),
    appendAtoms([PH,'/currytools/optimize/BindingOpt'],OptProg),
    existsFile(OptProg), !,
    verbosity(VL),
    (VL=0 -> OptVL=48 ; OptVL is VL+47),
    atom_codes(VParam,[45,118,OptVL,32]), % define -vN
    (pakcsrc(bindingoptimization,fast) -> FParam='-f ' ; FParam=' '),
    appendAtoms(['"',OptProg,'" ',VParam,FParam,'"',FcyFile,'"'],OptCmd),
    (verbosityIntermediate -> write('Executing: '), write(OptCmd),nl ; true),
    (shellCmdWithCurryPath(OptCmd) -> true
     ; writeLnErr('WARNING: binding optimization failed for file:'),
       writeLnErr(FcyFile)).
preprocessFcyFile(FcyFile) :-
    writeLnErr('WARNING: no binding optimization performed for file:'),
    writeLnErr(FcyFile).

checkForFurtherFcyProgs(_,[],_).
checkForFurtherFcyProgs(FcyDir,[Dir|Dirs],Prog) :-
	appendAtoms([Dir,'/',Prog],DirProg),
	prog2FlatCurryFile(DirProg,DirProgFile),
	((existsFile(DirProgFile), \+ equalDirectories(FcyDir,Dir))
	 -> writeErrNQ('WARNING: further FlatCurry file found (but ignored): '),
	    writeLnErrNQ(DirProgFile),
	    checkForFurtherFcyProgs(FcyDir,Dirs,Prog)
	  ; checkForFurtherFcyProgs(FcyDir,Dirs,Prog)).

% are two directories identical?
equalDirectories(Dir1,Dir2) :-
	% a bit complicate solution, but this works also for links
	absolute_file_name(Dir1,AbsDir1),
	absolute_file_name(Dir2,AbsDir2),
	workingDirectory(WDir),
	setWorkingDirectory(AbsDir1), absolute_file_name('.',AbsDir1a),
	setWorkingDirectory(AbsDir2), absolute_file_name('.',AbsDir2a),
	setWorkingDirectory(WDir),
	!,
	AbsDir1a=AbsDir2a.


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% try to read primitive function specification file and merge infos into
% external functions:
mergeWithPrimitiveSpecs(PlainFlatProg,DirProg,FlatProg) :-
        prog2DirProg(DirProg,RealDirProg),
	PlainFlatProg = 'Prog'(ModName,_,_,_,_),
	findPrimXmlFile(RealDirProg,PrimXmlFile),
	!,
	(verbosityIntermediate
	 -> writeErr('>>> Reading '),
	    writeErr(PrimXmlFile), writeErr(' ... '),
	    getRunTime(RT1) ; true),
	readPrimitiveXmlSpecs(PrimXmlFile,PrimSpecs),
	(verbosityIntermediate
	 -> getRunTime(RT2),
	    RT is RT2-RT1,
	    writeErr(RT), writeLnErr(' ms.')
	  ; true),
        append(ModName,[46],ModNameDotS), atom_codes(ModNameDot,ModNameDotS),
	map2partialM(compiler:addModuleName2PrimSpecs(ModNameDot),PrimSpecs,QPrimSpecs),
	addPrimitiveSpecs2FlatProg(PlainFlatProg,QPrimSpecs,FlatProg).
mergeWithPrimitiveSpecs(PlainFlatProg,_,FlatProg) :-
	addPrimitiveSpecs2FlatProg(PlainFlatProg,[],FlatProg).

findPrimXmlFile(RealDirProg,PrimXmlFile) :-
        appendAtom(RealDirProg,'.pakcs',PrimXmlFile),
	existsFile(PrimXmlFile), !.
findPrimXmlFile(RealDirProg,PrimXmlFile) :-
        appendAtom(RealDirProg,'.prim_c2p',PrimXmlFile),
	existsFile(PrimXmlFile), !.

% look for a Prolog file (with suffix .pakcs.pl) containing code
% for primitive operations to be added to the generated Prolog file
findPrimPrologFile(DirProg,PrimPrologFile) :-
        prog2DirProg(DirProg,RealDirProg),
        appendAtom(RealDirProg,'.pakcs.pl',PrimPrologFile),
	existsFile(PrimPrologFile),
        !.
findPrimPrologFile(_,'').

addModuleName2PrimSpecs(ModNameDot,primitive(F,N,Mod,Entry),primitive(QF,N,Mod,Entry)) :-
	ModNameDot='prelude.', !, appendAtom('Prelude.',F,QF).
addModuleName2PrimSpecs(ModNameDot,primitive(F,N,Mod,Entry),primitive(QF,N,Mod,Entry)) :-
	appendAtom(ModNameDot,F,QF).
addModuleName2PrimSpecs(ModNameDot,ignore(F,N),ignore(QF,N)) :-
	ModNameDot='prelude.', !, appendAtom('Prelude.',F,QF).
addModuleName2PrimSpecs(ModNameDot,ignore(F,N),ignore(QF,N)) :-
	appendAtom(ModNameDot,F,QF).

addPrimitiveSpecs2FlatProg('Prog'(ModName,Imps,Types,Funcs,Ops),PrimSpecs,
                           'Prog'(ModName,Imps,Types,ModFuncs,Ops)) :-
        addPrimitiveSpecs2Funcs(PrimSpecs,Funcs,ModFuncs).

% format a primitive specification (e.g., for error messages):
writePrimSpec(primitive(F,Arity,ELib,_EName)) :-
	writeErr(F), writeErr('/'), writeErr(Arity), writeErr(' in library "'),
	writeErr(ELib), writeLnErr('"').
writePrimSpec(ignore(F,Arity)) :-
	writeErr(F), writeErr('/'), writeLnErr(Arity).

% process list of function declarations w.r.t. primitive specification:
addPrimitiveSpecs2Funcs([],[],[]) :- !.
addPrimitiveSpecs2Funcs(PrimSpecs,[],[]) :-
	writeErrNQ('WARNING: specifications of primitive functions '),
	writeLnErrNQ('without source code found:'),
	(quietmode(no) -> map1M(compiler:writePrimSpec,PrimSpecs) ; true), !.
addPrimitiveSpecs2Funcs(PrimSpecs,['Func'(Name,Arity,_,_,_)|Funcs],MFuncs) :-
	flatName2Atom(Name,F),
	deleteCostCenterInPrologName(F,FWOCC),
	deleteFirst(ignore(FWOCC,EArity),PrimSpecs,DPrimSpecs), !,
	checkArityConsistency(F,Arity,EArity),
	addPrimitiveSpecs2Funcs(DPrimSpecs,Funcs,MFuncs).
addPrimitiveSpecs2Funcs(PrimSpecs,
			['Func'(Name,Arity,Vis,Type,_)|Funcs],
     	                ['Func'(Name,Arity,Vis,Type,'External'(EStr))|MFuncs]) :-
	flatName2Atom(Name,F),
	deleteCostCenterInPrologName(F,FWOCC),
	deleteFirst(primitive(FWOCC,EArity,EMod,EName),PrimSpecs,DPrimSpecs), !,
	checkArityConsistency(F,Arity,EArity),
	atom_codes(EMod,EModS),
	atom_codes(EName,ENameS),
	append(EModS,[32|ENameS],EStr),
	addPrimitiveSpecs2Funcs(DPrimSpecs,Funcs,MFuncs).
addPrimitiveSpecs2Funcs(PrimSpecs,
			['Func'(Name,Arity,Vis,Type,'External'(EStr))|Funcs],
			['Func'(Name,Arity,Vis,Type,'External'(EStr))|MFuncs]) :-
	append(_,[32|_],EStr), % has the form of an already known primitive
	!,
	addPrimitiveSpecs2Funcs(PrimSpecs,Funcs,MFuncs).
addPrimitiveSpecs2Funcs(PrimSpecs,
			['Func'(Name,Arity,Vis,Type,'External'(_))|Funcs],
     	                ['Func'(Name,Arity,Vis,Type,'External'(EStr))|MFuncs]) :-
	flatName2Atom(Name,F),
	deleteCostCenterInPrologName(F,PWOCC), decodePrologName(PWOCC,FWOCC),
        appendAtom(' ',FWOCC,EName), atom_codes(EName,EStr), !,
        (verbosityIntermediate
         -> writeErr('*** No specification of primitive function '),
            writeErr(FWOCC), writeErr('/'), writeLnErr(Arity),
            writeErr('*** Using external name:'), writeLnErr(EName)
          ; true),
     	addPrimitiveSpecs2Funcs(PrimSpecs,Funcs,MFuncs).
   
%addPrimitiveSpecs2Funcs(_,['Func'(Name,Arity,_,_,'External'(_))|_],_) :-
%	flatName2Atom(Name,F),
%	deleteCostCenterInPrologName(F,PWOCC), decodePrologName(PWOCC,FWOCC),
%	writeErr('ERROR: specification of primitive function '),
%	writeErr(FWOCC), writeErr('/'), writeErr(Arity),
%	writeLnErr(' not found!'), !, setFlcBug, fail.
addPrimitiveSpecs2Funcs(PrimSpecs,[Func|Funcs],[Func|MFuncs]) :-
	addPrimitiveSpecs2Funcs(PrimSpecs,Funcs,MFuncs).

checkArityConsistency(FName,FArity,EArity) :-
	(FArity=EArity -> true
         ; writeErr('ERROR in specification of primitive function '),
	   writeErr(FName), writeLnErr(' : inconsistent arities!'),
	   setFlcBug).


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% The main compiler for individual FlatCurry modules:

writeProg(Mod,Imports,MainTypes,MainFuncs,MainOps,ImpTypes,ImpFuncs,ImpOps) :-
	append(MainTypes,ImpTypes,AllTypes),
	append(MainOps,ImpOps,AllOps),
	atom_codes(ModName,Mod),
	writeClause((:- curryModule(ModName))), nl,
	getExternalLibraries(MainFuncs,[],ExtLibs),
	map1M(compiler:writeLibraryInclusion,ExtLibs), nl,
	% redundant checking, could be omitted if front end is correct:
	(retract(bugInFlcFile) -> true ; true),
	map1M(compiler:check_flcFunction,MainFuncs),
	\+ bugInFlcFile,
	(plprofiling(yes) -> addCostCenterOfFuncs([''],MainFuncs,CCs) ; CCs=['']),
	CCs=[_|NewCCs],
	(NewCCs=[] -> true
	 ; writeErr('...including code for profiling cost centers:'),
	   map1partialM(compiler:writeCostCenter(user_error),NewCCs),
	   nlErr),
	computeAllExternalFunctions(MainFuncs,ExtFuncs),
	(retract(externalFuncs(_)) -> true ; true),
	asserta(externalFuncs(ExtFuncs)),
	(map2M(compiler:elimNestedOrCases,MainFuncs,CodeFuncsWOnestedcase)
	 -> true
	  ; writeLnErr('INTERNAL COMPILER ERROR in or/case lifter!'),
	    fail),
	newAuxFunctions(TmpAuxFuns), rev(TmpAuxFuns,RevAuxFuns),
	append(CodeFuncsWOnestedcase,AllTypes,CodeFuncsAndAllTypes),
	append(CodeFuncsAndAllTypes,ImpFuncs,AllFunData),
	computeCorrectType(AllFunData,RevAuxFuns,AuxFuns),
	append(CodeFuncsWOnestedcase,AuxFuns,CodeFuncsOIS),
	(completeCases(no) -> CodeFuncsOISTotal=CodeFuncsOIS
	 ; (map2partialM(compiler:completeCaseExpressions(AllTypes),
		        CodeFuncsOIS,CodeFuncsOISTotal)
 	    -> true
	     ; writeLnErr('INTERNAL COMPILER ERROR in case branch completion!'),
	       fail)),
	append(CodeFuncsOISTotal,ImpFuncs,AllFuncs),
	map2M(compiler:flcFunc2FA,AllFuncs,AllFuncsArities),
	retract(allFunctions(_)), asserta(allFunctions(AllFuncsArities)),
	write('%%%%%%%%%%%% function types %%%%%%%%%%%%%%%%%%%'), nl,
	writeClause((:- multifile functiontype/6)),
	writeClause((:- dynamic functiontype/6)),
	map1partialM(compiler:writeFTypeClause(ExtFuncs,AllOps),CodeFuncsOISTotal), nl,
	write('%%%%%%%%%%%% constructor types %%%%%%%%%%%%%%%%%%%'), nl,
	writeClause((:- multifile constructortype/7)),
	writeClause((:- dynamic constructortype/7)),
	(member("Prelude",Imports) -> true
	 ; % generate type clause for partcall in the prelude:
	   writeClause(constructortype(partcall,partcall,3,partcall,0,
	    'FuncType'('TCons'('Int',[]),
		       'FuncType'(_,'FuncType'('TCons'([],[_]),_)))))),
	map1M(compiler:writeDTypeClause,MainTypes), nl,

	getConstructors(AllTypes,ConsList),
	retract(allConstructors(_)), asserta(allConstructors(ConsList)),
	write('%%%%%%%%%%%% function definitions %%%%%%%%%%%%%%%%%%%'), nl,
	map1M(compiler:writeFunc,CodeFuncsOISTotal),

	writeClause((:- costCenters(CCs))), nl,
	!,
	\+ bugInFlcFile,
	nl.

writeGenericClauses(CCs) :-
	write('%%%%%%%%%%%% clauses for generic operations %%%%%%%%%%%%%%%%%%%'), nl,
	map1M(compiler:transConstrEq,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),
	transDeref(CCs).

% "Linker" for separate compilation:
% create a file containing hnf clauses for all currently loaded functions
% and the generic clauses to define =:=, ==, nf, etc:
generateMainPlFile(_PrologFile,MainFile) :-
	currentCostCenters(CCs),
	mainPrologFileName(MainFile),
	tell(MainFile),
	writeClause((:- noSingletonWarnings)),
	writeClause((:- noDiscontiguousWarnings)),
	nl,
	writeClause((retractClause(LHS,RHS) :- retract((LHS :- RHS)))),
	nl,
	write('%%%%%%%%%%%% hnf clauses %%%%%%%%%%%%%%%%%%%'), nl,
	transHnfCurrent(CCs),
	writeGenericClauses(CCs),
	told.

% create main file, load it and delete it if not in profiling mode:
loadMain(PrologFile) :-
	generateMainPlFile(PrologFile,MainPrologFile),
	compilePrologFile(MainPrologFile),
	deleteMainPrologFile(MainPrologFile).

deleteMainPrologFile(MainPrologFile) :-
	((plprofiling(yes) ; pakcsrc(keepfiles,yes))
	 -> true % prog.pl.main needed later for PlProfileData.getHnfDefinitions
          ; % delete MainPrologFile:
	    deleteFile(MainPrologFile)).
	
% a call to this predicate sets the global error flat so that no compiled
% program is produced:
setFlcBug :- bugInFlcFile -> true ; assertz(bugInFlcFile).

% check for deprecated functions and print warning:
checkForDeprecatedFunction(Name) :-
	member(Name,['Term.readTerm','Term.readQTerm','Term.showTerm',
		     'Term.showQTerm',
		     'ReadShowTerm.readTerm','ReadShowTerm.readsTerm',
		     'System.getDate','System.showDate',
		     'FlatTools.writeFLC','FlatCurryTools.writeFLC',
		     'FileGoodies.findFileInPath',
		     'HTML.Form','HTML.HtmlElem',
		     'HTML.showHtmlDoc','HTML.showHtmlDocCSS',
		     'Ports.openSocketConnectPort']), !,
	writeErrNQ('WARNING: do not use deprecated function "'),
	writeErrNQ(Name),
	writeLnErrNQ('".').
checkForDeprecatedFunction(_).

% check for ocurrences of constructors of Dynamic type and print error:
checkForDynamicConstructor(Name) :-
	member(Name,['Dynamic.dynamic','Dynamic.persistent',
		     'Global.global','GlobalVariable.gvar']),
	currentFunction(QFunc),
	!,
	writeErr('ERROR in "'),
	writeErr(QFunc),
	writeErr('": Function "'),
	writeErr(Name),
	writeLnErr('" is not allowed in this context!'),
	setFlcBug.
checkForDynamicConstructor(_).

% check for maximal arity of tuples and print warning:
checkForTupleArity([40,44|Name]) :-
	length([44|Name],TA),
	maxTupleArity(MA),
	TA>MA, !,
	currentFunction(QFunc),
	writeErr('ERROR in "'),
	writeErr(QFunc),
	writeErr('": arity of '), writeErr(TA),
	writeLnErr('-tupel too large.'),
	writeErr('The maximal arity of tuples is '), writeErr(MA),
	writeLnErr('.'),
	writeLnErr('This can only be changed by reconfiguring your installation'),
	setFlcBug.
checkForTupleArity(_).


% compute all external functions in this program:
computeAllExternalFunctions([],[]).
computeAllExternalFunctions(['Func'(Name,Arity,_,_Type,'External'(EStr))|Funcs],
			    [(F/Arity,EStr)|EFs]) :- !,
	flatName2Atom(Name,F),
	computeAllExternalFunctions(Funcs,EFs).
computeAllExternalFunctions([_|Funcs],EFs) :-
	computeAllExternalFunctions(Funcs,EFs).


% transform Flat-Curry representation of a function into name/arity pair
% where the arity is the arity of the final (eta-expanded) function:
flcFunc2FA('Func'(Name,Arity,_,_Type,_),F/Arity) :- flatName2Atom(Name,F).

getConstructors([],Cs) :-
	TupleCons = ['Prelude.()'/0,'Prelude.(,)'/2,'Prelude.(,,)'/3,
		     'Prelude.(,,,)'/4,'Prelude.(,,,,)'/5],
	(includePrelude
          -> Cs=[partcall/3,'$stream'/1] % all standard constructors defined in prelude
           ; Cs=[partcall/3,'Prelude.True'/0,'Prelude.False'/0,
		 []/0,'.'/2|TupleCons]).
getConstructors(['Type'(_,_,_,DataCons)|Types],AllCons) :-
	getDataCons(DataCons,DCs),
	getConstructors(Types,TCs),
	append(DCs,TCs,AllCons).

getDataCons([],[]).
getDataCons(['Cons'(Name,Arity,_,_)|DataCons],[Con/Arity|DCs]) :-
	flatName2Atom(Name,Con),
	getDataCons(DataCons,DCs).

% compute the arity of a constructor from the list of all stored constructors
% (fail if arity not found):
getConsArity(Cons,Arity) :-
	allConstructors(CAs), getArity(CAs,Cons,Arity).

% compute the arity of a function from the list of all stored functions:
% (error message and fail if arity not found):
getFuncArity(Func,Arity) :-
	allFunctions(FAs), getArity(FAs,Func,Arity), !.
getFuncArity(Func,Arity) :- % special case for tuples:
	atom_codes(Func,[40,44|Commas]),
	length([44|Commas],Arity), !.
getFuncArity(Func,_) :-
	writeErr('ERROR (illegal FlatCurry file?): Arity of function '),
	writeErr(Func),
	writeErr(' (used in function '),
	currentFunction(CF), writeErr(CF), writeErr(')'),
	writeLnErr(' not found!'), !, fail.

getArity([Name/Arity|_],Name,Arity) :- !.
getArity([_|FAs],Name,Arity) :- getArity(FAs,Name,Arity).


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% pre-transformation of defined functions:
% possibly add missing arguments in case of higher-order equations,
% i.e., in this implementation all functions are defined by first-order
% rules

% compute argument number (of uncurryfied function) from the functions type:
argnum('FuncType'(_,T2),N) :-
	argnum(T2,N2), N is N2+1.
argnum('TVar'(_),0).
argnum('TCons'(TC,_),N) :- TC="Prelude.IO" -> N=1 ; N=0.

% compute maximum variable index in a term (list):
maxVarIndex('Var'(V),V).
maxVarIndex('Lit'(_),-1).
maxVarIndex('Comb'(_,_,Es),M) :- map2M(compiler:maxVarIndex,Es,Ms), maxList(Ms,M).
maxVarIndex('Free'(Vs,E),M) :-
	maxList(Vs,Ms), maxVarIndex(E,ME), max(Ms,ME,M).
maxVarIndex('Or'(E1,E2),M) :-
	maxVarIndex(E1,M1), maxVarIndex(E2,M2), max(M1,M2,M).
maxVarIndex('Case'(_,E,Cs),M) :-
	maxVarIndex(E,ME), map2M(compiler:maxVarCase,Cs,Ms), maxList(Ms,MC),
	max(MC,ME,M).

maxVarCase('Branch'('Pattern'(_,Vs),E),M) :-
	maxList(Vs,Ms), maxVarIndex(E,ME), max(Ms,ME,M).
maxVarCase('Branch'('LPattern'(_),E),M) :-
	maxVarIndex(E,M).

% maximum of a list of naturals:
maxList([],-1).
maxList([X|Xs],M) :- maxList(Xs,Ms), max(X,Ms,M).

max(X,Y,Z) :- X>Y -> Z=X ; Z=Y.

% for simplicity, we generate negative variable indices here:
genVarIndices(_,0,[]).
genVarIndices(Max,N,[I|Is]) :-
	N>0, I is Max+1, N1 is N-1,
	genVarIndices(I,N1,Is).


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% complete case branches with fail branches for missing constructors:
completeCaseExpressions(Types,
			'Func'(Name,Arity,Vis,Type,'Rule'(Args,RHS)),
			'Func'(Name,Arity,Vis,Type,'Rule'(Args,NewRHS))) :-
	!,
	%atom_codes(A,Name), writeLnErr(completeCase(A)),
	completeCaseInExp(Name,Types,RHS,NewRHS).
completeCaseExpressions(_,Func,Func).

completeCaseInExp(_,_,'Var'(V),'Var'(V)).
completeCaseInExp(_,_,'Lit'(V),'Lit'(V)).
completeCaseInExp(FName,Types,'Comb'(CT,CF,Args),'Comb'(CT,CF,NewArgs)) :-
	map2partialM(compiler:completeCaseInExp(FName,Types),Args,NewArgs).
completeCaseInExp(FName,Types,'Free'(Vs,E),'Free'(Vs,NE)) :-
	completeCaseInExp(FName,Types,E,NE).
completeCaseInExp(FName,Types,'Case'(CT,C,Cases),'Case'(CT,C,NewCases)) :- !,
	getMissingBranchConstructors(Types,Cases,Cs),
	(Cs=[] -> MissingCases=[]
	        ; map2partialM(compiler:generateMissingBranch(FName),
		              Cs,MissingCases)),
	map2partialM(compiler:completeCaseInBranch(FName,Types,CT),Cases,NCases),
	append(NCases,MissingCases,NewCases).
completeCaseInExp(FName,Types,'Or'(E1,E2),'Or'(NE1,NE2)) :- !,
	completeCaseInExp(FName,Types,E1,NE1),
	completeCaseInExp(FName,Types,E2,NE2).
completeCaseInExp(FName,Types,'Let'(Bs,E),'Let'(NBs,NE)) :- !,
	map2partialM(compiler:completeCaseInBinding(FName,Types),Bs,NBs),
	completeCaseInExp(FName,Types,E,NE).

completeCaseInBinding(FName,Types,'Prelude.(,)'(V,E),'Prelude.(,)'(V,NE)) :-
	completeCaseInExp(FName,Types,E,NE).

completeCaseInBranch(FName,_,'Rigid',
		     'Branch'('Pattern'(Cons,Args),
			      'Comb'('FuncCall',FailedName,[])),
		     'Branch'('Pattern'(Cons,Args),FailureExp)) :-
	atom_codes('Prelude.failed',FailedName), !,
	% change Prelude.failed branch which is inserted by the front-end
	% in rigid case expressions:
	atom_codes('Prelude.failure',FailFuncName),
	atom_codes('Prelude.[]',EmptyList),
	atom_codes('Prelude.:',ConsList),
	FNameExp = 'Comb'('FuncCall',FName,[]),
	map2M(compiler:varIndex2VarExp,Args,ArgExps),
	ConsExp = 'Comb'('ConsCall',Cons,ArgExps),
	ArgExp = 'Comb'('ConsCall',ConsList,[ConsExp,
					     'Comb'('ConsCall',EmptyList,[])]),
	FailureExp = 'Comb'('FuncCall',FailFuncName,[FNameExp,ArgExp]).
completeCaseInBranch(FName,Types,_,'Branch'(Pat,Exp),'Branch'(Pat,NewExp)) :-
	completeCaseInExp(FName,Types,Exp,NewExp).

generateMissingBranch(FName,Cons/Arity,'Branch'('Pattern'(Cons,Args),Failed)) :-
	length(Args,Arity), numberVarList(100,Args),
	atom_codes('Prelude.failure',FailFuncName),
	atom_codes('Prelude.[]',EmptyList),
	atom_codes('Prelude.:',ConsList),
	FNameExp = 'Comb'('FuncCall',FName,[]),
	map2M(compiler:varIndex2VarExp,Args,ArgExps),
	ConsExp = 'Comb'('ConsCall',Cons,ArgExps),
	ArgExp = 'Comb'('ConsCall',ConsList,[ConsExp,
					     'Comb'('ConsCall',EmptyList,[])]),
	Failed = 'Comb'('FuncCall',FailFuncName,[FNameExp,ArgExp]).

numberVarList(_,[]).
numberVarList(N,[N|Vs]) :- N1 is N+1, numberVarList(N1,Vs).


getMissingBranchConstructors(Type,Branches,MissingCons) :-
	getBranchConstructors(Branches,BCons),
	getMissingConstructors(Type,BCons,MissingCons).

getMissingConstructors(_,[],[]). % nothing missing in case of LPatterns
getMissingConstructors(Types,[C|Cs],MissingCons) :-
	getConsOfType(Types,C,TypeCons),
	diff(TypeCons,[C|Cs],MissingCons).

getConsOfType(['Type'(_,_,_,TypeCons)|_],C/A,Cons) :-
	member('Cons'(C,A,_,_),TypeCons), !,
	map2M(compiler:getDataConsNameArity,TypeCons,Cons).
getConsOfType([_|Types],C,TypeCons) :- getConsOfType(Types,C,TypeCons).

getDataConsNameArity('Cons'(C,A,_,_),C/A).

getBranchConstructors([],[]).
getBranchConstructors(['Branch'('Pattern'(Cons,Args),_)|Bs],[Cons/A|Cs]) :-
	length(Args,A),
	getBranchConstructors(Bs,Cs).
getBranchConstructors(['Branch'('LPattern'(_),_)|Bs],Cs) :-
	getBranchConstructors(Bs,Cs).


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% eliminate nested or/case expressions in right-hand sides of function
% definitions:
elimNestedOrCases('Func'(Name,Arity,Vis,Type,'Rule'(Args,RHS)),
		  'Func'(Name,Arity,Vis,Type,'Rule'(Args,NewRHS))) :-
	!,
	(retract(newFunctionCounter(_,_)) -> true ; true),
	asserta(newFunctionCounter(Name,0)),
	elimNestedCasesInRHS(RHS,NewRHS).
elimNestedOrCases('Func'(Name,Arity,Vis,Type,'External'(EName)),
		  'Func'(Name,Arity,Vis,Type,'External'(EName))) :- !.
elimNestedOrCases(Arg,Arg) :-
	writeErr('ERROR: Illegal argument in elimNestedOrCases: '),
	writeLnErr(Arg).

% remove nested cases in right-hand side:
elimNestedCasesInRHS('Case'(CT,CE,Cases),'Case'(CT,NCE,NewCases)) :- !,
	elimCasesInExp(CE,NCE),
	elimNestedCasesInBranches(Cases,NewCases).
elimNestedCasesInRHS('Or'(E1,E2),'Or'(NE1,NE2)) :- !,
	elimNestedCasesInRHS(E1,NE1),
	elimNestedCasesInRHS(E2,NE2).
elimNestedCasesInRHS(Exp,NewExp) :- elimCasesInExp(Exp,NewExp).

elimNestedCasesInBranches([],[]).
elimNestedCasesInBranches(['Branch'(Pat,Exp)|Cs],
	                  ['Branch'(Pat,NewExp)|NCs]) :-
	elimNestedCasesInRHS(Exp,NewExp),
	elimNestedCasesInBranches(Cs,NCs).


elimCasesInExp('Var'(V),'Var'(V)).
elimCasesInExp('Lit'(L),'Lit'(L)).
elimCasesInExp('Comb'(CT,CF,Args),'Comb'(CT,CF,NewArgs)) :-
	map2M(compiler:elimCasesInExp,Args,NewArgs).
elimCasesInExp('Free'(Vs,E),'Free'(Vs,NE)) :-
	elimCasesInExp(E,NE).
elimCasesInExp('Or'(E1,E2),'Comb'('FuncCall',FNew,FVExps)) :-
	% elimCasesInExp(E1,NE1), no need to do that.
	% elimCasesInExp(E2,NE2),
	freeVarsInExp('Or'(E1,E2),FVs),
	map2M(compiler:varIndex2VarExp,FVs,FVExps),
	genAuxFuncName(FNew),
	length(FVs,FNArity),
        elimNestedOrCases('Func'(FNew,FNArity,'Private',
				 'TVar'(0), % here I am too lazy
			                    % to compute the correct type
				 'Rule'(FVs,'Or'(E1,E2))),ElimF),
        addAuxFunction(ElimF).
elimCasesInExp('Case'(CT,CE,Branches),
	       'Comb'('FuncCall',FNew,[NCE|FVExps])) :-
	elimCasesInExp(CE,NCE),
	% elimCasesInBranches(Branches,NewBranches),
	freeVarsInBranches(Branches,FVs),
	map2M(compiler:varIndex2VarExp,FVs,FVExps),
	genAuxFuncName(FNew),
	length(FVs,FVLength),
	FNArity is FVLength+1,
	newVarIndex(0,FVs,CVI),
	elimNestedOrCases('Func'(FNew,FNArity,'Private',
				 'TVar'(0), % here I am too lazy
			                    % to compute the correct type
				 'Rule'([CVI|FVs],'Case'(CT,'Var'(CVI),Branches))),
                         ElimF),
        addAuxFunction(ElimF).
% preliminary solution (hack?): transform (Let [(x1,e1),...,(xn,en)] e) into
% (Constr2 [x1,...,xn] (letrec x1 e1 &>...&> letrec xn en &> e)
elimCasesInExp('Let'(Bindings,E),'Free'(Vs,BindingList)) :-
	map2M(compiler:bindingVar,Bindings,Vs),
	map2M(compiler:elimCasesInBinding,Bindings,NBindings),
	elimCasesInExp(E,NE),
	letbindings2constr(NBindings,NE,BindingList).

bindingVar('Prelude.(,)'(V,_),V).

letbindings2constr([],Exp,Exp).
letbindings2constr(['Prelude.(,)'(X,E)|Bs],Exp,
		   'Comb'('FuncCall',Cond,['Comb'('FuncCall',LetRec,['Var'(X),E]),BsL])) :-
	atom_codes('Prelude.letrec',LetRec),
        atom_codes('Prelude.cond',Cond),
        letbindings2constr(Bs,Exp,BsL).
	
elimCasesInBinding('Prelude.(,)'(V,E),'Prelude.(,)'(V,NE)) :-
	elimCasesInExp(E,NE).

elimCasesInBranches([],[]).
elimCasesInBranches(['Branch'(Pat,Exp)|Cs],
	            ['Branch'(Pat,NewExp)|NCs]) :-
	elimCasesInExp(Exp,NewExp),
	elimCasesInBranches(Cs,NCs).

% find a new variable index not occurring in a list of variables:
newVarIndex(Index,Vars,NewIndex) :-
	member(Index,Vars)
	 -> I1 is Index+1, newVarIndex(I1,Vars,NewIndex)
	  ; NewIndex=Index.

% generate new name for auxiliary function:
genAuxFuncName(FauxName) :-
	retract(newFunctionCounter(FNameS,FC)),
	FC1 is FC+1,
	asserta(newFunctionCounter(FNameS,FC1)),
	number_codes(FC,FCS),
	append(FNameS,"._#caseor",FNameAux),
	append(FNameAux,FCS,FauxName).

% add new auxiliary function:
addAuxFunction(AF) :-
	retract(newAuxFunctions(AFs)),
	asserta(newAuxFunctions([AF|AFs])).


% compute the correct types of a list of functions w.r.t. to a list of already
% type correct functions:
computeCorrectType(_,[],[]).
computeCorrectType(AllFunData,['Func'(Name,Arity,Vis,_,'Rule'(Args,RHS))|Funs],
		   [NewFun|NewFuns]) :-
	atom_codes(NameA,Name),
	%writeErr('Compute type of '), writeLnErr(NameA),
	%writeFunTypes(AllFunData), nlErr,
	map2M(compiler:var2vartype,Args,TEnv),
	%writeErr(TEnv), nlErr,
	%writeErr(RHS), nlErr,
        (typeExpr(RHS,AllFunData,TEnv,EType) -> true
          ; % an internal type error occurred: set new type to error type:
            (verbosityIntermediate
            -> writeErr('*** Internal type inference for auxiliary function "'),
               writeErr(NameA), writeLnErr('" failed') ; true),
            EType = 'TCons'("ERRORTYPE",[])),
	%writeErr(EType), nlErr,
 	%writeErr(TEnv), nlErr,
	tenvtype2funtype(TEnv,EType,Type),
	freevars2tvars(Type,0,_),
	NewFun='Func'(Name,Arity,Vis,Type,'Rule'(Args,RHS)), !,
	computeCorrectType([NewFun|AllFunData],Funs,NewFuns).
computeCorrectType(AllFunData,['Func'(Name,Arity,Vis,Type,'External'(EName))|Funs],
		   [NewFun|NewFuns]) :-
	NewFun='Func'(Name,Arity,Vis,Type,'External'(EName)), !,
	computeCorrectType([NewFun|AllFunData],Funs,NewFuns).
computeCorrectType(AllFunData,[FunDecl|Funs],[FunDecl|NewFuns]) :-
        FunDecl = 'Func'(Name,_,_,_,_),
        writeErr('*** Internal error during compilation of operation: '),
	atom_codes(NameA,Name), writeLnErr(NameA),
	computeCorrectType([FunDecl|AllFunData],Funs,NewFuns).

% for testing:
writeFunTypes([]).
writeFunTypes(['Func'(Name,_,_,_,_)|FDs]) :-
	atom_codes(NameA,Name), writeErr(NameA), writeErr(' '),
	writeFunTypes(FDs).
writeFunTypes(['Type'(Name,_,_,_)|FDs]) :-
	atom_codes(NameA,Name), writeErr(NameA), writeErr(' '),
	writeFunTypes(FDs).


tenvtype2funtype([],T,T).
tenvtype2funtype([type(_,T)|Ts],RT,'FuncType'(T,FT)) :-
	tenvtype2funtype(Ts,RT,FT).

var2vartype(V,type(V,_)).

getTypeFromTypeEnv([type(V,T)|_],V,T) :- !.
getTypeFromTypeEnv([_|TEnv],V,T) :- getTypeFromTypeEnv(TEnv,V,T).

% transform list of ASCII values into atom in a term:
ascii2atom(T,T) :- var(T), !.
ascii2atom([],[]).
ascii2atom([X|Xs],A) :- isListOfASCII([X|Xs]), !, atom_codes(A,[X|Xs]).
ascii2atom(T,TA) :-
        T =.. [F|Args],
        ascii2atoms(Args,ArgsA),
        TA =.. [F|ArgsA].

ascii2atoms([],[]).
ascii2atoms([T|Ts],[TA,TAs]) :- ascii2atom(T,TA), ascii2atoms(Ts,TAs).

isListOfASCII(T) :- var(T), fail.
isListOfASCII([]).
isListOfASCII([A|As]) :- integer(A), A>31, A<255, isListOfASCII(As).

typeExpr('Var'(V),_,TEnv,Type) :- getTypeFromTypeEnv(TEnv,V,Type), !.
typeExpr('Lit'('Intc'(_)),_,_,'TCons'("Prelude.Int",[])) :- !.
typeExpr('Lit'('Floatc'(_)),_,_,'TCons'("Prelude.Float",[])) :- !.
typeExpr('Lit'('Charc'(_)),_,_,'TCons'("Prelude.Char",[])) :- !.
typeExpr('Comb'(_,CF,Args),Funs,TE,T) :-
	getTypeOfFunction(Funs,CF,FunType),
	typeExprs(Args,Funs,TE,FunType,T), !.
typeExpr('Free'(Vs,E),Funs,TE,T) :-
	map2M(compiler:var2vartype,Vs,TVs),
	append(TVs,TE,VTE),
	typeExpr(E,Funs,VTE,T), !.
typeExpr('Or'(E1,E2),Funs,TE,T) :-
	typeExpr(E1,Funs,TE,T1),
	typeExpr(E2,Funs,TE,T2),
	(unifyWithOccursCheck(T1,T2) -> T=T1 ;
           (verbosityIntermediate ->
	     writeLnErr('*** Illegal FlatCurry file: Type error (Or):'),
             writeLnErr('*** Term: '), writeErr('Or'(E1,E2)),
	     writeErr('*** Inferred type of first argument:  '),
	     writeLnErr(T1),
	     writeErr('*** Inferred type of second argument: '),
	     writeLnErr(T2) ; true),
	   !, fail), !.
typeExpr('Case'(_,CE,Branches),Funs,TE,T) :-
	typeExpr(CE,Funs,TE,CT),
	typeBranches(Branches,CT,Funs,TE,T), !.
typeExpr(Expr,_,_,_) :-
        (verbosityIntermediate ->
	   writeLnErr('*** Internal error: cannot type expression'),
           ascii2atom(Expr,ExprA), writeLnErr(ExprA) ; true), !, fail.
% TODO: add Let case

typeExprs([],_,_,Type,Type).
typeExprs([E|Es],Funs,TE,'FuncType'(T1,T2),ResultType) :-
	typeExpr(E,Funs,TE,TA1),
	(unifyWithOccursCheck(TA1,T1) -> true ;
           (verbosityIntermediate ->
	     writeLnErr('*** Illegal FlatCurry file: Type error (FunArgs):'),
	     writeLnErr('*** Term: '), writeErr(E),
	     writeErr('*** Inferred type: '),
	     writeLnErr(TA1),
	     writeErr('*** Expected type: '),
	     writeLnErr(T1) ; true),
	   !, fail),
	typeExprs(Es,Funs,TE,T2,ResultType).

typeBranches([],_,_,_,_).
typeBranches(['Branch'('LPattern'(_),Exp)|Bs],CT,Funs,TE,T) :-
	typeExpr(Exp,Funs,TE,T1),
	typeBranches(Bs,CT,Funs,TE,T2),
	unifyBranchTypes(['Branch'('LPattern'(_),Exp)|Bs],T1,T2,T).
typeBranches(['Branch'('Pattern'(Cons,Vs),Exp)|Bs],CT,Funs,TE,T) :-
	map2M(compiler:var2vartype,Vs,TVs),
	append(TVs,TE,VTE),
	getTypeOfFunction(Funs,Cons,ConsType),
	map2M(compiler:varIndex2VarExp,Vs,Vars),
	typeExprs(Vars,Funs,VTE,ConsType,CT), % type pattern arguments
	typeExpr(Exp,Funs,VTE,T1),
	typeBranches(Bs,CT,Funs,TE,T2),
	unifyBranchTypes(['Branch'('Pattern'(Cons,Vs),Exp)|Bs],T1,T2,T).

unifyBranchTypes(_,T1,T2,T) :- unifyWithOccursCheck(T1,T2), !, T=T1.
unifyBranchTypes(Branches,T1,T2,_) :-
        (verbosityIntermediate ->
	  writeLnErr('*** Illegal FlatCurry file: Type error (Case):'),
	  writeLnErr('*** Branches: '),
          ascii2atom(Branches,Bs), writeLnErr(Bs),
	  writeErr('*** Inferred type of first branch:  '),
	  ascii2atom(T1,T1A), writeLnErr(T1A),
	  writeErr('*** Inferred type of second branch: '),
	  ascii2atom(T2,T2A), writeLnErr(T2A) ; true),
	!, fail.

getTypeOfFunction([],Name,_) :- % usually, this case should not occur!
	writeErr('WARNING: Type of function '),
	atom_codes(AName,Name), writeErr(AName),
	writeLnErr(' not found!').
getTypeOfFunction(['Func'(Name,_,_,FType,_)|_],Name,Type) :- !,
	tvars2freevars(FType,[],Type,_).
getTypeOfFunction(['Type'(TC,_,TVs,Conss)|_],Name,Type) :-
	getTypeOfCons(Conss,Name,ArgTypes), !,
	map2M(compiler:addTVar,TVs,TTVs),
	constype2funtype(ArgTypes,'TCons'(TC,TTVs),FType),
	tvars2freevars(FType,[],Type,_).
getTypeOfFunction([_|Funs],Name,FunType) :-
	getTypeOfFunction(Funs,Name,FunType).

addTVar(V,'TVar'(V)).

varIndex2VarExp(I,'Var'(I)).

constype2funtype([],T,T).
constype2funtype([T|Ts],RT,'FuncType'(T,FT)) :-	constype2funtype(Ts,RT,FT).

getTypeOfCons(['Cons'(Name,_,_,ArgTypes)|_],Name,ArgTypes) :- !.
getTypeOfCons([_|Conss],Name,ArgTypes) :- getTypeOfCons(Conss,Name,ArgTypes).


% transform all 'TVar's into Prolog variables:
tvars2freevars('TVar'(I),TVs,V,NTVs) :-
	addTVar2FreeVar(I,TVs,V,NTVs).
tvars2freevars('FuncType'(T1,T2),TVs,'FuncType'(NT1,NT2),NTVs) :-
	tvars2freevars(T1,TVs,NT1,NTVs1),
	tvars2freevars(T2,NTVs1,NT2,NTVs).
tvars2freevars('TCons'(TC,Ts),TVs,'TCons'(TC,NTs),NTVs) :-
	tvars2freevarsOnList(Ts,TVs,NTs,NTVs).

tvars2freevarsOnList([],TVs,[],TVs).
tvars2freevarsOnList([T|Ts],TVs,[NT|NTs],NTVs) :-
	tvars2freevars(T,TVs,NT,TVs1),
	tvars2freevarsOnList(Ts,TVs1,NTs,NTVs).

addTVar2FreeVar(I,[],V,[(I,V)]). % new entry for first variable occurrence
addTVar2FreeVar(I,[(I,V)|TVs],V,[(I,V)|TVs]) :- !.
addTVar2FreeVar(I,[TV|TVs],V,[TV|NTVs]) :- addTVar2FreeVar(I,TVs,V,NTVs).

	       
% transform all Prolog variables into numbered 'TVar's:
freevars2tvars(V,I,I1) :-
	var(V), !,
	V='TVar'(I),
	I1 is I+1.
freevars2tvars('TVar'(_),I,I).
freevars2tvars('FuncType'(T1,T2),I,I2) :-
	freevars2tvars(T1,I,I1),
	freevars2tvars(T2,I1,I2).
freevars2tvars('TCons'(_,Ts),I,J) :-
	freevars2tvarsOnList(Ts,I,J).

freevars2tvarsOnList([],I,I).
freevars2tvarsOnList([T|Ts],I,J) :-
	freevars2tvars(T,I,I1),
	freevars2tvarsOnList(Ts,I1,J).


% compute the free variables in an expression (where variables are represented
% as integers):
freeVarsInExp('Var'(V),[V]).
freeVarsInExp('Lit'(_),[]).
freeVarsInExp('Comb'(_,_,Terms),V) :-
	freeVarsInExps(Terms,V).
freeVarsInExp('Free'(CVars,Exp),V) :-
	freeVarsInExp(Exp,VE),
	diff(VE,CVars,V).
freeVarsInExp('Or'(E1,E2),V) :-
	freeVarsInExp(E1,V1),
	freeVarsInExp(E2,V2),
	union(V1,V2,V).
freeVarsInExp('Case'(_,CE,Branches),V) :-
	freeVarsInExp(CE,V1),
	freeVarsInBranches(Branches,V2),
	union(V1,V2,V).
freeVarsInExp('Let'(Bindings,Exp),V) :-
	freeVarsInBindings(Bindings,BVs),
	freeVarsInExp(Exp,EVs),
	union(BVs,EVs,BEVs),
	map2M(compiler:bindingVar,Bindings,Vs),
	diff(BEVs,Vs,V).

freeVarsInExps([],[]).
freeVarsInExps([E|Es],V) :-
	freeVarsInExp(E,V1),
	freeVarsInExps(Es,V2),
	union(V1,V2,V).

freeVarsInBindings([],[]).
freeVarsInBindings(['Prelude.(,)'(_,E)|Bs],V) :-
	freeVarsInExp(E,V1),
	freeVarsInBindings(Bs,V2),
	union(V1,V2,V).

freeVarsInBranches([],[]).
freeVarsInBranches(['Branch'('Pattern'(_,PVs),E)|Bs],V) :-
	freeVarsInExp(E,V1),
	diff(V1,PVs,V2),
	freeVarsInBranches(Bs,V3),
	union(V2,V3,V).
freeVarsInBranches(['Branch'('LPattern'(_),E)|Bs],V) :-
	freeVarsInExp(E,V1),
	freeVarsInBranches(Bs,V2),
	union(V1,V2,V).


% does a (logical) variable occures in an expression (where variables
% are represented as logical variables)?
occursInExp(V,'Var'(X)) :- X==V.
occursInExp(V,'Comb'(_,_,Terms)) :- occursInExps(V,Terms).
occursInExp(V,'Free'(_,Exp)) :- occursInExp(V,Exp).
occursInExp(V,'Or'(E1,E2)) :- occursInExp(V,E1) ; occursInExp(V,E2).
occursInExp(V,'Case'(_,CE,Branches)) :-
	occursInExp(V,CE) ; occursInBranches(V,Branches).

occursInExps(V,[E|Es]) :- occursInExp(V,E) ; occursInExps(V,Es).

occursInBranches(V,['Branch'(_,E)|Bs]) :-
	occursInExp(V,E) ; occursInBranches(V,Bs).


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Auxiliaries for handling global values:

% translate global specification into run-time form:
translateGlobalSpec(_,'Global.Temporary','Global.Temporary').
translateGlobalSpec(_,'Global.Persistent'(_),'Global.Persistent').
translateGlobalSpec(FName,_,_) :-
	writeErr('ERROR: Global declaration "'),
	writeErr(FName),
	writeLnErr('" has illegal specification of storage mechanism!'),
	setFlcBug.

% check the type of dynamic predicates (i.e., result type Dynamic and
% monomorphism restriction):
checkGlobalType(PredName,'TCons'("Global.Global",[T])) :- !,
	checkGlobalTypeForCorrectTypes(PredName,T).
checkGlobalType(PredName,_) :-
	writeErr('ERROR: Global declaration "'),
	writeErr(PredName),
	writeLnErr('" has not result type "Global"!'),
	setFlcBug.

checkGlobalTypeForCorrectTypes(PredName,'FuncType'(T1,T2)) :-
	checkGlobalTypeForCorrectTypes(PredName,T1),
	checkGlobalTypeForCorrectTypes(PredName,T2).
checkGlobalTypeForCorrectTypes(PredName,'TCons'(TC,_)) :-
	atom_codes(TCA,TC),
	member(TCA,['Prelude.IO','Data.IORef.IORef','Dynamic.Dynamic','Ports.Port',
		    %'System.IO.Handle',
		    'Network.Socket.Socket']),
	!,
	nlErr,
	writeErr('ERROR: Type of global declaration "'),
	writeErr(PredName),
	writeErr('" contains illegal type: '), writeLnErr(TCA),
	setFlcBug.
checkGlobalTypeForCorrectTypes(PredName,'TCons'(_,Ts)) :-
	map1partialM(compiler:checkGlobalTypeForCorrectTypes(PredName),Ts).
checkGlobalTypeForCorrectTypes(PredName,'TVar'(_)) :-
	writeErr('ERROR: Type of global declaration "'),
	writeErr(PredName),
	writeLnErr('" contains type variable!'),
	setFlcBug.


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Auxiliaries for handling global variables:

% check the type of dynamic predicates (i.e., result type Dynamic and
% monomorphism restriction):
checkGVarType(PredName,'TCons'("GlobalVariable.GVar",[T])) :- !,
	checkGlobalTypeForCorrectTypes(PredName,T).
checkGVarType(PredName,_) :-
	writeErr('ERROR: GVar declaration "'),
	writeErr(PredName),
	writeLnErr('" has not result type "GVar"!'),
	setFlcBug.


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Auxiliaries for handling dynamic data:

% Add new initialization directives for dynamic data (used for saving states):
addDynamicNameInfo(PredName,FileName) :-
	retract(dynamicPredNames(Ds)),
	asserta(dynamicPredNames([(PredName,FileName)|Ds])), !.

% Write initial info clause for dynamic predicates:
writeDynamicInfoClause((PredName,'')) :- !,
	writeClause((:- assertz(dynamicPredInfo(PredName,'')))).
writeDynamicInfoClause((PredName,FileNameExp)) :-
	DynInfoClause =
	  (dynamicPredInfo(PredName,RF) :-
	               evaluateDynamicPredInfo(PredName,FileNameExp,RF)),
	writeClause((:- assertz(DynInfoClause))).


% is the rhs of a rule a dynamic declaration?
isDynamicRuleDecl([],'Comb'('FuncCall',"Dynamic.dynamic",[]),'') :- !.
isDynamicRuleDecl([],'Comb'('FuncCall',"Dynamic.persistent",[S]),S) :- !.
isDynamicRuleDecl(Args,'Comb'('FuncCall',"Prelude.apply",[Exp,'Var'(A)]),S) :- !,
	append(As,[A],Args),
	isDynamicRuleDecl(As,Exp,S).


% check the type of dynamic predicates (i.e., result type Dynamic and
% monomorphism restriction):
checkDynamicType(PredName,'FuncType'(T1,T2)) :- !,
	checkDynamicTypeForCorrectTypes(PredName,T1),
	checkDynamicType(PredName,T2).
checkDynamicType(_,'TCons'("Dynamic.Dynamic",[])) :- !.
checkDynamicType(PredName,_) :-
	writeErr('ERROR: Dynamic predicate "'),
	writeErr(PredName),
	writeLnErr('" has not result type "Dynamic"!'),
	setFlcBug.

checkDynamicTypeForCorrectTypes(PredName,'FuncType'(T1,T2)) :-
	checkDynamicTypeForCorrectTypes(PredName,T1),
	checkDynamicTypeForCorrectTypes(PredName,T2).
checkDynamicTypeForCorrectTypes(PredName,'TCons'(TC,_)) :-
	atom_codes(TCA,TC),
	member(TCA,['Data.IORef.IORef','Dynamic.Dynamic','Ports.Port',%'System.IO.Handle',
		    'Network.Socket.Socket']),
	!,
	nlErr,
	writeErr('ERROR: Type of dynamic predicate "'),
	writeErr(PredName),
	writeErr('" contains illegal type: '), writeLnErr(TCA),
	setFlcBug.
checkDynamicTypeForCorrectTypes(PredName,'TCons'(_,Ts)) :-
	map1partialM(compiler:checkDynamicTypeForCorrectTypes(PredName),Ts).
checkDynamicTypeForCorrectTypes(PredName,'TVar'(_)) :-
	writeErr('ERROR: Type of dynamic predicate "'),
	writeErr(PredName),
	writeLnErr('" contains type variable!'),
	setFlcBug.


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% translation of a defined function

writeFunc('Func'(_,_,_,_,'External'(ExtNameS))) :-
	append(_,"[raw]",ExtNameS),
	% don't generate standard external interface for externals
	% annotated with [raw]
	!.

writeFunc('Func'(Name,FArity,_,Type,'External'(ExtNameS))) :-
	isIOAction(Type), !,
	% generate standard external interface for I/O operations:
	flatName2Atom(Name,FName),
        length(Args,FArity),
	rev(Args,RevArgs),
	appendAtom(FName,'$WORLD',FNameWorld),
	append(Args,[partcall(1,FNameWorld,RevArgs),E,E],PFArgs),
	PrimFact =.. [FName|PFArgs],
	writeClause(PrimFact),
	FArity3 is FArity+3,
	FArity4 is FArity+4,
	genBlockDecl(FNameWorld,FArity4,[FArity3],NewFNameWorld),
	length(RefArgs,FArity),
	append(RefArgs,[_,'$io'(Result),E0,E],PredArgs),
	LHS =.. [NewFNameWorld|PredArgs],
	append(_,[32|PredNameS],ExtNameS),
	atom_codes(PredName,PredNameS),
	append(Args,[Result],PrimArgs),
	PrimCall =.. [PredName|PrimArgs],
	genDerefCalls(Type,RefArgs,Args,(PrimCall, E0=E),RHS),
	writeClause((LHS :- RHS)),
	nl, !.

writeFunc('Func'(Name,FArity,_,Type,'External'(ExtNameS))) :-
	% generate standard external interface for non I/O operations:
	flatName2Atom(Name,FName),
	FArity2 is FArity+2,
	FArity3 is FArity+3,
	genBlockDecl(FName,FArity3,[FArity2],NewFName),
	length(RArgs,FArity),
	append(RArgs,[Result,E0,E],PredArgs),
	LHS =.. [NewFName|PredArgs],
	length(Args,FArity),
	append(Args,[Result],PrimArgs),
	append(_,[32|PredNameS],ExtNameS),
	atom_codes(PredName,PredNameS),
	PrimCall =.. [PredName|PrimArgs],
	genDerefCalls(Type,RArgs,Args,(PrimCall, E0=E),RHS),
	writeClause((LHS :- RHS)),
	nl, !.

% special code for dynamic predicates:
writeFunc('Func'(Name,FArity,_Vis,Type,'Rule'(Args,Exp))) :-
	isDynamicRuleDecl(Args,Exp,DynDeclArg), !,
	flatName2Atom(Name,FName),
	checkDynamicType(FName,Type),
	atom_codes(FName,FNameS),
	append(_,[46|UQNameS],FNameS),
	append("$DYN_",UQNameS,DynNameS),
	atom_codes(DynName,DynNameS),
        (DynDeclArg = ''
	  -> DynType = 'Dynamic.Temporary'
	   ; exp2Term([],DynDeclArg,ENameTerm),
	     DynType = 'Dynamic.Persistent'),
        length(Xs,FArity),
	length(Ys,FArity),
	PYs =.. [DynName,DynType,0,0|Ys],
	append(Xs,['Dynamic.Dynamic'(PYs),E0,E],HeadArgs),
	Head =.. [FName|HeadArgs],
	genNfArgs(Xs,Ys,E0,E,Body),
	writeClause((Head :- Body)),
	argnum(Type,TArity),
	DArity is TArity+2,
	writeClause((:- dynamic DynName/DArity)),
	(DynType = 'Dynamic.Temporary'
	 -> addDynamicNameInfo(DynName/DArity,'')
	  ; addDynamicNameInfo(DynName/DArity,ENameTerm)),
	nl, !.

% special code for global declarations:
writeFunc('Func'(Name,0,_Vis,Type,
	  'Rule'([],'Comb'('FuncCall',"Global.global",[V,S])))) :- !,
	flatName2Atom(Name,FName),
	checkGlobalType(FName,Type),
	appendAtom('$GLOBAL_',FName,GlobName),
        exp2Term([],V,ValueTerm),
        exp2Term([],S,GSpecTerm),
	translateGlobalSpec(FName,GSpecTerm,GSpec),
	Head =.. [FName,'Global.GlobalDef'(GlobName,GSpec),E,E],
	writeClause(Head),
	writeClause((:- dynamic GlobName/1)),
	GlobClauseHead =.. [GlobName,IVal],
	writeClause((GlobClauseHead :-
                         initGlobalValue(GlobName,GSpecTerm,ValueTerm,IVal))),
	nl, !.

% special code for global variable declarations:
writeFunc('Func'(Name,0,_Vis,Type,
	  'Rule'([],'Comb'('FuncCall',"GlobalVariable.gvar",[V])))) :- !,
	flatName2Atom(Name,FName),
	checkGVarType(FName,Type),
	%appendAtom('$GLOBVAR_',FName,GlobName),
        exp2Term([],V,ValueTerm),
	Head =.. [FName,GlobValue,E0,E],
	writeClause((:- dynamic FName/3)),
	writeClause((Head :-
                       initGlobalVariable(FName,ValueTerm,GlobValue,E0,E))),
	nl, !.

writeFunc('Func'(Name,FArity,_Vis,_Type,'Rule'(FlatArgs,FlatExp))) :-
	flatName2Atom(Name,FName),
	retract(currentFunction(_)),
	decodePrologName(FName,FlatName),
	asserta(currentFunction(FlatName)),
	% only for debugging:
	  %writeErr('*** Translating rule: '),
	  %writeErr(FName), writeErr(' '),
	  %writeErr(FlatArgs), writeErr(' = '),
	  %writeErr(FlatExp), nlErr,
	FArity2 is FArity+2,
	FArity3 is FArity+3,
	genBlockDecl(FName,FArity3,[FArity2],NewFName),
	%write(':- block '), writeq(FName), write('(?,'),
	%writeNTimes(FArity,'?,'), write('-,?).'), nl,
	flatargs2var(FlatArgs,Env,Args),
	flatexp2var(Env,FlatExp,RHS),
	transExp(NewFName,'',Args,Args,nocut,RHS), nl.

% is a function type the type of a (parameterized) IO action?
isIOAction('FuncType'(_,T)) :- isIOAction(T).
isIOAction('TCons'("Prelude.IO",_)) :- !.

% generate deref-calls for external function interface:
genDerefCalls('FuncType'(Type1,Type2),[RA|RArgs],[A|Args],LastGoal,
	      (DerefCall, LastGoal2)) :- !,
	genDerefCalls(Type2,RArgs,Args,LastGoal,LastGoal2),
	type2derefPred(Type1,DerefPred),
	DerefCall =.. [DerefPred,RA,A].
genDerefCalls('TCons'(TCName,_),[RA],[A],LastGoal,LastGoal) :-
	TCName="Prelude.IO", !, % IO type is handled as a function type
	RA=A. % world argument is not dereferenced
genDerefCalls(_,[],[],LastGoal,LastGoal).
%genDerefCalls(Type,RArgs,Args,LastGoal,(RArgs=Args, LastGoal)) :-
%	writeErr(Type), nlErr.

% create deref predicate for corresponding type, i.e.,
% derefRoot for primitive types and derefAll for other types
type2derefPred('TCons'(Name,_),derefRoot) :-
	member(Name,["Prelude.Int","Prelude.Float","Prelude.Char","Prelude.Bool",
		     "Prelude.Ordering",
		     "IO.Handle","IO.IOMode","IO.SeekMode",
		     "PlProfileData.ProfileSelection","Ports.Port","Socket.Socket"]), !.
type2derefPred('FuncType'(_,_),derefRoot) :-
	% functional arguments are only evaluated to head normal form
	!.
type2derefPred(_,derefAll).


genNfArgs([],[],E,E,true).
genNfArgs([X|Xs],[Y|Ys],E0,E,(nf(X,Y,E0,E1),Goal)) :-
	genNfArgs(Xs,Ys,E1,E,Goal).

% assign to each FlatCurry argument (an integer) in an argument list a new
% logic variable and unify second argument with this assignment, e.g.,
% flatargs2var([1,2,3],E,L) --> E=[(1,X),(2,Y),(3,Z)],L=[X,Y,Z]
flatargs2var([],[],[]).
flatargs2var([I|Is],[(I,Var)|E],[Var|Vars]) :- flatargs2var(Is,E,Vars).

% replace in a FlatCurry expression all variable indices by logic variables:
flatexp2var(Env,'Var'(I),'Var'(V)) :- !,
	getVarInEnv(I,Env,V).
flatexp2var(_,'Lit'(L),'Lit'(L)) :- !.
flatexp2var(Env,'Comb'(CT,CF,Exps),'Comb'(CT,CF,VarExps)) :- !,
	map2partialM(compiler:flatexp2var(Env),Exps,VarExps).
flatexp2var(Env,'Free'(VarIs,Exp),'Free'(Vars,VarExp)) :- !,
	flatargs2var(VarIs,VarEnv,Vars),
	append(VarEnv,Env,Env1),
	flatexp2var(Env1,Exp,VarExp).
flatexp2var(Env,'Or'(E1,E2),'Or'(VE1,VE2)) :- !,
	flatexp2var(Env,E1,VE1),
	flatexp2var(Env,E2,VE2).
flatexp2var(Env,'Case'(CT,Exp,Cases),'Case'(CT,VarExp,VarCases)) :- !,
	flatexp2var(Env,Exp,VarExp),
	map2partialM(compiler:flatcases2var(Env),Cases,VarCases).
flatexp2var(_,Expr,Expr) :-
	writeErr('ERROR in FlatCurry file: Unknown expression "'),
	writeErr(Expr),
	writeErr('" in function "'),
	currentFunction(FName), writeErr(FName),
	writeLnErr('"!'),
	pleaseReport,
	put_code(37), write('ERROR in FlatCurry file: Unknown expression "'),
	write(Expr), write('" in function "'),
	write(FName), write('"!'), nl.

flatcases2var(Env,'Branch'('Pattern'(L,VarIs),Exp),
	          'Branch'('Pattern'(L,Vars),VarExp)) :-
	flatargs2var(VarIs,VarEnv,Vars),
	append(VarEnv,Env,Env1),
	flatexp2var(Env1,Exp,VarExp).
flatcases2var(Env,'Branch'('LPattern'(L),Exp),
	          'Branch'('LPattern'(L),VarExp)) :-
	flatexp2var(Env,Exp,VarExp).

getVarInEnv(_,[],_) :-
	writeErr('ERROR in FlatCurry file: '),
	writeErr('undeclared variable in function "'),
	currentFunction(FName), writeErr(FName),
	writeLnErr('"!'),
	reportLiftBug,
	put_code(37), write('ERROR in FlatCurry file: '),
	write('undeclared variable in function "'),
	write(FName), write('"!'), nl.
getVarInEnv(I,[(I,Var)|_],Var) :- !.
getVarInEnv(I,[_|Env],Var) :- getVarInEnv(I,Env,Var).

	
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% write clauses with type (and evaluation) information

writeFTypeClause(ExtFuncs,Ops,'Func'(Name,_FArity,Vis,FlatType,_)) :-
	flatName2Atom(Name,FName),
	replaceTVarByLVar([],FlatType,_,FlatTypeP),
	getExternalNameFromVisibility(Name,Vis,EName),
	getFuncArity(FName,Arity),
	getPrologNameFromExtFuncs(FName,Arity,ExtFuncs,PrologName),
	getFixityFromOpList(FName,Ops,Fixity),
	writeClause(functiontype(FName,EName,Arity,PrologName,
                                 Fixity,FlatTypeP)).

getPrologNameFromExtFuncs(FName,Arity,ExtFuncs,PrologName) :-
	member((FName/Arity,PName),ExtFuncs), !,
	(append(_,[32|PrimNameS],PName)
	 -> (append(EPrimNameS,"[raw]",PrimNameS)
	     -> atom_codes(PrologName,EPrimNameS)
	      ; PrologName=FName)
	  ; writeErr('ERROR: Specification of primitive function '),
	    deleteCostCenterInPrologName(FName,PNameWOCC),
	    decodePrologName(PNameWOCC,FNameWOCC),
	    writeErr(FNameWOCC), writeErr('/'), writeErr(Arity),
	    writeLnErr(' not found!'),
	    setFlcBug, fail).
getPrologNameFromExtFuncs(FName,_,_,FName).

getFixityFromOpList(FName,Ops,Fixity) :-
	atom_codes(FName,FNameS),
	member('Op'(FNameS,Type,Prec),Ops), !,
	transFixity2pl(Type,Prec,Fixity).
getFixityFromOpList(_,_,nofix).

transFixity2pl('InfixOp',P,infix(P)).
transFixity2pl('InfixlOp',P,infixl(P)).
transFixity2pl('InfixrOp',P,infixr(P)).

getExternalNameFromVisibility(Name,'Private',FName) :- atom_codes(FName,Name).
getExternalNameFromVisibility(Name,'Public',FName) :-
	append([_|_],[46|F],Name), !, atom_codes(FName,F).
getExternalNameFromVisibility(Name,'Public',FName) :- atom_codes(FName,Name).

getUnqualifiedName(Name,UQName) :-
	append([_|_],[46|F],Name), !, atom_codes(UQName,F).
getUnqualifiedName(Name,UQName) :- atom_codes(UQName,Name).

writeDTypeClause('Type'(TypeName,_Vis,TypeArgs,ConsExprs)) :-
	map2M(compiler:index2tvar,TypeArgs,TypeArgExps),
	ResultType = 'TCons'(TypeName,TypeArgExps),
	writeDTypeClauses(ResultType,0,ConsExprs,ConsExprs).

index2tvar(I,'TVar'(I)). % transform tvar index into type expression

writeDTypeClauses(_,_,[],_).
writeDTypeClauses(ResultType,Index,['Cons'(ConsName,Arity,Vis,ArgTypes)|Cs],
		  AllConstrs) :-
	flatName2Atom(ConsName,Cons),
	append(ArgTypes,[ResultType],TypeL),
	typelist2flattype(TypeL,CType),
	replaceTVarByLVar([],CType,_,CTypeP),
	getExternalNameFromVisibility(ConsName,Vis,EName),
	getUnqualifiedName(ConsName,UQName),
	getOtherConstructors(ConsName,AllConstrs,OtherConstrs),
	writeClause(constructortype(Cons,EName,Arity,UQName,Index,CTypeP,
				    OtherConstrs)),
	Index1 is Index+1,
	writeDTypeClauses(ResultType,Index1,Cs,AllConstrs).

getOtherConstructors(_,[],[]).
getOtherConstructors(ConsName,['Cons'(ConsName,_,_,_)|Cs],OCs) :- !,
	getOtherConstructors(ConsName,Cs,OCs).
getOtherConstructors(ConsName,['Cons'(CN,CA,_,_)|Cs],[CNA/CA|OCs]) :-
	flatName2Atom(CN,CNA),
	getOtherConstructors(ConsName,Cs,OCs).

typelist2flattype([Type],Type) :- !.
typelist2flattype([T1|T2L],'FuncType'(T1,T2)) :-
	!,
	typelist2flattype(T2L,T2).


% remove all "TVar" constructors in a type expression by logic variables
% and replace FlatCurry names by atoms for better readability of
% the generated Prolog programs:
replaceTVarByLVar(Env,'TVar'(I),Env,TVar) :-
	getTVarInEnv(I,Env,TVar), !.
replaceTVarByLVar(Env,'TVar'(I),[(I,TVar)|Env],TVar).
replaceTVarByLVar(Env,'FuncType'(T1,T2),NewEnv,'FuncType'(TT1,TT2)) :-
	replaceTVarByLVar(Env,T1,Env1,TT1),
	replaceTVarByLVar(Env1,T2,NewEnv,TT2).
replaceTVarByLVar(Env,'TCons'(Name,Types),NewEnv,'TCons'(Cons,TTypes)) :-
	flatName2Atom(Name,Cons),
	replaceTVarByLVarL(Env,Types,NewEnv,TTypes).

replaceTVarByLVarL(Env,[],Env,[]).
replaceTVarByLVarL(Env,[Type|Types],NewEnv,[TType|TTypes]) :-
	replaceTVarByLVar(Env,Type,Env1,TType),
	replaceTVarByLVarL(Env1,Types,NewEnv,TTypes).

getTVarInEnv(I,[(I,TVar)|_],TVar) :- !.
getTVarInEnv(I,[_|Env],TVar) :- getTVarInEnv(I,Env,TVar).



%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% translation of clauses for evaluation to head normal form

transHnfCurrent(CCs) :-
	findall(FE,functiontypeWithExternal(FE),Funcs),
	transHnf(Funcs,CCs).

functiontypeWithExternal((FName/FArity,EName)) :-
	user:functiontype(FName,_,FArity,EName,_,_).

transHnf(Funcs,CCs) :-
	genBlockDecl(hnf,4,[3],HNF),
	%writeClause((:- block hnf(?,?,-,?))),
	HnfLHS =.. [HNF,T,H,E0,E],
	writeClause((HnfLHS :- var(T), !, H=T, E0=E)),
	(compileWithSharing(variable)
	 -> map1partialM(compiler:genVariableShareHnfClause(HNF),CCs)
	  ; (compileWithSharing(function)
	     -> map1partialM(compiler:genFunctionShareHnfClause(HNF),CCs)
	      ; true)),
	map1partialM(compiler:genHnfClause(HNF),Funcs),
	HnfFact =.. [HNF,T,T,E,E],
	writeClause(HnfFact), nl.

genVariableShareHnfClause(HNF,Suffix) :-
	appendAtom(share,Suffix,Share),
	Share_M =.. [Share,M],
	appendAtom(propagateShare,Suffix,PropShare),
	PropShare_HV_R =.. [PropShare,HV,R],
	HnfLHS =.. [HNF,Share_M,R,E0,E],
	ShareGoal = (PropShare_HV_R, update_mutable('$eval'(R),M)),
	(printConsFailure(no)
	 -> ShareHNF = ShareGoal
	  ; ShareHNF = % no sharing for FAIL:
	     ((nonvar(HV), functor(HV,'FAIL',_)) -> R=HV ; ShareGoal)),
	writeClause((HnfLHS :- !, get_mutable(V,M),
                        (V='$eval'(Expr)
                         -> R=Expr, E0=E
                          ; hnf(V,HV,E0,E1),
			    ShareHNF,
			    E1=E))).

genFunctionShareHnfClause(HNF,Suffix) :-
	appendAtom(share,Suffix,Share),
	Share_M =.. [Share,M],
	HnfLHS =.. [HNF,Share_M,R,E0,E],
	writeClause((HnfLHS :- !, get_mutable(V,M),
                        (V='$eval'(Expr)
                         -> R=Expr, E0=E
                          ; hnf(V,R,E0,E1),
			    update_mutable('$eval'(R),M),
			    E1=E))).

% generate hnf clause for a function:
genHnfClause(HNF,(FName/FArity,PredName)) :-
	length(Args,FArity),
	LHS =.. [FName|Args],
	append(Args,[R,E0,E],RArgs),
	PredCall =.. [PredName|RArgs],
	(compileWithDebug ->
	      Goal = (traceCall(LHS,Skip), PredCall, traceExit(LHS,R,E,Skip))
            ; (((\+ printConsFailure(no)), failCheckFunc(yes),
		(\+ FName='Prelude.failure'), (\+ FName='Prelude.apply'))
	       -> append(Args,[IR,E0,E1],IRArgs),
		  PredCall1 =.. [PredName|IRArgs],
		  Goal = (PredCall1, checkFailValue(LHS,IR,R,E1,E))
		; Goal = PredCall)),
	HnfLHS =.. [HNF,LHS,R,E0,E],
	(compileWithFailPrint
	 -> writeClause((HnfLHS :- !, (Goal; failprint(LHS,E0,E))))
	  ; writeClause((HnfLHS :- !, Goal))).
genHnfClause(_,_) :- !.


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% translation of clauses for solving equational constraints

transConstrEq(Suffix) :-
	appendAtom('Prelude.constrEq',Suffix,ConstrEqOrg),
	genBlockDecl(ConstrEqOrg,5,[4],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],
	(compileWithDebug ->
            writeClause((ConstrEq_A_B_R_E0_E :-
			   traceCall('Prelude.=:='(A,B),Skip),
	                   hnf(A,HA,E0,E1), hnf(B,HB,E1,E2),
	                   ConstrEqHnf_HA_HB_R_E2_E,
			   traceExit('Prelude.=:='(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],
	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],
	(printConsFailure(no)
	 -> writeClause((ConstrEqHnf_T1_T2_E0_E :- number(T1),!,T1=T2,E0=E))
	  ; ConstrEqHnf_FAIL_X_E_E =.. [ConstrEqHnf,'FAIL'(Src),X,
					'FAIL'(Src),E,E],
	    writeClause((ConstrEqHnf_FAIL_X_E_E :- !)),
	    ConstrEqHnf_X_FAIL_E_E =.. [ConstrEqHnf,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.=:=',[Dict]),[A,B],R,E0,E))))),
	appendAtom(genConstrEqHnfBody,Suffix,GenConstrEqHnfBody),
	GenConstrEqHnfBody_1_NA =.. [GenConstrEqHnfBody,1,NA,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],
	   writeClause((ConstrEqHnf_A_B_FAIL_E0_E :-
		          prim_failure(partcall(2,'Prelude.=:=',[Dict]),[A,B],R,E0,E)))),
	nl,
	GenConstrEqHnfBody_N_NA_Succ =..
             [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],
	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],
	writeClause((GenConstrEqHnfBody_N_NA_And :-
		       arg(N,A,ArgA), arg(N,B,ArgB),
		       N1 is N+1, GenConstrEqHnfBody_N1_NA)),
	nl,
	% optimization: try to normalize the term before binding:
	BindTryNf_X_T_R_E0_E =.. [BindTryNf,X,T,R,E0,E],
	appendAtom(nf,Suffix,Nf),
	Nf_T_NT_E0_E1 =.. [Nf,T,NT,E0,E1],
	appendAtom(bindDirect,Suffix,BindDirect),
	appendAtom(bind,Suffix,Bind),
	BindDirect_X_NT_R_E1_E =.. [BindDirect,X,NT,R,E1,E],
	Bind_X_T_R_E0_E =.. [Bind,X,T,R,E0,E],
	writeClause((BindTryNf_X_T_R_E0_E :- Nf_T_NT_E0_E1,
	                       (nonvar(E1) -> BindDirect_X_NT_R_E1_E
                                            ; Bind_X_T_R_E0_E))),
	BindDirect_X_T_R_E0_E =.. [BindDirect,X,T,R,E0,E],
	appendAtom(occursNot,Suffix,OccursNot),
	OccursNot_X_T =.. [OccursNot,X,T],
	writeClause((BindDirect_X_T_R_E0_E :- var(T), !, X=T,
		                              R='Prelude.True', E0=E)),
	(printConsFailure(no)
	 -> writeClause((BindDirect_X_T_R_E0_E :-
			     OccursNot_X_T, X=T, R='Prelude.True', E0=E))
	  ; BindDirect_X_FAIL_E_E =..
	                      [BindDirect,X,'FAIL'(Src),'FAIL'(Src),E,E],
	    writeClause((BindDirect_X_FAIL_E_E :- !)),
	    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.=:=',[]),[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)),
	writeClause((Bind_X_T_E0_E :- number(T), !, X=T, E0=E)),
	(printConsFailure(no) -> true
	 ; Bind_X_FAIL_E_E =.. [Bind,X,'FAIL'(Src),'FAIL'(Src),E,E],
	   writeClause((Bind_X_FAIL_E_E :- !))),
	Bind_A_B_R_E0_E =.. [Bind,A,B,R,E0,E],
	appendAtom(occursNotArgs,Suffix,OccursNotArgs),
	OccursNotArgs_1_NB_A_B =.. [OccursNotArgs,1,NB,A,B],
	appendAtom(bindArgs,Suffix,BindArgs),
	BindArgs_1_NB_A_B_R_E0_E =.. [BindArgs,1,NB,A,B,R,E0,E],
	(printConsFailure(no)
	 -> writeClause((Bind_A_B_R_E0_E :-
		        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 :-
		        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.=:=',[]),[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],
	OccursNot_A_ArgB =.. [OccursNot,A,ArgB],
	writeClause((OccursNotArgs_N_NA_A_B :- N>NA,!)),
	writeClause((OccursNotArgs_N_NA_A_B :- arg(N,B,ArgB),
		        OccursNot_A_ArgB,
		        N1 is N+1, OccursNotArgs_N1_NA_A_B)),
	nl,
	BindArgs_N_NA_A_B_E0_E =.. [BindArgs,N,NA,A,B,'Prelude.True',E0,E],
	BindArgs_N_NA_A_B_R_E0_E =.. [BindArgs,N,NA,A,B,R,E0,E],
	Bind_ArgA_HArgB_R_E1_E2 =.. [Bind,ArgA,HArgB,R,E1,E2],
	Bind_ArgA_HArgB_R0_E1_E2 =.. [Bind,ArgA,HArgB,R0,E1,E2],
	BindArgs_N1_NA_A_B_R_E2_E =.. [BindArgs,N1,NA,A,B,R,E2,E],
	writeClause((BindArgs_N_NA_A_B_E0_E :- N>NA,!, E0=E)),
	(printConsFailure(no)
	 -> writeClause((BindArgs_N_NA_A_B_R_E0_E :-
		        arg(N,A,ArgA), arg(N,B,ArgB),
		        hnf(ArgB,HArgB,E0,E1), Bind_ArgA_HArgB_R_E1_E2,
		        N1 is N+1, BindArgs_N1_NA_A_B_R_E2_E))
	  ; writeClause((BindArgs_N_NA_A_B_R_E0_E :-
		        arg(N,A,ArgA), arg(N,B,ArgB),
		        hnf(ArgB,HArgB,E0,E1), Bind_ArgA_HArgB_R0_E1_E2,
		        N1 is N+1,
			freeze(E2,(R0='FAIL'(_) -> R=R0, E2=E
				                 ; BindArgs_N1_NA_A_B_R_E2_E))))),
	nl,
	OccursNot_X_Y =.. [OccursNot,X,Y],
	writeClause((OccursNot_X_Y :- var(Y), !, X\==Y)),
	OccursNotArgs_1_NY_X_Y =.. [OccursNotArgs,1,NY,X,Y],
	writeClause((OccursNot_X_Y :- functor(Y,FY,NY),
		                      constructortype(FY,_,NY,_,_,_,_),
		                      !, OccursNotArgs_1_NY_X_Y)),
	writeClause(OccursNot_X_Y),
	nl.


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% translation of clauses for (Boolean) strict equality test
	
transBoolEq(Suffix) :-
	appendAtom(boolEq,Suffix,BoolEqOrg),
	genBlockDecl(BoolEqOrg,5,[4],BoolEq),
	appendAtom(boolEqHnf,Suffix,BoolEqHnfOrg),
	BoolEq_A_B_R_E0_E =.. [BoolEq,A,B,R,E0,E],
	BoolEqHnf_HA_HB_R_E2_E =.. [BoolEqHnfOrg,HA,HB,R,E2,E],
	writeClause((BoolEq_A_B_R_E0_E :- hnf(A,HA,E0,E1),hnf(B,HB,E1,E2),
	                                  BoolEqHnf_HA_HB_R_E2_E)),
	nl,
	%genBlockDecl(BoolEqHnfOrg,5,[1,2,4],BoolEqHnf),
	genBlockDecl(BoolEqHnfOrg,5,[4],BoolEqHnf),
	BoolEqHnf_A_B_R_E0_E =.. [BoolEqHnf,A,B,R,E0,E],
	BoolEqHnf_B_A_R_E0_E =.. [BoolEqHnf,B,A,R,E0,E],
	% wait if both arguments are variables:
	writeClause((BoolEqHnf_A_B_R_E0_E :- var(A), var(B), !,
		      evaluator:addSuspensionReason('Comparing (with ==) two free variables'),
		      when((nonvar(A);nonvar(B)),BoolEqHnf_A_B_R_E0_E))),
	writeClause((BoolEqHnf_A_B_R_E0_E :- var(A), !,
		                             BoolEqHnf_B_A_R_E0_E)),
	(printConsFailure(no) -> true
	 ; BoolEqHnf_FAIL_X_E_E =.. [BoolEqHnf,'FAIL'(Src),X,'FAIL'(Src),E,E],
	   writeClause((BoolEqHnf_FAIL_X_E_E :- !)),
	   BoolEqHnf_X_FAIL_E_E =.. [BoolEqHnf,X,'FAIL'(Src),'FAIL'(Src),E,E],
	   writeClause((BoolEqHnf_X_FAIL_E_E :- !))),
	writeClause((BoolEqHnf_A_B_R_E0_E :-
		% we cannot narrow numbers or characters, so we wait:
		(number(A) ; basics:isCharCons(A)), !,
		((A=B, R='Prelude.True', E0=E) ;
		    evaluator:addSuspensionReason('Comparing (with ==) a free variable with a number or character'),
		    when(nonvar(B),(A\=B, R='Prelude.False', E0=E))))),
	appendAtom(genBoolEqHnfBody,Suffix,GenBoolEqHnfBody),
	GenBoolEqHnfBody_1_NA =.. [GenBoolEqHnfBody,1,NA,A,B,SeqBody],
	writeClause((BoolEqHnf_A_B_R_E0_E :- var(B), !, % bind variable
	    functor(A,FA,NA),
	    ((functor(B,FA,NA),GenBoolEqHnfBody_1_NA,hnf(SeqBody,R,E0,E))
	     ; (constructortype(FA,_,NA,_,_,_,OtherCons),
		member(OC/OCA,OtherCons),
		functor(B,OC,OCA), R='Prelude.False',E0=E)))),
	writeClause((BoolEqHnf_A_B_R_E0_E :-
		       functor(A,FA,NA),
		       ((functor(B,FA,NA),GenBoolEqHnfBody_1_NA)
		          -> hnf(SeqBody,R,E0,E)
		           ; R='Prelude.False',E0=E))),
	nl,
	GenBoolEqHnfBody_N_NA_True =.. [GenBoolEqHnfBody,N,NA,_,_,'Prelude.True'],
	writeClause((GenBoolEqHnfBody_N_NA_True :- N>NA,!)),
	appendAtom('Prelude.==',Suffix,Eq),
	Eq_ArgA_ArgB =.. [Eq,ArgA,ArgB],
	appendAtom('Prelude.&&',Suffix,BoolAnd),
	BoolAnd_Eq =.. [BoolAnd,Eq_ArgA_ArgB,RemBody],
	GenBoolEqHnfBody_N_NA_And =.. [GenBoolEqHnfBody,N,NA,A,B,BoolAnd_Eq],
	GenBoolEqHnfBody_N1_NA =.. [GenBoolEqHnfBody,N1,NA,A,B,RemBody],
	writeClause((GenBoolEqHnfBody_N_NA_And :-
		       arg(N,A,ArgA), arg(N,B,ArgB),
		       N1 is N+1, GenBoolEqHnfBody_N1_NA)),
	nl.


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% translation of clauses for evaluation to normal form
	
transNf(Suffix) :-
	appendAtom(nf,Suffix,NfOrg),
	genBlockDecl(NfOrg,4,[3],Nf),
	appendAtom(nfHnf,Suffix,NfHnfOrg),
	%NfMode =.. [Nf,?,?,-,?],
	%writeClause((:- block NfMode)),
	Nf_A_V_E0_E =.. [Nf,A,V,E0,E],
	NfHnf_HA_V_E1_E =.. [NfHnfOrg,HA,V,E1,E],
	writeClause((Nf_A_V_E0_E :- hnf(A,HA,E0,E1), NfHnf_HA_V_E1_E)),
	nl,
	genBlockDecl(NfHnfOrg,4,[3],NfHnf),
	%NfHnfMode =.. [NfHnf,?,?,-,?],
	%writeClause((:- block NfHnfMode)),
	NfHnf_T_V_E0_E =.. [NfHnf,T,V,E0,E],
	writeClause((NfHnf_T_V_E0_E :- var(T), !, V=T, E0=E)),
	NfHnf_A_A_E0_E =.. [NfHnf,A,A,E0,E],
	writeClause((NfHnf_A_A_E0_E :- number(A), !, E0=E)),
	NfHnf_IORefA_IORefA_E0_E =..
                           [NfHnf,'IOExts.IORef'(A),'IOExts.IORef'(A),E0,E],
        writeClause((NfHnf_IORefA_IORefA_E0_E :- !, E0=E)),
	% do not normalize partcall arguments:
	NfHnf_partcall_partcall_E0_E =..
                           [NfHnf,partcall(A,B,C),partcall(A,B,C),E0,E],
        writeClause((NfHnf_partcall_partcall_E0_E :- !, E0=E)),
	(printConsFailure(no) -> true
	 ; NfHnf_FailA_FailA_E0_E =.. [NfHnf,'FAIL'(A),'FAIL'(A),E0,E],
	   writeClause((NfHnf_FailA_FailA_E0_E :- !, E0=E))),
	NfHnf_A_R_E0_E =.. [NfHnf,A,R,E0,E],
	appendAtom(nfHnfArgs,Suffix,NfHnfArgs),
	NfHnfArgs_1_NA_A_NR_R_E0_E =.. [NfHnfArgs,1,NA,A,NR,R,E0,E],
	writeClause((NfHnf_A_R_E0_E :-
		       functor(A,FA,NA), functor(NR,FA,NA),
		       NfHnfArgs_1_NA_A_NR_R_E0_E)),
	nl,
	NfHnfArgs_N_NA_A_NR_R_E0_E =.. [NfHnfArgs,N,NA,A,NR,R,E0,E],
	writeClause((NfHnfArgs_N_NA_A_NR_R_E0_E :- N>NA,!,R=NR,E0=E)),
	Nf_ArgA_ArgR_E0_E1 =.. [Nf,ArgA,ArgR,E0,E1],
	NfHnfArgs_N1_NA_A_NR_R_E1_E =.. [NfHnfArgs,N1,NA,A,NR,R,E1,E],
	(printConsFailure(no)
	 -> writeClause((NfHnfArgs_N_NA_A_NR_R_E0_E :-
		       arg(N,A,ArgA), arg(N,NR,ArgR),
		       Nf_ArgA_ArgR_E0_E1,
		       N1 is N+1, NfHnfArgs_N1_NA_A_NR_R_E1_E))
	  ; writeClause((NfHnfArgs_N_NA_A_NR_R_E0_E :-
		       arg(N,A,ArgA), arg(N,NR,ArgR),
		       Nf_ArgA_ArgR_E0_E1,
		       N1 is N+1,
		       freeze(E1,((nonvar(ArgR),ArgR='FAIL'(_))
				  -> R=ArgR, E1=E
				   ; NfHnfArgs_N1_NA_A_NR_R_E1_E))))),
	nl.


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% translation of clauses for create, propagate, and dereference sharing
	
genMakeFunctionShare(Suffix) :-
	appendAtom(makeShare,Suffix,MakeShare),
	appendAtom(share,Suffix,Share),
	Share_M =.. [Share,M],
	MakeShare_X_ShM =.. [MakeShare,X,Share_M],
	writeClause((MakeShare_X_ShM :- create_mutable(X,M))),
	nl.

transpropshar(Suffix) :-
	appendAtom(propagateShare,Suffix,PropShare),
	appendAtom(propagateShareArg,Suffix,PropShareArg),
	PropShare_X_X =.. [PropShare,X,X],
	writeClause((PropShare_X_X :- var(X), !)),
	PC1=partcall(N,F,PArg),
	PC2=partcall(N,F,SPArg),
	PropShare_PC_PC =.. [PropShare,PC1,PC2],
	writeClause((PropShare_PC_PC :- !, map2M(user:PropShareArg,PArg,SPArg))),
	IP='Ports.internalPort'(_,_,_,_),
	PropShare_IP_IP =.. [PropShare,IP,IP],
	writeClause((PropShare_IP_IP :- !)),
	Str='$stream'(_),
	PropShare_Str_Str =.. [PropShare,Str,Str],
	writeClause((PropShare_Str_Str :- !)),
	(printConsFailure(no) -> true
	 ; Fail='FAIL'(_),
	   PropShare_Fail_Fail =.. [PropShare,Fail,Fail],
	   writeClause((PropShare_Fail_Fail :- !))),
	writeClause((PropShare_X_X :- number(X),!)),
	PropShare_A_R =.. [PropShare,A,R],
	appendAtom(propagateShareArgs,Suffix,PropShareArgs),
	PropShareArgs_1_NA_A_R =.. [PropShareArgs,1,NA,A,R],
	writeClause((PropShare_A_R :-
		       functor(A,FA,NA), functor(R,FA,NA),
		       PropShareArgs_1_NA_A_R)),
	nl,
	PropShareArg_ArgA_ArgR =.. [PropShareArg,ArgA,ArgR],
	PropShareArgs_N_NA_A_R =.. [PropShareArgs,N,NA,A,R],
	PropShareArgs_N1_NA_A_R =.. [PropShareArgs,N1,NA,A,R],
	writeClause((PropShareArgs_N_NA_A_R :- N>NA,!)),
	writeClause((PropShareArgs_N_NA_A_R :-
		       arg(N,A,ArgA), arg(N,R,ArgR),
		       PropShareArg_ArgA_ArgR,
		       N1 is N+1, PropShareArgs_N1_NA_A_R)),
	nl,
	PropShareArg_A_A =.. [PropShareArg,A,A],
	writeClause((PropShareArg_A_A :- var(A), !)),
	writeClause((PropShareArg_A_A :- functor(A,'Ports.internalPort',4), !)),
	PropShareArg_A_SA =.. [PropShareArg,A,SA],
	appendAtom(makeShare,Suffix,MakeShare),
	MakeShare_A_SA =.. [MakeShare,A,SA],
	writeClause((PropShareArg_A_SA :- MakeShare_A_SA)),
	nl,
	MakeShare_X_X =.. [MakeShare,X,X],
	appendAtom(share,Suffix,Share),
	Share_M =.. [Share,M],
	MakeShare_X_Y =.. [MakeShare,X,Y],
	MakeShare_X_ShM =.. [MakeShare,X,Share_M],
	writeClause((MakeShare_X_X :- var(X), !)),
	writeClause((MakeShare_X_Y :- atomic(X), !, (functiontype(X,_,0,_,_,_) -> create_mutable(X,M), Y=Share_M ; Y=X))),
	writeClause((MakeShare_X_X :- X=Share_M, !)),
	writeClause((MakeShare_X_ShM :- create_mutable(X,M))),
	nl.

transDeref(CCs) :-
	write('% dereference a term, i.e., remove all top-level sharing structures:'),
	nl,
	writeClause((derefRoot(R,V) :- var(R), !, V=R)),
	map1M(compiler:transDerefClause,CCs),
	writeClause((derefRoot('FAIL'(Src),_) :- !,
	                                      evaluator:writeFailSource(Src))),
	writeClause(derefRoot(R,R)),
	nl,
	write('% completely dereference a term, i.e., remove all sharing structures'),
	nl,
	write('% also inside subterms:'), nl,
	writeClause((derefAll(R,V) :- var(R), !, V=R)),
	map1M(compiler:transDerefAllClause,CCs),
	writeClause((derefAll(R,V) :- functor(R,F,N), functor(V,F,N), derefArgs(N,R,V))),
	writeClause((derefArgs(0,_,_) :- !)),
	writeClause((derefArgs(I,R,V) :-
		         arg(I,R,RI), derefAll(RI,VI), arg(I,V,VI),
		         I1 is I-1, derefArgs(I1,R,V))),
	nl.

transDerefClause(Suffix) :-
	appendAtom(share,Suffix,Share),
	Share_M =.. [Share,M],
	writeClause((derefRoot(Share_M,V) :- !,
	             get_mutable(E,M), (E='$eval'(R) -> V=R ; derefRoot(E,V)))).

transDerefAllClause(Suffix) :-
	appendAtom(share,Suffix,Share),
	Share_M =.. [Share,M],
	writeClause((derefAll(Share_M,V) :- !,
	       get_mutable(E,M), (E='$eval'(R) -> derefAll(R,V) ; derefAll(E,V)))).


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% translation of expressions:
% here we assume that all cases and ors occur only outermost and not
% at nested inner positions
transExp(FName,Aux,Patterns,Vars,Cut,'Case'(CType,CaseExp,Cases)) :- !,
	(CaseExp='Var'(X)
	 -> % case expression is variable:
	    selectVar(X,Vars,I,VarsX),
	    % check whether the case variable occurs in any case branch
	    (occursInBranches(X,Cases)
              -> CaseTerm=ShareX, UMShares=[makeShare(X,ShareX)],
                 map2partialM(compiler:replaceShareVars(UMShares),Vars,NewVars),
                 map2partialM(compiler:insertShareInBranch(UMShares),Cases,
                                                           ShareCases)
                ; NewVars=VarsX, CaseTerm=X, UMShares=[], ShareCases=Cases),
	    number_codes(I,IS), atom_codes(IA,IS) % transform number into atom
	  ; % case expression is complex (not a variable)
	    (compileWithSharing(variable)
	     -> %exp2ShareExpr(CaseExp,UMShares,SCExp),
		getSharedVarsOfCaseArg('Case'(CType,CaseExp,Cases),UMShares),
		insertShare(CaseExp,UMShares,SCExp),
		map2partialM(compiler:replaceShareVars(UMShares),Vars,NewVars),
		exp2Term(NewVars,SCExp,CaseTerm),
		map2partialM(compiler:insertShareInBranch(UMShares),Cases,ShareCases)
	      ; (compileWithSharing(function)
	         -> exp2FuncShareTerm(Vars,CaseExp,UMShares,CaseTerm),
		    NewVars=Vars, ShareCases=Cases
	          ; exp2Term(Vars,CaseExp,CaseTerm),
		    UMShares=[], NewVars=Vars, ShareCases=Cases)),
	    IA='ComplexCase'  % naming needs to be improved!
	),
	atom_codes(FName,FNameS), getCostCenterOfName(FNameS,CC),
	map2partialM(compiler:addSuffix2MakeShare(CC),UMShares,UShares),
	append(Patterns,[H,E0,E],LArgs),
	LHS =.. [FName|LArgs],
	appendAtom(FName,Aux,FNaux),
	appendAtom(FNaux,'_',FNameUS),
	appendAtom(FNameUS,IA,F_I),
	(var(CaseTerm) -> replaceEq(CaseTerm,Y,NewVars,ArgVars)
	                ; ArgVars=NewVars),
	append(ArgVars,[H,E1,E],F_I_Args),
	F_I_Call =.. [F_I,Y|F_I_Args],
	(Cut=withcut -> CutUShares=['!'|UShares] ; CutUShares=UShares),
	writeClauseWithInitGoals(LHS,CutUShares,
	                         (hnf(CaseTerm,Y,E0,E1), F_I_Call)),
	nl,
	length(NewVars,LenNewVars), NumVars is LenNewVars+1,
	F_I_Arity is NumVars+3,
	F_I_Arity1 is NumVars+2,
	(CType='Rigid'
	 -> genBlockDecl(F_I,F_I_Arity,[1,F_I_Arity1],NewF_I)
	  ; % CType='Flex'
	    genBlockDecl(F_I,F_I_Arity,[F_I_Arity1],NewF_I)),
	transCases(NewF_I,NewVars,ShareCases,CType,FName).

transExp(FName,Aux,Patterns,Vars,_,'Or'(Exp1,Exp2)) :- !,
	appendAtom(Aux,'_or1',Aux1),
	appendAtom(Aux,'_or2',Aux2),
	transExp(FName,Aux1,Patterns,Vars,nocut,Exp1),
	transExp(FName,Aux2,Patterns,Vars,nocut,Exp2).

transExp(FName,Aux,Patterns,Vars,Cut,'Comb'('FuncCall',"commit",[Exp])) :- !,
	writeErr('ERROR: "'),
	writeErr(FName),
	writeLnErr(' eval choice" not yet supported!'),
	transExp(FName,Aux,Patterns,Vars,Cut,Exp),
	setFlcBug.

transExp(FName,_Aux,Patterns,Vars,Cut,Exp) :-
	append(Patterns,[H,E0,E],LArgs),
	LHS =.. [FName|LArgs],
	(compileWithSharing(variable)
	 -> exp2ShareExpr(Exp,UMShares,SExp),
            map2partialM(compiler:replaceShareVars(UMShares),Vars,NewVars),
	    exp2Term(NewVars,SExp,Term)
	  ; (compileWithSharing(function)
	     -> exp2FuncShareTerm(Vars,Exp,UMShares,Term)
	      ; exp2Term(Vars,Exp,Term), UMShares=[])),
	atom_codes(FName,FNameS), getCostCenterOfName(FNameS,CC),
	map2partialM(compiler:addSuffix2MakeShare(CC),UMShares,UShares),
	(Cut=withcut -> CutUShares=['!'|UShares] ; CutUShares=UShares),
	(isConstructorRooted(Exp)
	 -> % right-hand side is constructor-rooted -> no hnf call necessary:
            H=Term,
	    (UShares=[]
		-> E0=E,
		   (Cut=withcut -> writeClause((LHS :- !))
                                 ; writeClause(LHS))
		 ; writeClauseWithInitGoals(LHS,CutUShares,E0=E))
	 ; ((var(Term) ; hnfTailCallOptim(no) ; (\+ localFunCall(FName,Exp)))
	    -> writeClauseWithInitGoals(LHS,CutUShares,hnf(Term,H,E0,E))
             ; % if the right-hand side is operation-rooted ->
	       % generate direct call to root predicate:
  	       functor(Term,TF,TA),
	       Term =.. [TF|TArgs],
	       append(TArgs,[H,E0,E],TArgsH),
	       externalFuncs(EFs),
	       (member((TF/TA,PrimName),EFs)
	        -> append(_,[32|TPS],PrimName), atom_codes(TP,TPS) ; TP=TF),
	       TPCall =.. [TP|TArgsH],
               writeClauseWithInitGoals(LHS,CutUShares,TPCall) )).

localFunCall(DefFuncName,'Comb'('FuncCall',FName,_)) :-
	atom_codes(DefFuncName,DefFuncNameS),
	fromSameModule(DefFuncNameS,FName), !.
localFunCall(DefFuncName,'Free'(_,Exp)) :- % since we ignore Constr in the code:
	localFunCall(DefFuncName,Exp).

fromSameModule(F1,F2) :-
	append(Mod,[46|_],F1),
	append(Mod,[46|_],F2), !.

isConstructorRooted('Lit'(_)).
isConstructorRooted('Comb'('ConsCall',_,_)).
isConstructorRooted('Free'(_,Exp)) :- % since we ignore Constr in the code:
	isConstructorRooted(Exp).


transCases(_,_,[],_,_) :- failForwarding(no), !.
transCases(F_I,VarsX,[],CType,FName) :- % generate clause for Fail forwarding:
	(failCheckFunc(no)
	 -> append(['FAIL'(Src)|VarsX],['FAIL'([FName|Src]),E,E],ClauseArgs)
	  ; append(['FAIL'(Src)|VarsX],['FAIL'(Src),E,E],ClauseArgs)),
	LHS =.. [F_I|ClauseArgs],
	% avoid instantiation with FAIL in case of flexible branches:
	(CType='Flex' -> RHS=nonvar(Src) ; RHS=true),
	writeClause((LHS :- RHS)).
transCases(F_I,VarsX,['Branch'('Pattern'(Name,ConsVars),Exp)|Cases],
	   CType,FName) :-
	atom_codes('Prelude.failure',FailFuncName),
	((Exp='Comb'('FuncCall',FailFuncName,_), CType='Flex')
	 -> NCType='Rigid'
	  ; NCType=CType),
	flatName2Atom(Name,Cons),
	Pattern =.. [Cons|ConsVars],
	append(ConsVars,VarsX,NewVars),
	atomic2Atom(Cons,ConsA),
	appendAtom('_',ConsA,Aux),
	(noFurtherNonFailingCase(CType,Cases) -> Cut=withcut ; Cut=nocut),
	transExp(F_I,Aux,[Pattern|VarsX],NewVars,Cut,Exp),
	transCases(F_I,VarsX,Cases,NCType,FName).
transCases(F_I,VarsX,['Branch'('LPattern'(Lit),Exp)|Cases],CType,FName) :-
	transCaseLit2Cons(Lit,Cons),
	atomic2Atom(Cons,ConsA),
	appendAtom('_',ConsA,Aux),
	transExp(F_I,Aux,[Cons|VarsX],VarsX,nocut,Exp),
	transCases(F_I,VarsX,Cases,CType,FName).

% are the further case branches only failure branches?
noFurtherNonFailingCase(_,[]).
noFurtherNonFailingCase(CType,['Branch'('Pattern'(_,_),Exp)|_]) :-
	atom_codes('Prelude.failure',FailFuncName),
	Exp='Comb'('FuncCall',FailFuncName,_), CType='Flex'.

% extract constructor of literal:
transCaseLit2Cons('Intc'(I),I) :- !.
transCaseLit2Cons('Floatc'(F),F) :- !.
transCaseLit2Cons('Charc'(N),C) :- !, char_int(C,N).
transCaseLit2Cons(Lit,Lit) :-
	writeErr('ERROR in FlatCurry file: Illegal argument "'),
	writeErr(Lit),
	writeLnErr('" in case branch!'),
	pleaseReport.

% translate FlatCurry expression into corresponding Prolog term:
% (first argument are the currently visible variables, only used
% to check inconsistencies in FlatCurry)
exp2Term(Vars,'Var'(V),V) :- !,
	(memberEq(V,Vars) -> true
	  ; writeErr('ERROR in FlatCurry file in function "'),
	    currentFunction(FuncName), writeErr(FuncName),
	    writeLnErr('":'),
	    writeErr('variable "'),
	    writeErr(V),
	    writeLnErr('" does not occur in left-hand side.'),
	    reportLiftBug,
	    put_code(37), write('ERROR in FlatCurry file: variable "'),
	    write(V),
	    write('" does not occur in left-hand side!'), nl).
exp2Term(_,'Lit'('Intc'(I)),I) :- !.
exp2Term(_,'Lit'('Floatc'(F)),F) :- !.
exp2Term(_,'Lit'('Charc'(N)),C) :- !, char_int(C,N).
exp2Term(_,'Lit'('Ident'(S)),A) :- !,
	writeErr('ERROR in FlatCurry file in function "'),
	currentFunction(FuncName), writeErr(FuncName),
	writeLnErr('":'),
	flatName2Atom(S,A),
	writeErr('Expression "'),
	writeErr('Lit'('Ident'(A))),
	writeLnErr('" should not occur in FlatCurry expressions.'),
	pleaseReport,
	put_code(37), write('ERROR in FlatCurry file: Expression "'),
	write('Lit'('Ident'(A))),
	write('" should not occur in FlatCurry expressions.'),
	nl.
exp2Term(Vars,'Comb'(CombType,NameS,Exprs),Term) :- !,
	flatName2Atom(NameS,Name),
	checkForDeprecatedFunction(Name),
	checkForDynamicConstructor(Name),
	checkForTupleArity(NameS),
	map2partialM(compiler:exp2Term(Vars),Exprs,Terms),
	%length(Terms,TArity),
	((CombType='ConsCall' ; CombType='ConsPartCall'(_))
          %getConsArity(Name,Arity)
	 -> Missing=0 % constructors are not represented by partial applications
	 ; (CombType='FuncCall' -> Missing=0
                                 ; CombType='FuncPartCall'(Missing))),
           %(getFuncArity(Name,Arity) -> Missing is Arity-TArity ; Missing=0)),
	(Missing=0 -> Term =.. [Name|Terms] ;
         (Missing>0 -> rev(Terms,RevTerms), Term = partcall(Missing,Name,RevTerms)
	             ; writeLnErr('INTERNAL COMPILER ERROR: over-application occured in exp2Term!'),
	               writeErr('Function: '),
	               currentFunction(QFunc), writeLnErr(QFunc),
	               writeErr('Expression: '),
	               writeLnErr('Comb'(CombType,NameS,Exprs)),
	               setFlcBug)).
exp2Term(Vars,'Free'(LocalVars,Exp),ET) :- !,
	append(Vars,LocalVars,NewVars),
	exp2Term(NewVars,Exp,ET).
exp2Term(_,Expr,'***unknown expression***') :-
	writeErr('ERROR in FlatCurry file: Unknown expression "'),
	writeErr(Expr),
	writeLnErr('" in FlatCurry file!'),
	pleaseReport.


% implement sharing scheme for variable sharing according to [Antoy/Hanus FroCos'2000]
% replace multiple variables by new variables connected to the old
% ones via a makeShare goal:
exp2ShareExpr(Exp,Shares,SExp) :-
	getSharedVars(Exp,Shares),
	insertShare(Exp,Shares,SExp).

insertShare('Var'(V),Shares,Share) :- !,
	varToShare(V,Shares,Share).
insertShare('Lit'(L),_,'Lit'(L)) :- !.
insertShare('Comb'(CT,Name,Exprs),Shares,'Comb'(CT,Name,SExprs)) :- !,
	insertShares(Exprs,Shares,SExprs).
insertShare('Free'(Vars,Exp),Shares,'Free'(NewVars,SExp)) :- !,
        map2partialM(compiler:replaceShareVars(Shares),Vars,NewVars),
	insertShare(Exp,Shares,SExp).
insertShare('Case'(CType,Exp,Branches),Shares,'Case'(CType,SExp,SBranches)) :-
	!,
	insertShare(Exp,Shares,SExp),
	map2partialM(compiler:insertShareInBranch(Shares),Branches,SBranches).
insertShare('Or'(Exp1,Exp2),Shares,'Or'(SExp1,SExp2)) :-
	!,
	insertShare(Exp1,Shares,SExp1),
	insertShare(Exp2,Shares,SExp2).
insertShare(Exp,_,Exp) :-
	writeLnErr('INTERNAL ERROR in "insertShare"!'),
	writeLnErr('Unknown expression in FlatCurry file:'),
	writeLnErr(Exp),
	pleaseReport.

insertShareInBranch(Shares,'Branch'(Pattern,Exp),'Branch'(Pattern,SExp)) :-
        insertShare(Exp,Shares,SExp).

insertShares([],_,[]).
insertShares([T|Ts],Shares,[ST|STs]) :-
	insertShare(T,Shares,ST),
	insertShares(Ts,Shares,STs).

varToShare(V,[],'Var'(V)).
varToShare(V,[makeShare(W,NV)|_],'Var'(NV)) :- V==W, !.
varToShare(V,[_|Shares],Share) :- varToShare(V,Shares,Share).

replaceShareVars([],V,V).
replaceShareVars([makeShare(V,NV)|_],W,NV) :- V==W, !.
replaceShareVars([_|UVs],W,NV) :- replaceShareVars(UVs,W,NV).

% implement sharing scheme for function sharing (classical technique):
exp2TermInMakeShare(Vars,makeShare(Exp,V),makeShare(Term,V)) :-
	exp2Term(Vars,Exp,Term).

exp2FuncShareTerm(Vars,Exp,Shares,Term) :-
	exp2FuncShareTerm(top,Vars,Exp,SharesR,Term),
	rev(SharesR,Shares).

exp2FuncShareTerm(_,Vars,'Var'(V),[],V) :- !,
	(memberEq(V,Vars) -> true
	  ; writeErr('ERROR in FlatCurry file in function "'),
	    currentFunction(FuncName), writeErr(FuncName),
	    writeLnErr('":'),
	    writeErr('variable "'),
	    writeErr(V),
	    writeLnErr('" does not occur in left-hand side.'),
	    reportLiftBug,
	    put_code(37), write('ERROR in FlatCurry file: variable "'),
	    write(V),
	    write('" does not occur in left-hand side!'), nl).
exp2FuncShareTerm(_,_,'Lit'('Intc'(I)),[],I) :- !.
exp2FuncShareTerm(_,_,'Lit'('Floatc'(F)),[],F) :- !.
exp2FuncShareTerm(_,_,'Lit'('Charc'(N)),[],C) :- !, char_int(C,N).
exp2FuncShareTerm(_,_,'Lit'('Ident'(S)),[],A) :- !,
	writeErr('ERROR in FlatCurry file in function "'),
	currentFunction(FuncName), writeErr(FuncName),
	writeLnErr('":'),
	flatName2Atom(S,A),
	writeErr('Expression "'),
	writeErr('Lit'('Ident'(A))),
	writeLnErr('" should not occur in FlatCurry expressions.'),
	pleaseReport,
	put_code(37), write('ERROR in FlatCurry file: Expression "'),
	write('Lit'('Ident'(A))),
	write('" should not occur in FlatCurry expressions.'),
	nl.
exp2FuncShareTerm(Level,Vars,'Comb'(CombType,NameS,Exprs),NewShares,NewTerm) :- !,
	exp2FuncShareTerms(Vars,Exprs,Shares,Terms),
	flatName2Atom(NameS,Name),
	checkForDeprecatedFunction(Name),
	checkForDynamicConstructor(Name),
	checkForTupleArity(NameS),
	length(Terms,TArity),
	(getConsArity(Name,Arity)
	 -> Missing=0 % constructors are not represented by partial applications
	 ; (getFuncArity(Name,Arity) -> Missing is Arity-TArity ; Missing=0)),
	(Missing=0 -> Term =.. [Name|Terms] ;
         (Missing>0 -> rev(Terms,RevTerms), Term = partcall(Missing,Name,RevTerms)
	             ; writeLnErr('INTERNAL COMPILER ERROR: over-application occured in exp2FuncShareTerm!'))),
	((CombType='FuncCall', Level=subterm)
	 -> NewShares = [makeShare(Term,V)|Shares], NewTerm = V
	  ; NewShares = Shares, NewTerm = Term).
exp2FuncShareTerm(Level,Vars,'Free'(LocalVars,Exp),Shares,Term) :- !,
	append(Vars,LocalVars,NewVars),
	exp2FuncShareTerm(Level,NewVars,Exp,Shares,Term).
exp2FuncShareTerm(_,_,Exp,[],'***unknown expression***') :-
	writeLnErr('INTERNAL ERROR in "exp2FuncShareTerm"!'),
	writeLnErr('Unknown expression in FlatCurry file:'),
	writeLnErr(Exp),
	pleaseReport.

exp2FuncShareTerms(_,[],[],[]).
exp2FuncShareTerms(Vars,[T|Ts],Shares,[ST|STs]) :-
	exp2FuncShareTerm(subterm,Vars,T,Shares1,ST),
	exp2FuncShareTerms(Vars,Ts,Shares2,STs),
	append(Shares1,Shares2,Shares).

% add suffix to "makeShare":
addSuffix2MakeShare(Suffix,makeShare(V,NV),MSs) :-
	appendAtom(makeShare,Suffix,MakeShare),
	MSs =.. [MakeShare,V,NV].


% get the variables in a term which occurs more than once and must be shared:
getSharedVars(Exp,Shares) :-
	countVarsInTerm(Exp,[],Vars),
	varsIntoShares(Vars,Shares).

% get the variables of a case argument which occurs more tha once in the case expression
% and, thus, must be shared:
getSharedVarsOfCaseArg('Case'(_,CaseExp,Branches),Shares) :-
	countVarsInTerm(CaseExp,[],ArgVars),
	countVarsInBranches(Branches,ArgVars,CaseVars),
	prefixVars(ArgVars,CaseVars,MultArgVars),
	varsIntoShares(MultArgVars,Shares).

% prefixVars(Xs,Ys,Zs): Zs is prefix of Ys that has the same length as Xs
prefixVars([],_,[]).
prefixVars([_|Xs],[Y|Ys],[Y|Zs]) :- prefixVars(Xs,Ys,Zs).
	
varsIntoShares([],[]).
varsIntoShares([V/C|Vs],[makeShare(V,_)|Shs]) :-
	C>1, !,
	  % for statistics:
	  retract(numberOfShares(SC)),
	  SC1 is SC+1,
	  asserta(numberOfShares(SC1)),
	varsIntoShares(Vs,Shs).
varsIntoShares([_|Vs],Shs) :-
	varsIntoShares(Vs,Shs).

countVarsInTerm('Var'(V),Vars,IVars) :- !, incVarCount(V,Vars,IVars).
countVarsInTerm('Lit'(_),Vars,Vars) :- !.
countVarsInTerm('Comb'(_,_,Terms),Vars,IVars) :- !,
	countVarsInTerms(Terms,Vars,IVars).
countVarsInTerm('Free'(_,Exp),Vars,IVars) :- !,
	countVarsInTerm(Exp,Vars,IVars).
countVarsInTerm('Case'(_,CaseExp,Branches),Vars,IVars) :- !,
	countVarsInTerm(CaseExp,Vars,CVars),
	countVarsInBranches(Branches,CVars,IVars).
countVarsInTerm('Or'(E1,E2),Vars,IVars) :- !,
	countVarsInTerm(E1,Vars,Vars1),
	countVarsInTerm(E2,Vars1,IVars).
countVarsInTerm(Exp,Vars,Vars) :- !,
	writeLnErr('INTERNAL ERROR in "countVarsInTerm"!'),
	writeLnErr('Unknown expression in FlatCurry file:'),
	writeLnErr(Exp),
	pleaseReport.

countVarsInTerms([],Vars,Vars).
countVarsInTerms([X|Xs],Vars,IVars) :-
	countVarsInTerm(X,Vars,XVars),
	countVarsInTerms(Xs,XVars,IVars).

countVarsInBranches([],Vars,Vars).
countVarsInBranches(['Branch'(_,X)|Xs],Vars,IVars) :-
	countVarsInTerm(X,Vars,XVars),
	countVarsInBranches(Xs,XVars,IVars).

incVarCount(V,[],[V/1]).
incVarCount(V,[X/T|Vars],[X/T1|Vars]) :- V==X, !, T1 is T+1.
incVarCount(V,[X/T|Vars],[X/T|IVars]) :- incVarCount(V,Vars,IVars).



% select a variable in a list of variables.
% return position in the list and list of variables without this variable
selectVar(X,[Y|Ys],1,Ys) :- X==Y, !.
selectVar(X,[Y|Ys],XNr,[Y|Zs]) :- selectVar(X,Ys,Nr,Zs), XNr is Nr+1.



%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Check correctness of FlatCurry rules and expressions.
% This checking is redundant and should only ensure
% that the front-end produces syntactically correct code.

check_flcFunction('Func'(Name,_,_,_,Rule)) :-
	flatName2Atom(Name,FName),
	retract(currentFunction(_)),
	decodePrologName(FName,FlatName),
	asserta(currentFunction(FlatName)),
        check_flcRule(Rule), !.
check_flcFunction(_) :-
	writeErr('INTERNAL ERROR in FlatCurry file "'),
	writeErr('" in function "'),
	currentFunction(FName), writeErr(FName),
	writeLnErr('"!'),
	pleaseReport.

check_flcRule('Rule'(Args,Expr)) :-
	map1M(user:integer,Args),
	check_flcExpr(Expr).
check_flcRule('External'(Name)) :-
	check_flcString(Name).

check_flcString(S) :- map1M(user:integer,S).

check_flcCaseType('Rigid').
check_flcCaseType('Flex').

check_flcCombType('FuncCall').
check_flcCombType('ConsCall').
check_flcCombType('FuncPartCall'(_)).
check_flcCombType('ConsPartCall'(_)).

check_flcExpr('Var'(_)) :- !.
check_flcExpr('Lit'(L)) :- !, check_flcLit(L).
check_flcExpr('Comb'(CT,Name,Es)) :- !,
	check_flcCombType(CT),
	check_flcString(Name),
	map1M(compiler:check_flcExpr,Es).
check_flcExpr('Free'(Xs,E)) :- !,
	map1M(user:integer,Xs),
	check_flcExpr(E).
check_flcExpr('Let'(Bindings,E)) :- !,
	map1M(compiler:check_flcBinding,Bindings),
	check_flcExpr(E).
check_flcExpr('Or'(E1,E2)) :- !,
	check_flcExpr(E1), check_flcExpr(E2).
check_flcExpr('Case'(CT,E,Cs)) :- !,
	check_flcCaseType(CT),
	check_flcExpr(E),
	map1M(compiler:check_flcCase,Cs).
check_flcExpr(E) :-
	writeErr('ERROR in FlatCurry file: Illegal expression "'),
	writeErr(E),
	writeErr('" in function "'),
	currentFunction(FName), writeErr(FName),
	writeLnErr('"!'),
	reportLiftBug.

check_flcBinding('Prelude.(,)'(V,E)) :- integer(V), check_flcExpr(E).

check_flcLit('Intc'(_)) :- !.
check_flcLit('Floatc'(_)) :- !.
check_flcLit('Charc'(_)) :- !.
check_flcLit(Lit) :-
	writeErr('ERROR in FlatCurry file: Illegal literal "'),
	writeErr(Lit),
	writeErr('" in function "'),
	currentFunction(FName), writeErr(FName),
	writeLnErr('"!'),
	pleaseReport.

check_flcCase('Branch'('Pattern'(Name,Xs),E)) :- !,
	check_flcString(Name),
	map1M(user:integer,Xs),
	check_flcExpr(E).
check_flcCase('Branch'('LPattern'(C),E)) :- !,
	check_flcLit(C),
	check_flcExpr(E).
check_flcCase(Branch) :-
	writeErr('ERROR in FlatCurry file: Illegal case pattern "'),
	writeErr(Branch),
	writeErr('" in function "'),
	currentFunction(FName), writeErr(FName),
	writeLnErr('"!'),
	pleaseReport.


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Auxiliaries:

% generate N new free variables:
genVars(N,[]) :- N=0, !.
genVars(N,[_|Xs]) :- N1 is N-1, genVars(N1,Xs).

writeNTimes(0,_) :- !.
writeNTimes(N,S) :- N>0, write(S), N1 is N-1, writeNTimes(N1,S).

% write a clause and puts some initialization goals at the beginning
% of the right-hand side:
writeClauseWithInitGoals(LHS,Init,RHS) :-
	rev(Init,RInit),
	writeClauseWithRevInitGoals(LHS,RInit,RHS).
writeClauseWithRevInitGoals(LHS,[],RHS) :-
	writeClause((LHS :- RHS)).
writeClauseWithRevInitGoals(LHS,[G|Gs],RHS) :-
	writeClauseWithRevInitGoals(LHS,Gs,(G,RHS)).

writeClause(C) :- deleteLastTrue(C,C1), writeqWithVars(C1), write('.'), nl.

% delete a possibly generated last literal "true" in the clause:
deleteLastTrue((Head :- true),Head) :- !.
deleteLastTrue((Head :- B),(Head :- B1)) :- deleteLastTrueInBody(B,B1).
deleteLastTrue(Head,Head).

deleteLastTrueInBody((L,true),L) :- !.
deleteLastTrueInBody((L,B),(L,B1)) :- deleteLastTrueInBody(B,B1).


% replace all dots by underscores in an atom:
replaceDotByUnderscore(DA,UA) :-
	atom_codes(DA,DAS),
	replaceDotsByUnderscores(DAS,UAS),
	atom_codes(UA,UAS).
replaceDotsByUnderscores(DAS,UAS) :-
	append(S1,[46|S2],DAS), !,
	replaceDotsByUnderscores(S2,S3),
	append(S1,[95|S3],UAS).
replaceDotsByUnderscores(S,S).


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% check the header of a generated (Prolog) program and delete it
% if it is not appropriate:
checkProgramHeader(PrologProg) :-
	existsFile(PrologProg),
	% catch read errors:
	on_exception(_Exc,readProgramHeader(PrologProg,Header),
		     (deletePrologTarget(PrologProg),fail)),
	(checkHeaderParams(Header) -> true ; deletePrologTarget(PrologProg)),
	!.
checkProgramHeader(_).

% delete an existing Prolog target file:
deletePrologTarget(PrologProg) :-
	existsFile(PrologProg),
	writeErrNQ('Deleting old target file \''),
	writeErrNQ(PrologProg),
	writeLnErrNQ('\'.'),
	tryDeleteFile(PrologProg), !.
deletePrologTarget(_).

% check header parameters for current settings:
checkHeaderParams(Header) :-
	compilerVersion(CV),
	atom_codes(CV,CVL),
	member([37|CVL],Header), % 37 = '%'
	prologMajor(Prolog), atom_codes(Prolog,PrologS),
	member(PrologS,Header),
	(compileWithSharing(variable) -> member("VARIABLESHARING",Header)
	                               ; \+ member("VARIABLESHARING",Header)),
	(compileWithSharing(function) -> member("FUNCTIONSHARING",Header)
	                               ; \+ member("FUNCTIONSHARING",Header)).

% read the header of a generated (Prolog) program:
readProgramHeader(Prog,Header) :-
	open(Prog,read,ProgStream),
	readStreamLine(ProgStream,Line),
	close(ProgStream),
	split2words(Line,Header).


