$ message "Compiling the compiler ...";
$ include "seed7_05.s7i";
include "stdio.s7i";
include "osfiles.s7i";
include "scanstri.s7i";
include "unicode.s7i";
include "bigint.s7i";
include "float.s7i";
include "math.s7i";
include "bytedata.s7i";
include "bin64.s7i";
include "draw.s7i";
include "keybd.s7i";
include "progs.s7i";
include "shell.s7i";
include "cc_conf.s7i";
include "inifile.s7i";
include "comp/config.s7i";
include "comp/type.s7i";
include "comp/expr.s7i";
include "comp/debug.s7i";
include "comp/literal.s7i";
include "comp/destr.s7i";
include "comp/create.s7i";
include "comp/copy.s7i";
include "comp/expr_utl.s7i";
include "comp/stat.s7i";
include "comp/inline.s7i";
include "comp/const.s7i";
include "comp/intrange.s7i";
include "comp/error.s7i";
include "comp/library.s7i";
include "comp/action.s7i";
const string: temp_marker is "/* Seed7 compiler temp file */";
const boolean: SHOW_STATISTIC is FALSE;
const type: optionHash is hash [string] string;
var boolean: compileLibrary is FALSE;
var array string: libraryDirs is 0 times "";
var reference: main_object is NIL;
var file: c_prog is STD_NULL;
var integer: countDeclarations is 0;
var expr_type: global_init is expr_type.value;
const type: globalInitHash is hash [reference] string;
var globalInitHash: globalInitalisations is globalInitHash.EMPTY_HASH;
const type: interface_hash is hash [type] array type;
const type: enum_literal_hash is hash [type] element_number_hash;
const type: act_to_form_param_hash is hash [reference] reference;
const type: params_added_hash is hash [reference] act_to_form_param_hash;
const type: setOfCategory is set of category;
const type: setOfString is set of string;
const type: funcparam_data_hash is hash [reference] string;
const type: element_repeat_count_hash is hash [reference] integer;
const type: stringLengthHash is hash [integer] integer;
const type: lengthToStriNumHash is hash [integer] array integer;
const type: profiledFunctionsHash is hash [integer] reference;
var boolean_type_hash: generic_hashCode_declared is boolean_type_hash.EMPTY_HASH;
var boolean_type_hash: generic_cpy_declared is boolean_type_hash.EMPTY_HASH;
var boolean_type_hash: generic_create_declared is boolean_type_hash.EMPTY_HASH;
var boolean_type_hash: generic_destr_declared is boolean_type_hash.EMPTY_HASH;
var boolean_type_hash: generic_cmp_declared is boolean_type_hash.EMPTY_HASH;
var boolean_obj_hash: return_ref_to_value is boolean_obj_hash.EMPTY_HASH;
var boolean_obj_hash: function_declared is boolean_obj_hash.EMPTY_HASH;
var boolean_obj_hash: function_not_declared is boolean_obj_hash.EMPTY_HASH;
var boolean_obj_hash: function_var_declared is boolean_obj_hash.EMPTY_HASH;
var ref_list: dynamic_functions is ref_list.EMPTY;
var interface_hash: interfaceOfType is interface_hash.EMPTY_HASH;
var enum_literal_hash: enum_literal is enum_literal_hash.EMPTY_HASH;
var params_added_hash: params_added is params_added_hash.EMPTY_HASH;
var boolean_obj_hash: definedActualFuncParams is boolean_obj_hash.EMPTY_HASH;
var funcparam_data_hash: funcparam_data is funcparam_data_hash.EMPTY_HASH;
var funcparam_data_hash: funcparam_reference is funcparam_data_hash.EMPTY_HASH;
var element_repeat_count_hash: element_repeat_count is element_repeat_count_hash.EMPTY_HASH;
var profiledFunctionsHash: profiledFunctions is profiledFunctionsHash.value;
const func boolean: isFuncParamData (in reference: currExpr) is
return currExpr in funcparam_data;
const proc: count_declarations (inout expr_type: c_expr) is func
begin
incr(countDeclarations);
c_expr.expr &:= "/* ";
c_expr.expr &:= str(countDeclarations);
c_expr.expr &:= " */\n";
write(OUT, countDeclarations);
write(OUT, "\r");
flush(OUT);
end func;
const proc: process_generic_hashCode_declaration (in reference: function,
in type: object_type, inout expr_type: c_expr) is func
begin
if object_type not in generic_hashCode_declared then
c_expr.expr &:= "static intType generic_hashCode_";
c_expr.expr &:= str(typeNumber(object_type));
c_expr.expr &:= " (const genericType a)\n";
c_expr.expr &:= "{\n";
c_expr.expr &:= "return o_";
create_name(function, c_expr.expr);
c_expr.expr &:= "(((const_rtlObjectType *) &a)->value.";
c_expr.expr &:= raw_type_value(object_type);
c_expr.expr &:= ");\n";
c_expr.expr &:= "}\n\n";
generic_hashCode_declared @:= [object_type] TRUE;
end if;
end func;
const proc: process_generic_cpy_declaration (in type: object_type,
inout expr_type: c_expr) is func
begin
if object_type not in generic_cpy_declared then
process_cpy_declaration(object_type, c_expr);
c_expr.expr &:= "static void generic_cpy_";
c_expr.expr &:= str(typeNumber(object_type));
c_expr.expr &:= " (genericType *a, const genericType b)\n";
c_expr.expr &:= "{\n";
process_cpy_call(object_type,
"((const_rtlObjectType *) a)->value." & raw_type_value(object_type),
"((const_rtlObjectType *) &b)->value." & raw_type_value(object_type),
c_expr.expr);
c_expr.expr &:= ";\n";
c_expr.expr &:= "}\n\n";
generic_cpy_declared @:= [object_type] TRUE;
end if;
end func;
const proc: process_generic_create_declaration (in type: object_type,
inout expr_type: c_expr) is func
begin
if object_type not in generic_create_declared then
process_create_declaration(object_type, c_expr);
c_expr.expr &:= "static genericType generic_create_";
c_expr.expr &:= str(typeNumber(object_type));
c_expr.expr &:= " (const genericType b)\n";
c_expr.expr &:= "{\n";
c_expr.expr &:= "rtlObjectType result;\n";
c_expr.expr &:= "result.value.";
c_expr.expr &:= raw_type_value(object_type);
c_expr.expr &:= "=";
process_create_call(object_type,
"((const_rtlObjectType *) &b)->value." & raw_type_value(object_type),
c_expr.expr);
c_expr.expr &:= ";\n";
c_expr.expr &:= "return result.value.genericValue;\n";
c_expr.expr &:= "}\n\n";
generic_create_declared @:= [object_type] TRUE;
end if;
end func;
const proc: process_generic_destr_declaration (in type: object_type,
inout expr_type: c_expr) is func
begin
if object_type not in generic_destr_declared then
process_destr_declaration(object_type, c_expr);
c_expr.expr &:= "static void generic_destr_";
c_expr.expr &:= str(typeNumber(object_type));
c_expr.expr &:= " (const genericType b)\n";
c_expr.expr &:= "{\n";
process_destr_call(object_type,
"((const_rtlObjectType *) &b)->value." & raw_type_value(object_type),
c_expr.expr);
c_expr.expr &:= "}\n\n";
generic_destr_declared @:= [object_type] TRUE;
end if;
end func;
const proc: process_generic_cmp_declaration (in reference: function,
in type: object_type, inout expr_type: c_expr) is func
begin
if object_type not in generic_cmp_declared then
process_cpy_declaration(object_type, c_expr);
c_expr.expr &:= "static intType generic_cmp_";
c_expr.expr &:= str(typeNumber(object_type));
c_expr.expr &:= " (const genericType a, const genericType b)\n";
c_expr.expr &:= "{\n";
c_expr.expr &:= "return o_";
create_name(function, c_expr.expr);
c_expr.expr &:= "(((const_rtlObjectType *) &a)->value.";
c_expr.expr &:= raw_type_value(object_type);
c_expr.expr &:= ", ((const_rtlObjectType *) &b)->value.";
c_expr.expr &:= raw_type_value(object_type);
c_expr.expr &:= ");\n";
c_expr.expr &:= "}\n\n";
generic_cmp_declared @:= [object_type] TRUE;
end if;
end func;
const proc: process_big_create_call (in bigInteger: number, inout string: expr) is func
begin
if number = 0_ then
incr(countOptimizations);
expr &:= "bigZero(); /* 0_ */\n";
else
expr &:= "bigCreate(";
expr &:= bigIntegerLiteral(number);
expr &:= ");\n";
end if;
end func;
const proc: process_str_create_call (in string: stri, inout string: expr) is func
local
var char: ch is ' ';
var integer: index is 2;
begin
if stri = "" then
incr(countOptimizations);
expr &:= "strEmpty(); /* \"\" */\n";
elsif length(stri) = 1 then
incr(countOptimizations);
expr &:= "chrStr(";
expr &:= charLiteral(stri[1]);
expr &:= "); /* ";
expr &:= literal(stri);
expr &:= " */\n";
else
ch := stri[1];
while index <= length(stri) and ch = stri[index] do
incr(index);
end while;
if index > length(stri) then
incr(countOptimizations);
if ch = '\0;' then
expr &:= "strZero(";
else
expr &:= "strChMult(";
expr &:= charLiteral(ch);
expr &:= ", ";
end if;
expr &:= integerLiteral(length(stri));
expr &:= ");\n";
else
expr &:= "strCreate(";
expr &:= stringLiteral(stri);
expr &:= ");\n";
end if;
end if;
end func;
const proc: getAnyParamToTempAssigns (in expr_type: c_param, inout expr_type: c_expr) is func
begin
if c_param.result_expr <> "" then
c_expr.temp_decls &:= c_param.result_decl;
c_expr.temp_frees &:= c_param.result_free;
c_expr.temp_to_null &:= c_param.result_to_null;
c_expr.temp_assigns &:= c_param.result_intro;
c_expr.temp_assigns &:= c_param.result_expr;
c_expr.temp_assigns &:= c_param.result_finish;
else
c_expr.temp_assigns &:= c_param.expr;
end if;
end func;
const proc: getAnyParamToTempAssigns (in reference: aParam, inout expr_type: c_expr) is func
local
var category: exprCategory is category.value;
var reference: paramValue is NIL;
var string: variableName is "";
var expr_type: c_param is expr_type.value;
begin
prepareAnyParamTemporarys(aParam, c_param, c_expr);
if aParam not in funcparam_data and
not isFunc(getType(aParam)) and
aParam in inlineParam and
inlineParam[aParam][1].paramValue <> NIL then
paramValue := inlineParam[aParam][1].paramValue;
exprCategory := category(paramValue);
if not isVar(paramValue) and
(exprCategory = INTOBJECT or
exprCategory = FLOATOBJECT or
exprCategory = CHAROBJECT or
exprCategory = STRIOBJECT or
exprCategory = BSTRIOBJECT or
exprCategory = POINTLISTOBJECT) then
incr(c_expr.temp_num);
variableName := "tmp_" & str(c_expr.temp_num);
c_expr.temp_decls &:= type_name(getType(paramValue));
c_expr.temp_decls &:= " ";
c_expr.temp_decls &:= variableName;
c_expr.temp_decls &:= ";\n";
c_expr.temp_assigns &:= "(";
c_expr.temp_assigns &:= variableName;
c_expr.temp_assigns &:= "=";
getAnyParamToTempAssigns(c_param, c_expr);
c_expr.temp_assigns &:= ", &";
c_expr.temp_assigns &:= variableName;
c_expr.temp_assigns &:= ")";
else
c_expr.temp_assigns &:= "&(";
getAnyParamToTempAssigns(c_param, c_expr);
c_expr.temp_assigns &:= ")";
end if;
else
c_expr.temp_assigns &:= "&(";
getAnyParamToTempAssigns(c_param, c_expr);
c_expr.temp_assigns &:= ")";
end if;
end func;
const func string: enum_value (in reference: current_object) is func
result
var string: enumValue is "";
local
var type: enum_type is void;
var string: object_name is "";
begin
enum_type := getType(current_object);
if enum_type in typeCategory and typeCategory[enum_type] = BOOLOBJECT then
object_name := str(current_object);
if object_name = "FALSE" then
enumValue := "0/*FALSE*/";
elsif object_name = "TRUE" then
enumValue := "1/*TRUE*/";
end if;
else
enumValue := "/*" & str(current_object) & "*/";
if enum_type in enum_literal and
current_object in enum_literal[enum_type] then
enumValue &:= str(enum_literal[enum_type][current_object]);
else
enumValue &:= str(objNumber(current_object));
end if;
end if;
end func;
const proc: reference_value (in reference: current_value,
inout expr_type: c_expr) is func
begin
if current_value = NIL then
c_expr.expr &:= "NULL";
else
c_expr.expr &:= "&(";
process_expr(current_value, c_expr);
c_expr.expr &:= ")";
end if;
end func;
const proc: ref_list_value (in ref_list: current_value,
inout expr_type: c_expr) is func
local
var reference: element is NIL;
var boolean: first_element is TRUE;
begin
if length(current_value) = 0 then
c_expr.expr &:= "NULL";
else
c_expr.expr &:= "{";
for element range current_value do
if first_element then
first_element := FALSE;
else
c_expr.expr &:= ", ";
end if;
c_expr.expr &:= "&(";
process_expr(element, c_expr);
c_expr.expr &:= ")";
end for;
c_expr.expr &:= "}";
end if;
end func;
const func string: getExprValue (in reference: current_expression, attr string) is func
result
var string: exprValue is "";
local
var reference: evaluated_expression is NIL;
begin
if category(current_expression) = STRIOBJECT then
exprValue := getValue(current_expression, string);
else
evaluated_expression := evaluate(prog, current_expression);
if evaluated_expression <> NIL then
exprValue := getValue(evaluated_expression, string);
end if;
end if;
end func;
const func boolean: isPointerParam (in reference: a_param) is
return category(a_param) = REFPARAMOBJECT and
(not valueIsAtHeap(a_param) or isVar(a_param));
const func boolean: isCopyParam (in reference: a_param) is
return category(a_param) = VALUEPARAMOBJECT and
valueIsAtHeap(a_param);
const func boolean: isInOutParam (in reference: a_param) is
return category(a_param) = REFPARAMOBJECT and isVar(a_param);
const func boolean: canTakeAddress (in reference: an_expression) is func
result
var boolean: canTakeAddress is TRUE;
local
var category: exprCategory is category.value;
var string: action_name is "";
begin
exprCategory := category(an_expression);
if (exprCategory = INTOBJECT or
exprCategory = CHAROBJECT or
exprCategory = CONSTENUMOBJECT or
exprCategory = FLOATOBJECT) and
not isVar(an_expression) then
canTakeAddress := FALSE;
end if;
if isFunc(getType(an_expression)) then
canTakeAddress := FALSE;
end if;
if exprCategory = CALLOBJECT then
if category(getValue(an_expression, ref_list)[1]) = ACTOBJECT then
action_name := str(getValue(getValue(an_expression, ref_list)[1], ACTION));
if action_name = "ARR_IDX" or
action_name = "SCT_SELECT" then
canTakeAddress := TRUE;
end if;
end if;
end if;
end func;
const proc: process_constenumobject (in reference: function, in ref_list: params,
inout expr_type: c_expr) is func
begin
c_expr.expr &:= "/*constenumobject*/";
noop_params(formalParams(function), params, c_expr);
end func;
const func boolean: param_list_okay (in ref_list: formal_params) is func
result
var boolean: okay is TRUE;
local
var reference: obj is NIL;
var category: paramCategory is category.value;
begin
for obj range formal_params do
paramCategory := category(obj);
if paramCategory <> SYMBOLOBJECT and paramCategory <> TYPEOBJECT then
if isFunc(getType(obj)) then
okay := FALSE;
end if;
end if;
end for;
end func;
const func boolean: containsFunctionCall (in reference: function,
in reference: current_expression) is func
result
var boolean: containsCall is FALSE;
local
var category: exprCategory is category.value;
var ref_list: params is ref_list.EMPTY;
var reference: currentFunction is NIL;
var integer: paramNum is 0;
begin
exprCategory := category(current_expression);
if exprCategory = MATCHOBJECT or exprCategory = CALLOBJECT then
params := getValue(current_expression, ref_list);
currentFunction := params[1];
if currentFunction = function then
containsCall := TRUE;
else
paramNum := 2;
while paramNum <= length(params) and not containsCall do
containsCall := containsFunctionCall(function, params[paramNum]);
incr(paramNum);
end while;
end if;
elsif exprCategory = BLOCKOBJECT then
containsCall := current_expression = function;
end if;
end func;
const func boolean: recursiveFunctionCall (in reference: function,
in reference: current_expression) is func
result
var boolean: recursiveCall is FALSE;
local
var reference: obj is NIL;
begin
recursiveCall := containsFunctionCall(function, current_expression);
if not recursiveCall then
for obj range localConsts(function) do
if not recursiveCall and category(obj) = BLOCKOBJECT then
recursiveCall := containsFunctionCall(function, body(obj));
end if;
end for;
end if;
end func;
const func boolean: identical_values (in reference: object1, in reference: object2) is func
result
var boolean: isIdentical is FALSE;
local
var reference: element1 is NIL;
var ref_list: element_list2 is ref_list.EMPTY;
var integer: index2 is 0;
begin
case category(object1) of
when {INTOBJECT}:
isIdentical := getValue(object1, integer) = getValue(object2, integer);
when {BIGINTOBJECT}:
isIdentical := getValue(object1, bigInteger) = getValue(object2, bigInteger);
when {CHAROBJECT}:
isIdentical := getValue(object1, char) = getValue(object2, char);
when {STRIOBJECT}:
isIdentical := getValue(object1, string) = getValue(object2, string);
when {BSTRIOBJECT}:
isIdentical := getValue(object1, bstring) = getValue(object2, bstring);
when {SETOBJECT}:
isIdentical := getValue(object1, bitset) = getValue(object2, bitset);
when {FLOATOBJECT}:
isIdentical := getValue(object1, float) = getValue(object2, float);
when {REFOBJECT}:
isIdentical := getValue(object1, reference) = getValue(object2, reference);
when {FILEOBJECT}:
isIdentical := getValue(object1, clib_file) = getValue(object2, clib_file);
when {POINTLISTOBJECT}:
isIdentical := getValue(object1, pointList) = getValue(object2, pointList);
when {CONSTENUMOBJECT, VARENUMOBJECT}:
isIdentical := getValue(object1, reference) = getValue(object2, reference);
when {ARRAYOBJECT}:
if arrayMinIdx(object1) = arrayMinIdx(object2) and
arrayMaxIdx(object1) = arrayMaxIdx(object2) then
isIdentical := TRUE;
element_list2 := arrayToList(object2);
index2 := 1;
for element1 range arrayToList(object1) until not isIdentical do
isIdentical := identical_values(element1, element_list2[index2]);
incr(index2);
end for;
end if;
when {STRUCTOBJECT}:
isIdentical := TRUE;
element_list2 := structToList(object2);
index2 := 1;
for element1 range structToList(object1) until not isIdentical do
isIdentical := identical_values(element1, element_list2[index2]);
incr(index2);
end for;
end case;
end func;
const func boolean: canUseArrTimes (in type: objectType, in reference: arrayValue,
inout reference: repeatedElement) is func
result
var boolean: canUseArrTimes is FALSE;
local
var type: elementType is void;
var ref_list: array_list is ref_list.EMPTY;
var reference: element is NIL;
var reference: previous_element is NIL;
var integer: repeat_count is 1;
begin
if objectType in array_element then
elementType := array_element[objectType];
if elementType in typeCategory and
typeCategory[elementType] in simpleValueType then
array_list := arrayToList(arrayValue);
for element range array_list do
if previous_element <> NIL then
if identical_values(previous_element, element) then
incr(repeat_count);
end if;
end if;
previous_element := element;
end for;
if repeat_count = arrayLength(arrayValue) then
canUseArrTimes := TRUE;
repeatedElement := array_list[1];
end if;
end if;
end if;
end func;
const proc: assignArrayValue (in type: objectType, in reference: arrayValue,
inout expr_type: c_declaration) is func
local
var integer: arraySize is 0;
var reference: repeatedElement is NIL;
var string: variableName is "";
var string: param_value is "";
begin
arraySize := arrayLength(arrayValue);
if evaluate_const_expr >= 2 and
arrayMinIdx(arrayValue) > arrayMaxIdx(arrayValue) then
if FALSE and inlineFunctions then
incr(c_declaration.temp_num);
variableName := "new_arr" <& c_declaration.temp_num;
c_declaration.temp_decls &:= ";\n";
c_declaration.temp_decls &:= "arrayType ";
c_declaration.temp_decls &:= variableName;
c_declaration.temp_assigns &:= "(";
c_declaration.temp_assigns &:= variableName;
c_declaration.temp_assigns &:= " = (arrayType) malloc(sizeof(struct rtlArrayStruct) - sizeof(rtlObjectType)), (unlikely(";
c_declaration.temp_assigns &:= variableName;
c_declaration.temp_assigns &:= " == NULL) ? ";
c_declaration.temp_assigns &:= "intRaiseError(MEMORY_ERROR) ";
c_declaration.temp_assigns &:= ": 0), ";
c_declaration.temp_assigns &:= variableName;
c_declaration.temp_assigns &:= "->min_position = ";
c_declaration.temp_assigns &:= integerLiteral(arrayMinIdx(arrayValue));
c_declaration.temp_assigns &:= ", ";
c_declaration.temp_assigns &:= variableName;
c_declaration.temp_assigns &:= "->max_position = ";
c_declaration.temp_assigns &:= integerLiteral(arrayMaxIdx(arrayValue));
c_declaration.temp_assigns &:= ", ";
c_declaration.temp_assigns &:= variableName;
c_declaration.temp_assigns &:= ");\n";
else
c_declaration.temp_assigns &:= "arrMalloc(";
c_declaration.temp_assigns &:= integerLiteral(arrayMinIdx(arrayValue));
c_declaration.temp_assigns &:= ", ";
c_declaration.temp_assigns &:= integerLiteral(arrayMaxIdx(arrayValue));
c_declaration.temp_assigns &:= ");\n";
end if;
elsif evaluate_const_expr >= 2 and
canUseArrTimes(objectType, arrayValue, repeatedElement) and
category(repeatedElement) = INTOBJECT then
if getValue(repeatedElement, integer) = 0 then
incr(c_declaration.temp_num);
variableName := "new_arr" <& c_declaration.temp_num;
c_declaration.temp_decls &:= ";\n";
c_declaration.temp_decls &:= "arrayType ";
c_declaration.temp_decls &:= variableName;
c_declaration.temp_assigns &:= "(";
c_declaration.temp_assigns &:= variableName;
if inlineFunctions and
arrayMinIdx(arrayValue) >= -100000000 and arrayMinIdx(arrayValue) <= 100000000 and
arraySize <= 100000000 then
c_declaration.temp_assigns &:= " = (arrayType) malloc(sizeof(struct rtlArrayStruct) + ";
c_declaration.temp_assigns &:= integerLiteral(pred(arraySize));
c_declaration.temp_assigns &:= " * sizeof(rtlObjectType)), (unlikely(";
c_declaration.temp_assigns &:= variableName;
c_declaration.temp_assigns &:= " == NULL) ? ";
c_declaration.temp_assigns &:= "intRaiseError(MEMORY_ERROR) ";
c_declaration.temp_assigns &:= ": 0), ";
c_declaration.temp_assigns &:= variableName;
c_declaration.temp_assigns &:= "->min_position = ";
c_declaration.temp_assigns &:= integerLiteral(arrayMinIdx(arrayValue));
c_declaration.temp_assigns &:= ", ";
c_declaration.temp_assigns &:= variableName;
c_declaration.temp_assigns &:= "->max_position = ";
c_declaration.temp_assigns &:= integerLiteral(arrayMaxIdx(arrayValue));
else
c_declaration.temp_assigns &:= " = arrMalloc(";
c_declaration.temp_assigns &:= integerLiteral(arrayMinIdx(arrayValue));
c_declaration.temp_assigns &:= ", ";
c_declaration.temp_assigns &:= integerLiteral(arrayMaxIdx(arrayValue));
c_declaration.temp_assigns &:= ")";
end if;
c_declaration.temp_assigns &:= ", memset(";
c_declaration.temp_assigns &:= variableName;
c_declaration.temp_assigns &:= "->arr, 0, ";
c_declaration.temp_assigns &:= integerLiteral(arraySize);
c_declaration.temp_assigns &:= " * sizeof(rtlObjectType)), ";
c_declaration.temp_assigns &:= variableName;
c_declaration.temp_assigns &:= ");\n";
else
c_declaration.temp_assigns &:= "arrTimes(";
c_declaration.temp_assigns &:= integerLiteral(arrayMinIdx(arrayValue));
c_declaration.temp_assigns &:= ", ";
c_declaration.temp_assigns &:= integerLiteral(arrayMaxIdx(arrayValue));
c_declaration.temp_assigns &:= ", (genericType)(";
c_declaration.temp_assigns &:= integerLiteral(getValue(repeatedElement, integer));
c_declaration.temp_assigns &:= "));\n";
end if;
else
if arrayValue not in const_table then
const_table @:= [arrayValue] length(const_table);
end if;
process_create_declaration(objectType, global_c_expr);
param_value := "arr[";
param_value &:= str(const_table[arrayValue]);
param_value &:= "]";
process_create_call(objectType,
param_value, c_declaration.temp_assigns);
c_declaration.temp_assigns &:= ";\n";
end if;
end func;
const proc: process_local_declaration (in reference: current_object, in var reference: object_value,
inout expr_type: c_expr) is func
local
var type: objectType is void;
var category: valueCategory is category.value;
var expr_type: c_declaration is expr_type.value;
var expr_type: c_value is expr_type.value;
var string: param_name is "";
var string: param_value is "";
begin
c_declaration.temp_num := c_expr.temp_num;
valueCategory := category(object_value);
objectType := getType(current_object);
if objectType = getType(object_value) and objectType not in typeCategory then
typeCategory @:= [objectType] valueCategory;
end if;
declare_type_if_necessary(objectType, global_c_expr);
c_declaration.temp_decls &:= diagnosticLine(current_object);
c_declaration.temp_decls &:= type_name(objectType);
c_declaration.temp_decls &:= " o_";
create_name(current_object, c_declaration.temp_decls);
if objectType in typeCategory and typeCategory[objectType] = INTERFACEOBJECT then
if valueCategory = INTERFACEOBJECT then
object_value := interfaceToStruct(object_value);
valueCategory := category(object_value);
end if;
if isVar(object_value) then
c_declaration.temp_assigns &:= diagnosticLine(current_object);
c_declaration.temp_assigns &:= "o_";
create_name(current_object, c_declaration.temp_assigns);
c_declaration.temp_assigns &:= "=itfCreate(o_";
create_name(object_value, c_declaration.temp_assigns);
c_declaration.temp_assigns &:= "/* ";
c_declaration.temp_assigns &:= str(valueCategory);
c_declaration.temp_assigns &:= " */);\n";
else
if object_value not in const_table then
const_table @:= [object_value] length(const_table);
end if;
c_declaration.temp_assigns &:= diagnosticLine(current_object);
c_declaration.temp_assigns &:= "o_";
create_name(current_object, c_declaration.temp_assigns);
c_declaration.temp_assigns &:= "=(";
c_declaration.temp_assigns &:= type_name(objectType);
c_declaration.temp_assigns &:= ")(itfCreate(itf[";
c_declaration.temp_assigns &:= str(const_table[object_value]);
c_declaration.temp_assigns &:= "]));\n";
end if;
process_destr_declaration(objectType, global_c_expr);
param_name := "o_";
create_name(current_object, param_name);
process_destr_call(objectType, param_name, c_declaration.temp_frees);
elsif valueCategory = TYPEOBJECT then
c_declaration.temp_decls &:= "=";
c_declaration.temp_decls &:= typeLiteral(getValue(object_value, type));
elsif valueCategory = INTOBJECT then
c_declaration.temp_decls &:= "=";
c_declaration.temp_decls &:= integerLiteral(getValue(object_value, integer));
elsif valueCategory = BIGINTOBJECT then
c_declaration.temp_assigns &:= diagnosticLine(current_object);
c_declaration.temp_assigns &:= "o_";
create_name(current_object, c_declaration.temp_assigns);
c_declaration.temp_assigns &:= "=";
process_big_create_call(getValue(object_value, bigInteger), c_declaration.temp_assigns);
c_declaration.temp_frees &:= "bigDestr(o_";
create_name(current_object, c_declaration.temp_frees);
c_declaration.temp_frees &:= ");\n";
elsif valueCategory = CHAROBJECT then
c_declaration.temp_decls &:= "=";
c_declaration.temp_decls &:= charLiteral(getValue(object_value, char));
elsif valueCategory = FLOATOBJECT then
c_declaration.temp_decls &:= "=";
c_declaration.temp_decls &:= floatLiteral(getValue(object_value, float));
elsif valueCategory = STRIOBJECT then
c_declaration.temp_assigns &:= diagnosticLine(current_object);
c_declaration.temp_assigns &:= "o_";
create_name(current_object, c_declaration.temp_assigns);
c_declaration.temp_assigns &:= "=";
process_str_create_call(getValue(object_value, string), c_declaration.temp_assigns);
c_declaration.temp_frees &:= "strDestr(o_";
create_name(current_object, c_declaration.temp_frees);
c_declaration.temp_frees &:= ");\n";
elsif valueCategory = BSTRIOBJECT then
c_declaration.temp_assigns &:= diagnosticLine(current_object);
c_declaration.temp_assigns &:= "o_";
create_name(current_object, c_declaration.temp_assigns);
c_declaration.temp_assigns &:= "=bstCreate(";
c_declaration.temp_assigns &:= bstriLiteral(getValue(object_value, bstring));
c_declaration.temp_assigns &:= ");\n";
c_declaration.temp_frees &:= "bstDestr(o_";
create_name(current_object, c_declaration.temp_frees);
c_declaration.temp_frees &:= ");\n";
elsif valueCategory = SETOBJECT then
c_declaration.temp_assigns &:= diagnosticLine(current_object);
c_declaration.temp_assigns &:= "o_";
create_name(current_object, c_declaration.temp_assigns);
c_declaration.temp_assigns &:= "=setCreate(";
c_declaration.temp_assigns &:= bitsetLiteral(getValue(object_value, bitset));
c_declaration.temp_assigns &:= ");\n";
c_declaration.temp_frees &:= "setDestr(o_";
create_name(current_object, c_declaration.temp_frees);
c_declaration.temp_frees &:= ");\n";
elsif valueCategory = REFOBJECT then
c_declaration.temp_decls &:= "=";
reference_value(getValue(object_value, reference), c_value);
c_declaration.temp_decls &:= c_value.expr;
elsif valueCategory = REFLISTOBJECT then
c_declaration.temp_decls &:= "=";
ref_list_value(getValue(object_value, ref_list), c_value);
c_declaration.temp_decls &:= c_value.expr;
c_declaration.temp_frees &:= "rflDestr(o_";
create_name(current_object, c_declaration.temp_frees);
c_declaration.temp_frees &:= ");\n";
elsif valueCategory = FILEOBJECT then
c_declaration.temp_decls &:= "=&";
c_declaration.temp_decls &:= lower(literal(getValue(object_value, clib_file)));
c_declaration.temp_decls &:= "FileRecord";
c_declaration.temp_frees &:= "filDestr(o_";
create_name(current_object, c_declaration.temp_frees);
c_declaration.temp_frees &:= ");\n";
elsif valueCategory = SOCKETOBJECT then
c_declaration.temp_decls &:= "=-1";
elsif valueCategory = POLLOBJECT then
c_declaration.temp_assigns &:= diagnosticLine(current_object);
c_declaration.temp_assigns &:= "o_";
create_name(current_object, c_declaration.temp_assigns);
c_declaration.temp_assigns &:= "=polEmpty();\n";
c_declaration.temp_frees &:= "polDestr(o_";
create_name(current_object, c_declaration.temp_frees);
c_declaration.temp_frees &:= ");\n";
elsif valueCategory = ARRAYOBJECT then
c_declaration.temp_assigns &:= diagnosticLine(current_object);
c_declaration.temp_assigns &:= "o_";
create_name(current_object, c_declaration.temp_assigns);
c_declaration.temp_assigns &:= "=";
assignArrayValue(objectType, object_value, c_declaration);
process_destr_declaration(objectType, global_c_expr);
param_name := "o_";
create_name(current_object, param_name);
process_destr_call(objectType, param_name, c_declaration.temp_frees);
elsif valueCategory = STRUCTOBJECT then
if object_value not in const_table then
const_table @:= [object_value] length(const_table);
end if;
process_create_declaration(objectType, global_c_expr);
process_destr_declaration(objectType, global_c_expr);
c_declaration.temp_assigns &:= diagnosticLine(current_object);
c_declaration.temp_assigns &:= "o_";
create_name(current_object, c_declaration.temp_assigns);
c_declaration.temp_assigns &:= "=";
param_value := "sct[";
param_value &:= str(const_table[object_value]);
param_value &:= "]";
process_create_call(objectType,
param_value, c_declaration.temp_assigns);
c_declaration.temp_assigns &:= ";\n";
param_name := "o_";
create_name(current_object, param_name);
process_destr_call(objectType, param_name, c_declaration.temp_frees);
elsif valueCategory = HASHOBJECT then
if length(hashKeysToList(object_value)) = 0 then
process_destr_declaration(objectType, global_c_expr);
incr(countOptimizations);
c_declaration.temp_assigns &:= diagnosticLine(current_object);
c_declaration.temp_assigns &:= "o_";
create_name(current_object, c_declaration.temp_assigns);
c_declaration.temp_assigns &:= "=hshEmpty();\n";
else
if object_value not in const_table then
const_table @:= [object_value] length(const_table);
end if;
process_create_declaration(objectType, global_c_expr);
process_destr_declaration(objectType, global_c_expr);
c_declaration.temp_assigns &:= diagnosticLine(current_object);
c_declaration.temp_assigns &:= "o_";
create_name(current_object, c_declaration.temp_assigns);
c_declaration.temp_assigns &:= "=";
param_value := "hsh[";
param_value &:= str(const_table[object_value]);
param_value &:= "]";
process_create_call(objectType,
param_value, c_declaration.temp_assigns);
c_declaration.temp_assigns &:= ";\n";
end if;
param_name := "o_";
create_name(current_object, param_name);
process_destr_call(objectType, param_name, c_declaration.temp_frees);
elsif valueCategory = INTERFACEOBJECT then
if object_value not in const_table then
const_table @:= [object_value] length(const_table);
end if;
c_declaration.temp_assigns &:= diagnosticLine(current_object);
c_declaration.temp_assigns &:= "o_";
create_name(current_object, c_declaration.temp_assigns);
c_declaration.temp_assigns &:= "=itf[";
c_declaration.temp_assigns &:= str(const_table[object_value]);
c_declaration.temp_assigns &:= "];\n";
process_destr_declaration(objectType, global_c_expr);
param_name := "o_";
create_name(current_object, param_name);
process_destr_call(objectType, param_name, c_declaration.temp_frees);
elsif valueCategory = WINOBJECT then
c_declaration.temp_assigns &:= diagnosticLine(current_object);
c_declaration.temp_assigns &:= "o_";
create_name(current_object, c_declaration.temp_assigns);
c_declaration.temp_assigns &:= "=drwCreate(";
c_declaration.temp_assigns &:= windowLiteral(getValue(object_value, PRIMITIVE_WINDOW));
c_declaration.temp_assigns &:= ");\n";
c_declaration.temp_frees &:= "drwDestr(o_";
create_name(current_object, c_declaration.temp_frees);
c_declaration.temp_frees &:= ");\n";
elsif valueCategory = POINTLISTOBJECT then
c_declaration.temp_assigns &:= diagnosticLine(current_object);
c_declaration.temp_assigns &:= "o_";
create_name(current_object, c_declaration.temp_assigns);
c_declaration.temp_assigns &:= "=bstCreate(";
c_declaration.temp_assigns &:= pointListLiteral(getValue(object_value, pointList));
c_declaration.temp_assigns &:= ");\n";
c_declaration.temp_frees &:= "bstDestr(o_";
create_name(current_object, c_declaration.temp_frees);
c_declaration.temp_frees &:= ");\n";
elsif valueCategory = PROCESSOBJECT then
c_declaration.temp_decls &:= "=NULL";
c_declaration.temp_frees &:= "pcsDestr(o_";
create_name(current_object, c_declaration.temp_frees);
c_declaration.temp_frees &:= ");\n";
elsif valueCategory = PROGOBJECT then
c_declaration.temp_decls &:= "=NULL";
c_declaration.temp_frees &:= "prgDestr(o_";
create_name(current_object, c_declaration.temp_frees);
c_declaration.temp_frees &:= ");\n";
elsif valueCategory = DATABASEOBJECT then
c_declaration.temp_decls &:= "=NULL";
c_declaration.temp_frees &:= "sqlDestrDb(o_";
create_name(current_object, c_declaration.temp_frees);
c_declaration.temp_frees &:= ");\n";
elsif valueCategory = SQLSTMTOBJECT then
c_declaration.temp_decls &:= "=NULL";
c_declaration.temp_frees &:= "sqlDestrStmt(o_";
create_name(current_object, c_declaration.temp_frees);
c_declaration.temp_frees &:= ");\n";
elsif valueCategory = CONSTENUMOBJECT then
c_declaration.temp_decls &:= "=";
c_declaration.temp_decls &:= enum_value(getValue(object_value, reference));
elsif valueCategory = VARENUMOBJECT then
c_declaration.temp_decls &:= "=";
c_declaration.temp_decls &:= enum_value(getValue(object_value, reference));
elsif valueCategory = ENUMLITERALOBJECT then
c_declaration.temp_decls &:= "=o_";
create_name(object_value, c_declaration.temp_decls);
elsif valueCategory = CALLOBJECT then
param_name := "o_";
create_name(current_object, param_name);
c_value.temp_num := c_declaration.temp_num;
getTemporaryToResultExpr(object_value, c_value);
c_declaration.temp_num := c_value.temp_num;
c_expr.temp_decls &:= c_value.temp_decls;
c_expr.temp_assigns &:= c_value.temp_assigns;
c_expr.temp_frees &:= c_value.temp_frees;
c_expr.temp_to_null &:= c_value.temp_to_null;
c_declaration.temp_assigns &:= diagnosticLine(current_object);
c_declaration.temp_assigns &:= param_name;
c_declaration.temp_assigns &:= "=(";
c_declaration.temp_assigns &:= type_name(objectType);
c_declaration.temp_assigns &:= ")(";
c_declaration.temp_assigns &:= c_value.result_expr;
c_declaration.temp_assigns &:= ");\n";
process_destr_declaration(objectType, global_c_expr);
process_destr_call(objectType, param_name, c_declaration.temp_frees);
elsif valueCategory = BLOCKOBJECT then
create_name(object_value, objNumber(object_value), param_name);
c_value.temp_num := c_declaration.temp_num;
processFuncValue(param_name, objectType, object_value, c_value);
c_declaration.temp_num := c_value.temp_num;
c_declaration.temp_decls &:= "=";
c_declaration.temp_decls &:= c_value.expr;
c_expr.temp_decls &:= c_value.temp_decls;
c_expr.temp_assigns &:= c_value.temp_assigns;
c_expr.temp_frees &:= c_value.temp_frees;
c_expr.temp_to_null &:= c_value.temp_to_null;
function_declared @:= [object_value] TRUE;
function_var_declared @:= [current_object] TRUE;
elsif valueCategory = ACTOBJECT then
c_declaration.temp_decls &:= "=NULL";
else
c_declaration.temp_decls &:= "/* ";
c_declaration.temp_decls &:= str(valueCategory);
c_declaration.temp_decls &:= " */";
end if;
c_declaration.temp_decls &:= ";\n";
c_expr.temp_num := c_declaration.temp_num;
c_expr.temp_decls &:= c_declaration.temp_decls;
c_expr.temp_assigns &:= c_declaration.temp_assigns;
c_expr.temp_frees &:= c_declaration.temp_frees;
c_expr.temp_to_null &:= c_declaration.temp_to_null;
end func;
const proc: process_local_var_declaration (in reference: current_object,
inout expr_type: c_expr) is func
local
var ref_list: objects is ref_list.EMPTY;
var reference: obj is NIL;
begin
objects := localVars(current_object);
for obj range objects do
process_local_declaration(obj, getValue(obj, reference), c_expr);
end for;
end func;
const proc: determineDataForActualFuncParam (in reference: current_expression,
inout ref_list: data_list) is func
local
var category: paramCategory is category.value;
var ref_list: params is ref_list.EMPTY;
var reference: aParam is NIL;
begin
paramCategory := category(current_expression);
if paramCategory = MATCHOBJECT or paramCategory = CALLOBJECT then
params := getValue(current_expression, ref_list);
for aParam range params do
determineDataForActualFuncParam(aParam, data_list);
end for;
elsif paramCategory = LOCALVOBJECT or
paramCategory = VALUEPARAMOBJECT or
paramCategory = REFPARAMOBJECT or
paramCategory = RESULTOBJECT then
if current_expression not in data_list then
data_list &:= make_list(current_expression);
end if;
end if;
end func;
const func ref_list: determineDataForActualFuncParam (in reference: current_expression) is func
result
var ref_list: data_list is ref_list.EMPTY;
begin
determineDataForActualFuncParam(current_expression, data_list);
end func;
const proc: defineFunctype (in string: valueName, in reference: actual_param,
in ref_list: data_list, inout expr_type: c_expr) is func
local
var reference: dataItem is NIL;
var string: data_value is "";
begin
c_expr.expr &:= "typedef struct {\n";
c_expr.expr &:= type_name(resultType(getType(actual_param)));
c_expr.expr &:= " (*func) (void *data_";
c_expr.expr &:= valueName;
c_expr.expr &:= ");\n";
c_expr.expr &:= "struct {\n";
for dataItem range data_list do
if not isVar(dataItem) then
c_expr.expr &:= "const ";
if useConstPrefix(dataItem) then
c_expr.expr &:= "const_";
end if;
end if;
c_expr.expr &:= type_name(getType(dataItem));
if isFunc(getType(dataItem)) then
c_expr.expr &:= " data_";
else
c_expr.expr &:= " *data_";
end if;
create_name(dataItem, c_expr.expr);
c_expr.expr &:= ";\n";
if isFunc(getType(dataItem)) then
data_value := "((functype_";
data_value &:= valueName;
data_value &:= " *) data_";
data_value &:= valueName;
data_value &:= ")->data.data_";
create_name(dataItem, data_value);
data_value &:= "->func(((functype_";
data_value &:= valueName;
data_value &:= " *) data_";
data_value &:= valueName;
data_value &:= ")->data.data_";
create_name(dataItem, data_value);
data_value &:= ")";
if getType(dataItem) = proctype then
data_value &:= ";\n";
end if;
else
data_value := "*((functype_";
data_value &:= valueName;
data_value &:= " *) data_";
data_value &:= valueName;
data_value &:= ")->data.data_";
create_name(dataItem, data_value);
end if;
funcparam_data @:= [dataItem] data_value;
data_value := "((functype_";
data_value &:= valueName;
data_value &:= " *) data_";
data_value &:= valueName;
data_value &:= ")->data.data_";
create_name(dataItem, data_value);
funcparam_reference @:= [dataItem] data_value;
end for;
c_expr.expr &:= "} data;\n";
c_expr.expr &:= "} functype_";
c_expr.expr &:= valueName;
c_expr.expr &:= ";\n\n";
end func;
const proc: defineActualFuncParam (in type: resultType, in string: valueName,
in reference: actual_param, in ref_list: data_list, inout expr_type: c_expr) is func
local
var funcparam_data_hash: funcparam_data_backup is funcparam_data_hash.EMPTY_HASH;
var funcparam_data_hash: funcparam_reference_backup is funcparam_data_hash.EMPTY_HASH;
var expr_type: c_func_body is expr_type.value;
begin
funcparam_data_backup := funcparam_data;
funcparam_reference_backup := funcparam_reference;
if data_list <> ref_list.EMPTY then
defineFunctype(valueName, actual_param, data_list, c_expr);
end if;
c_expr.expr &:= "static ";
c_expr.expr &:= type_name(resultType);
c_expr.expr &:= " func_";
c_expr.expr &:= valueName;
c_expr.expr &:= " (void *data_";
c_expr.expr &:= valueName;
c_expr.expr &:= ")\n";
c_expr.expr &:= "{\n";
c_func_body.demand := REQUIRE_RESULT;
if category(actual_param) = BLOCKOBJECT then
process_call_by_name_expr(body(actual_param), c_func_body);
else
process_call_by_name_expr(actual_param, c_func_body);
end if;
appendWithDiagnostic(c_func_body.temp_decls, c_expr);
appendWithDiagnostic(c_func_body.temp_assigns, c_expr);
if getType(actual_param) = proctype then
c_expr.expr &:= c_func_body.expr;
appendWithDiagnostic(c_func_body.temp_frees, c_expr);
else
if c_func_body.temp_frees <> "" then
c_expr.expr &:= type_name(resultType);
c_expr.expr &:= " result=";
else
c_expr.expr &:= diagnosticLine(actual_param);
c_expr.expr &:= "return ";
end if;
if c_func_body.result_expr <> "" then
c_expr.expr &:= c_func_body.result_expr;
elsif valueIsAtHeap(resultType) then
process_create_declaration(resultType, global_c_expr);
process_create_call(resultType, c_func_body.expr, c_expr.expr);
else
c_expr.expr &:= c_func_body.expr;
end if;
c_expr.expr &:= ";\n";
if c_func_body.temp_frees <> "" then
appendWithDiagnostic(c_func_body.temp_frees, c_expr);
c_expr.expr &:= "return result;\n";
end if;
end if;
c_expr.expr &:= "}\n\n";
funcparam_data := funcparam_data_backup;
funcparam_reference := funcparam_reference_backup;
end func;
const proc: defineFuncValue (in string: valueName, in type: genericFuncType,
in ref_list: data_list, inout expr_type: c_expr) is func
local
var reference: dataItem is NIL;
begin
incr(c_expr.temp_num);
if data_list <> ref_list.EMPTY then
c_expr.temp_decls &:= "functype_";
c_expr.temp_decls &:= valueName;
else
c_expr.temp_decls &:= "struct_";
c_expr.temp_decls &:= type_name(genericFuncType);
end if;
c_expr.temp_decls &:= " funcvalue_";
c_expr.temp_decls &:= valueName;
c_expr.temp_decls &:= ";\n\n";
c_expr.temp_assigns &:= "funcvalue_";
c_expr.temp_assigns &:= valueName;
c_expr.temp_assigns &:= ".func = func_";
c_expr.temp_assigns &:= valueName;
c_expr.temp_assigns &:= ";\n";
for dataItem range data_list do
c_expr.temp_assigns &:= "funcvalue_";
c_expr.temp_assigns &:= valueName;
c_expr.temp_assigns &:= ".data.data_";
create_name(dataItem, c_expr.temp_assigns);
c_expr.temp_assigns &:= " = ";
if isFunc(getType(dataItem)) then
c_expr.temp_assigns &:= "o_";
create_name(dataItem, c_expr.temp_assigns);
else
getAnyParamToTempAssigns(dataItem, c_expr);
end if;
c_expr.temp_assigns &:= ";\n";
end for;
end func;
const proc: callActualFuncParam (in string: valueName, in type: genericFuncType,
in ref_list: data_list, inout expr_type: c_expr) is func
begin
if data_list <> ref_list.EMPTY then
c_expr.expr &:= "(";
c_expr.expr &:= type_name(genericFuncType);
c_expr.expr &:= " *)(";
end if;
c_expr.expr &:= "&funcvalue_";
c_expr.expr &:= valueName;
if data_list <> ref_list.EMPTY then
c_expr.expr &:= ")";
end if;
end func;
const proc: processFuncValue (in string: valueName, in type: genericFuncType,
in reference: closure, inout expr_type: c_expr) is func
local
var ref_list: data_list is ref_list.EMPTY;
var expr_type: function_c_expr is expr_type.value;
begin
declare_type_if_necessary(genericFuncType, global_c_expr);
data_list := determineDataForActualFuncParam(closure);
if closure not in definedActualFuncParams then
function_c_expr.currentFile := file(closure);
function_c_expr.currentLine := line(closure);
defineActualFuncParam(resultType(genericFuncType), valueName, closure,
data_list, function_c_expr);
global_c_expr.expr &:= function_c_expr.temp_decls;
global_init.expr &:= function_c_expr.temp_assigns;
global_c_expr.expr &:= function_c_expr.expr;
definedActualFuncParams @:= [closure] TRUE;
end if;
defineFuncValue(valueName, genericFuncType, data_list, c_expr);
if data_list <> ref_list.EMPTY then
c_expr.expr &:= "(";
c_expr.expr &:= type_name(genericFuncType);
c_expr.expr &:= ")(";
end if;
c_expr.expr &:= "&funcvalue_";
c_expr.expr &:= valueName;
if data_list <> ref_list.EMPTY then
c_expr.expr &:= ")";
end if;
end func;
const proc: processFuncParam (in reference: formal_param,
in reference: actual_param, inout expr_type: c_expr) is func
local
var string: valueName is "";
begin
create_name(formal_param, objNumber(actual_param), valueName);
processFuncValue(valueName, getType(formal_param), actual_param, c_expr);
end func;
const proc: checkParameterAliasing (in ref_list: formalParams,
in ref_list: actualParams, in expr_type: c_expr) is func
local
var integer: checkedParamNumber is 0;
var reference: formalParam is NIL;
var reference: checkedActualInOutParam is NIL;
var integer: paramNumber is 0;
var reference: actualParam is NIL;
var bitset: alreadyComplained is {};
begin
for checkedParamNumber range 1 to length(formalParams) do
formalParam := formalParams[checkedParamNumber];
if isInOutParam(formalParam) then
checkedActualInOutParam := actualParams[checkedParamNumber];
for paramNumber range 1 to length(actualParams) do
actualParam := actualParams[paramNumber];
if paramNumber <> checkedParamNumber and
actualParam = checkedActualInOutParam then
if isInOutParam(formalParams[paramNumber]) then
if checkedParamNumber not in alreadyComplained then
error(VARIABLE_USED_FOR_TWO_INOUT_PARAMETERS,
actualParam, formalParam, c_expr);
incl(alreadyComplained, checkedParamNumber);
end if;
elsif category(formalParams[paramNumber]) = REFPARAMOBJECT then
error(VARIABLE_USED_AS_INOUT_AND_REF_PARAMETER,
actualParam, formalParam, formalParams[paramNumber], c_expr);
end if;
end if;
end for;
end if;
end for;
end func;
const proc: call_params (in ref_list: formal_params,
in ref_list: actual_params, inout expr_type: c_expr) is func
local
var integer: number is 0;
var reference: formal_param is NIL;
var reference: actual_param is NIL;
var category: paramCategory is category.value;
var boolean: first_element is TRUE;
var integer: temp_num is 0;
begin
checkParameterAliasing(formal_params, actual_params, c_expr);
for number range 1 to length(actual_params) do
formal_param := formal_params[number];
actual_param := actual_params[number];
paramCategory := category(formal_param);
if paramCategory <> SYMBOLOBJECT then
if paramCategory = TYPEOBJECT then
c_expr.expr &:= "/* attr t_";
c_expr.expr &:= str(typeNumber(getValue(formal_param, type)));
c_expr.expr &:= " ";
c_expr.expr &:= str(getValue(formal_param, type));
c_expr.expr &:= "*/ ";
elsif getType(formal_param) <> voidtype then
if first_element then
first_element := FALSE;
else
c_expr.expr &:= ", ";
end if;
if isPointerParam(formal_param) then
if category(actual_param) = REFPARAMOBJECT then
if actual_param in inlineParam and
inlineParam[actual_param][1].paramNum <> 0 then
c_expr.expr &:= "par_";
c_expr.expr &:= str(inlineParam[actual_param][1].paramNum);
c_expr.expr &:= "_";
end if;
if actual_param in funcparam_reference then
c_expr.expr &:= funcparam_reference[actual_param];
else
c_expr.expr &:= "o_";
create_name(actual_param, c_expr.expr);
end if;
elsif category(actual_param) = MATCHOBJECT then
if getValue(actual_param, ref_list)[1] in function_var_declared then
c_expr.expr &:= "o_";
create_name(getValue(actual_param, ref_list)[1], c_expr.expr);
else
processFuncParam(formal_param, actual_param, c_expr);
end if;
elsif category(actual_param) = BLOCKOBJECT then
if actual_param in function_var_declared then
c_expr.expr &:= "o_";
create_name(actual_param, c_expr.expr);
else
processFuncParam(formal_param, actual_param, c_expr);
end if;
elsif category(actual_param) = LOCALVOBJECT and
actual_param in function_var_declared then
c_expr.expr &:= "o_";
create_name(actual_param, c_expr.expr);
elsif canTakeAddress(actual_param) then
c_expr.expr &:= "&(";
process_expr(actual_param, c_expr);
c_expr.expr &:= ")";
else
c_expr.expr &:= "/* ";
c_expr.expr &:= str(category(actual_param));
c_expr.expr &:= " */";
incr(c_expr.temp_num);
temp_num := c_expr.temp_num;
c_expr.temp_decls &:= type_name(getExprResultType(actual_param));
c_expr.temp_decls &:= " tmp_";
c_expr.temp_decls &:= str(temp_num);
c_expr.temp_decls &:= ";\n";
c_expr.expr &:= "(tmp_";
c_expr.expr &:= str(temp_num);
c_expr.expr &:= "=(";
c_expr.expr &:= type_name(getExprResultType(actual_param));
c_expr.expr &:= ")(";
getAnyParamToExpr(actual_param, c_expr);
c_expr.expr &:= "), &tmp_";
c_expr.expr &:= str(temp_num);
c_expr.expr &:= ")";
end if;
else
getAnyParamToExpr(actual_param, c_expr);
end if;
end if;
end if;
end for;
end func;
const proc: process_prototype_declaration (in reference: current_object,
inout expr_type: c_expr) is forward;
const proc: process_const_func_call (in reference: function,
in ref_list: actual_params, inout expr_type: c_expr) is func
local
var type: function_type is void;
var type: result_type is void;
var ref_list: formal_params is ref_list.EMPTY;
var expr_type: c_params is expr_type.value;
begin
if function not in prototype_declared then
process_prototype_declaration(function, global_c_expr);
prototype_declared @:= [function] TRUE;
end if;
function_type := getType(function);
result_type := resultType(function_type);
formal_params := formalParams(function);
c_params.currentFile := c_expr.currentFile;
c_params.currentLine := c_expr.currentLine;
if valueIsAtHeap(result_type) and
not isVarfunc(function_type) and
function not in return_ref_to_value then
prepare_typed_result(result_type, c_expr);
c_expr.result_expr := "o_";
create_name(function, c_expr.result_expr);
c_expr.result_expr &:= "(";
c_params.temp_num := c_expr.temp_num;
call_params(formal_params, actual_params, c_params);
c_expr.temp_num := c_params.temp_num;
c_expr.temp_decls &:= c_params.temp_decls;
c_expr.temp_assigns &:= c_params.temp_assigns;
c_expr.temp_frees &:= c_params.temp_frees;
c_expr.temp_to_null &:= c_params.temp_to_null;
c_expr.result_expr &:= c_params.expr;
c_expr.result_expr &:= ")";
elsif result_type = voidtype then
c_params.temp_num := c_expr.temp_num;
call_params(formal_params, actual_params, c_params);
c_expr.temp_num := c_params.temp_num;
if c_params.temp_decls <> "" or c_params.temp_assigns <> "" then
setDiagnosticLine(c_expr);
c_expr.expr &:= "{\n";
appendWithDiagnostic(c_params.temp_decls, c_expr);
appendWithDiagnostic(c_params.temp_assigns, c_expr);
end if;
setDiagnosticLine(c_expr);
if isVarfunc(function_type) then
c_expr.expr &:= "*o_";
else
c_expr.expr &:= "o_";
end if;
create_name(function, c_expr.expr);
c_expr.expr &:= "(";
c_expr.expr &:= c_params.expr;
c_expr.expr &:= ")";
c_expr.expr &:= ";\n";
if c_params.temp_decls <> "" or c_params.temp_assigns <> "" then
appendWithDiagnostic(c_params.temp_frees, c_expr);
setDiagnosticLine(c_expr);
c_expr.expr &:= "}\n";
end if;
else
if isVarfunc(function_type) then
c_expr.expr &:= "*o_";
else
c_expr.expr &:= "o_";
end if;
create_name(function, c_expr.expr);
c_expr.expr &:= "(";
call_params(formal_params, actual_params, c_expr);
c_expr.expr &:= ")";
end if;
end func;
const proc: process_func_call (in reference: function,
in ref_list: actual_params, inout expr_type: c_expr) is func
local
var type: result_type is void;
begin
if isVar(function) then
if getType(function) = proctype then
setDiagnosticLine(c_expr);
end if;
result_type := resultType(getType(function));
if valueIsAtHeap(result_type) then
prepare_typed_result(result_type, c_expr);
c_expr.result_expr &:= "o_";
create_name(function, c_expr.result_expr);
c_expr.result_expr &:= "->func(o_";
create_name(function, c_expr.result_expr);
c_expr.result_expr &:= ")";
else
c_expr.expr &:= "o_";
create_name(function, c_expr.expr);
c_expr.expr &:= "->func(o_";
create_name(function, c_expr.expr);
c_expr.expr &:= ")";
if getType(function) = proctype then
c_expr.expr &:= ";\n";
end if;
end if;
else
process_const_func_call(function, actual_params, c_expr);
end if;
end func;
const proc: process_call (in reference: current_expression, inout expr_type: c_expr) is func
local
var ref_list: params is ref_list.EMPTY;
var reference: function is NIL;
var category: functionCategory is category.value;
var reference: obj is NIL;
var boolean: first_element is TRUE;
begin
c_expr.currentFile := file(current_expression);
c_expr.currentLine := line(current_expression);
params := getValue(current_expression, ref_list);
function := params[1];
params := params[2 ..];
functionCategory := category(function);
if functionCategory = ACTOBJECT then
process_action(function, params, c_expr);
elsif functionCategory = BLOCKOBJECT then
if function in function_not_declared or
(function not in prototype_declared and
isFunctionCallingSpecialAction(function)) then
process_inline(function, params, c_expr);
else
process_func_call(function, params, c_expr);
end if;
elsif functionCategory = LOCALVOBJECT then
process_func_call(function, params, c_expr);
elsif functionCategory = CONSTENUMOBJECT then
process_expr(function, c_expr);
elsif functionCategory = REFPARAMOBJECT then
if isFunc(getType(function)) or
isVarfunc(getType(function)) then
if function in inlineParam then
process_inline_param(function, c_expr);
else
if getType(function) = proctype then
setDiagnosticLine(c_expr);
end if;
c_expr.expr &:= "o_";
create_name(function, c_expr.expr);
c_expr.expr &:= "->func(o_";
create_name(function, c_expr.expr);
c_expr.expr &:= ")";
if getType(function) = proctype then
c_expr.expr &:= ";\n";
end if;
end if;
else
process_expr(function, c_expr);
end if;
elsif functionCategory = VALUEPARAMOBJECT or
functionCategory = INTOBJECT or
functionCategory = BIGINTOBJECT or
functionCategory = FLOATOBJECT or
functionCategory = CHAROBJECT or
functionCategory = STRIOBJECT or
functionCategory = BSTRIOBJECT or
functionCategory = ARRAYOBJECT or
functionCategory = HASHOBJECT or
functionCategory = SETOBJECT or
functionCategory = STRUCTOBJECT or
functionCategory = INTERFACEOBJECT or
functionCategory = FILEOBJECT or
functionCategory = POLLOBJECT or
functionCategory = WINOBJECT or
functionCategory = POINTLISTOBJECT or
functionCategory = PROCESSOBJECT or
functionCategory = PROGOBJECT or
functionCategory = DATABASEOBJECT or
functionCategory = SQLSTMTOBJECT or
functionCategory = ENUMLITERALOBJECT or
functionCategory = TYPEOBJECT then
process_expr(function, c_expr);
elsif functionCategory = REFOBJECT then
c_expr.expr &:= "o_";
create_name(function, c_expr.expr);
elsif functionCategory = REFLISTOBJECT then
c_expr.expr &:= "o_";
create_name(function, c_expr.expr);
elsif functionCategory = FORWARDOBJECT then
error(FORWARD_CALLED, current_expression, function);
else
c_expr.expr &:= "/*[ ";
c_expr.expr &:= str(functionCategory);
c_expr.expr &:= " ]*/";
c_expr.expr &:= "o_";
create_name(function, c_expr.expr);
c_expr.expr &:= "(";
for obj range params do
if category(obj) <> SYMBOLOBJECT then
if first_element then
first_element := FALSE;
else
c_expr.expr &:= ", ";
end if;
process_expr(obj, c_expr);
end if;
end for;
c_expr.expr &:= ")";
end if;
end func;
const proc: process_match (in reference: current_expression, inout expr_type: c_expr) is func
local
var ref_list: params is ref_list.EMPTY;
var reference: function is NIL;
var category: functionCategory is category.value;
var reference: obj is NIL;
var boolean: first_element is TRUE;
begin
c_expr.currentFile := file(current_expression);
c_expr.currentLine := line(current_expression);
params := getValue(current_expression, ref_list);
function := params[1];
params := params[2 ..];
functionCategory := category(function);
if functionCategory = ACTOBJECT then
global_c_expr.expr &:= "objRefType ";
global_c_expr.expr &:= lower(str(getValue(function, ACTION)));
global_c_expr.expr &:= " (listType arguments);\n";
c_expr.expr &:= "&";
c_expr.expr &:= lower(str(getValue(function, ACTION)));
elsif functionCategory = BLOCKOBJECT then
c_expr.expr &:= "o_";
create_name(function, c_expr.expr);
else
raise RANGE_ERROR;
c_expr.expr &:= "/*[ ";
c_expr.expr &:= str(functionCategory);
c_expr.expr &:= " ]*/";
c_expr.expr &:= "o_";
create_name(function, c_expr.expr);
c_expr.expr &:= "(";
for obj range params do
if category(obj) <> SYMBOLOBJECT then
if first_element then
first_element := FALSE;
else
c_expr.expr &:= ", ";
end if;
process_expr(obj, c_expr);
end if;
end for;
c_expr.expr &:= ")";
end if;
end func;
const proc: optimize_constant_expressions (inout reference: current_expression,
inout expr_type: c_expr) is func
local
var reference: evaluated_expression is NIL;
begin
if evaluate_const_expr = 3 and isConstantExpr(current_expression) then
block
evaluated_expression := evaluate(prog, current_expression);
if evaluated_expression <> NIL and evaluated_expression <> current_expression then
incr(countEvaluations);
c_expr.expr &:= "/* evaluate ";
if category(getValue(current_expression, ref_list)[1]) = ACTOBJECT then
c_expr.expr &:= str(getValue(getValue(current_expression, ref_list)[1], ACTION));
elsif category(getValue(current_expression, ref_list)[1]) = BLOCKOBJECT then
c_expr.expr &:= "o_";
create_name2(getValue(current_expression, ref_list)[1], c_expr.expr);
end if;
c_expr.expr &:= " */ ";
current_expression := evaluated_expression;
if category(current_expression) = VARENUMOBJECT then
current_expression := getValue(current_expression, reference);
else
setVar(current_expression, FALSE);
end if;
end if;
exception
catch NUMERIC_ERROR: c_expr.expr &:= "/* NUMERIC_ERROR */ ";
catch OVERFLOW_ERROR: c_expr.expr &:= "/* OVERFLOW_ERROR */ ";
catch RANGE_ERROR: c_expr.expr &:= "/* RANGE_ERROR */ ";
catch INDEX_ERROR: c_expr.expr &:= "/* INDEX_ERROR */ ";
catch FILE_ERROR: c_expr.expr &:= "/* FILE_ERROR */ ";
catch DATABASE_ERROR: c_expr.expr &:= "/* DATABASE_ERROR */ ";
end block;
end if;
end func;
const proc: process_expr (in var reference: current_expression, inout expr_type: c_expr) is func
local
var category: exprCategory is category.value;
begin
optimize_constant_expressions(current_expression, c_expr);
exprCategory := category(current_expression);
if exprCategory = MATCHOBJECT then
process_match(current_expression, c_expr);
elsif exprCategory = CALLOBJECT then
process_call(current_expression, c_expr);
elsif exprCategory = BLOCKOBJECT then
c_expr.expr &:= "o_";
create_name(current_expression, c_expr.expr);
if not isVar(current_expression) then
c_expr.expr &:= "()";
if resultType(getType(current_expression)) = voidtype then
c_expr.expr &:= ";\n";
end if;
end if;
elsif exprCategory = ACTOBJECT then
global_c_expr.expr &:= "objRefType ";
global_c_expr.expr &:= lower(str(getValue(current_expression, ACTION)));
global_c_expr.expr &:= " (listType arguments);\n";
c_expr.expr &:= "&";
c_expr.expr &:= lower(str(getValue(current_expression, ACTION)));
elsif exprCategory = LOCALVOBJECT then
if current_expression in funcparam_data then
c_expr.expr &:= funcparam_data[current_expression];
else
c_expr.expr &:= "o_";
create_name(current_expression, c_expr.expr);
end if;
elsif exprCategory = VALUEPARAMOBJECT then
if current_expression in funcparam_data then
c_expr.expr &:= funcparam_data[current_expression];
elsif current_expression in inlineParam and
inlineParam[current_expression][1].paramValue <> NIL then
process_expr(inlineParam[current_expression][1].paramValue, c_expr);
else
if current_expression in inlineParam and
inlineParam[current_expression][1].paramNum <> 0 then
c_expr.expr &:= "par_";
c_expr.expr &:= str(inlineParam[current_expression][1].paramNum);
c_expr.expr &:= "_";
end if;
c_expr.expr &:= "o_";
create_name(current_expression, c_expr.expr);
end if;
elsif exprCategory = REFPARAMOBJECT then
if current_expression in funcparam_data then
c_expr.expr &:= funcparam_data[current_expression];
elsif isFunc(getType(current_expression)) or
isVarfunc(getType(current_expression)) then
if current_expression in inlineParam then
process_inline_param(current_expression, c_expr);
else
if getType(current_expression) = proctype then
setDiagnosticLine(c_expr);
end if;
c_expr.expr &:= "o_";
create_name(current_expression, c_expr.expr);
c_expr.expr &:= "->func(o_";
create_name(current_expression, c_expr.expr);
c_expr.expr &:= ")";
if getType(current_expression) = proctype then
c_expr.expr &:= ";\n";
end if;
end if;
elsif current_expression in inlineParam and
inlineParam[current_expression][1].paramValue <> NIL then
process_expr(inlineParam[current_expression][1].paramValue, c_expr);
else
if isPointerParam(current_expression) then
c_expr.expr &:= "*";
end if;
if current_expression in inlineParam and
inlineParam[current_expression][1].paramNum <> 0 then
c_expr.expr &:= "par_";
c_expr.expr &:= str(inlineParam[current_expression][1].paramNum);
c_expr.expr &:= "_";
end if;
c_expr.expr &:= "o_";
create_name(current_expression, c_expr.expr);
end if;
elsif exprCategory = RESULTOBJECT then
if current_expression in funcparam_data then
c_expr.expr &:= funcparam_data[current_expression];
else
c_expr.expr &:= "o_";
create_name(current_expression, c_expr.expr);
end if;
elsif exprCategory = TYPEOBJECT then
if isVar(current_expression) then
c_expr.expr &:= "o_";
create_name(current_expression, c_expr.expr);
else
c_expr.expr &:= typeLiteral(getValue(current_expression, type));
end if;
elsif exprCategory = INTOBJECT then
if isVar(current_expression) then
c_expr.expr &:= "o_";
create_name(current_expression, c_expr.expr);
else
c_expr.expr &:= integerLiteral(getValue(current_expression, integer));
end if;
elsif exprCategory = BIGINTOBJECT then
if isVar(current_expression) then
c_expr.expr &:= "o_";
create_name(current_expression, c_expr.expr);
else
c_expr.expr &:= bigIntegerLiteral(getValue(current_expression, bigInteger));
end if;
elsif exprCategory = FLOATOBJECT then
if isVar(current_expression) then
c_expr.expr &:= "o_";
create_name(current_expression, c_expr.expr);
else
c_expr.expr &:= floatLiteral(getValue(current_expression, float));
end if;
elsif exprCategory = CHAROBJECT then
if isVar(current_expression) then
c_expr.expr &:= "o_";
create_name(current_expression, c_expr.expr);
else
c_expr.expr &:= charLiteral(getValue(current_expression, char));
end if;
elsif exprCategory = STRIOBJECT then
if isVar(current_expression) then
c_expr.expr &:= "o_";
create_name(current_expression, c_expr.expr);
else
c_expr.expr &:= stringLiteral(getValue(current_expression, string));
end if;
elsif exprCategory = BSTRIOBJECT then
if isVar(current_expression) then
c_expr.expr &:= "o_";
create_name(current_expression, c_expr.expr);
else
c_expr.expr &:= bstriLiteral(getValue(current_expression, bstring));
end if;
elsif exprCategory = SETOBJECT then
if isVar(current_expression) then
c_expr.expr &:= "o_";
create_name(current_expression, c_expr.expr);
else
c_expr.expr &:= "(";
c_expr.expr &:= type_name(getType(current_expression));
c_expr.expr &:= ")(";
c_expr.expr &:= bitsetLiteral(getValue(current_expression, bitset));
c_expr.expr &:= ")";
end if;
elsif exprCategory = REFOBJECT then
if isVar(current_expression) then
c_expr.expr &:= "o_";
create_name(current_expression, c_expr.expr);
else
if getValue(current_expression, reference) = NIL then
c_expr.expr &:= "NULL";
else
c_expr.expr &:= "&(";
process_expr(getValue(current_expression, reference), c_expr);
c_expr.expr &:= ")";
end if;
end if;
elsif exprCategory = REFLISTOBJECT then
c_expr.expr &:= "o_";
create_name(current_expression, c_expr.expr);
elsif exprCategory = ARRAYOBJECT then
if isVar(current_expression) then
c_expr.expr &:= "o_";
create_name(current_expression, c_expr.expr);
else
if current_expression not in const_table then
const_table @:= [current_expression] length(const_table);
end if;
c_expr.expr &:= "arr[";
c_expr.expr &:= str(const_table[current_expression]);
c_expr.expr &:= "]";
end if;
elsif exprCategory = STRUCTOBJECT then
if isVar(current_expression) then
c_expr.expr &:= "o_";
create_name(current_expression, c_expr.expr);
else
if current_expression not in const_table then
const_table @:= [current_expression] length(const_table);
end if;
c_expr.expr &:= "sct[";
c_expr.expr &:= str(const_table[current_expression]);
c_expr.expr &:= "]";
end if;
elsif exprCategory = HASHOBJECT then
if isVar(current_expression) then
c_expr.expr &:= "o_";
create_name(current_expression, c_expr.expr);
else
if current_expression not in const_table then
const_table @:= [current_expression] length(const_table);
end if;
c_expr.expr &:= "hsh[";
c_expr.expr &:= str(const_table[current_expression]);
c_expr.expr &:= "]";
end if;
elsif exprCategory = INTERFACEOBJECT then
if isVar(current_expression) then
c_expr.expr &:= "o_";
create_name(current_expression, c_expr.expr);
else
if current_expression not in const_table then
const_table @:= [current_expression] length(const_table);
end if;
c_expr.expr &:= "itf[";
c_expr.expr &:= str(const_table[current_expression]);
c_expr.expr &:= "]";
end if;
elsif exprCategory = FILEOBJECT then
c_expr.expr &:= "o_";
create_name(current_expression, c_expr.expr);
elsif exprCategory = SOCKETOBJECT then
c_expr.expr &:= "o_";
create_name(current_expression, c_expr.expr);
elsif exprCategory = POLLOBJECT then
c_expr.expr &:= "o_";
create_name(current_expression, c_expr.expr);
elsif exprCategory = WINOBJECT then
if isVar(current_expression) then
c_expr.expr &:= "o_";
create_name(current_expression, c_expr.expr);
else
c_expr.expr &:= windowLiteral(getValue(current_expression, PRIMITIVE_WINDOW));
end if;
elsif exprCategory = POINTLISTOBJECT then
if isVar(current_expression) then
c_expr.expr &:= "o_";
create_name(current_expression, c_expr.expr);
else
c_expr.expr &:= pointListLiteral(getValue(current_expression, pointList));
end if;
elsif exprCategory = PROCESSOBJECT then
if isVar(current_expression) then
c_expr.expr &:= "o_";
create_name(current_expression, c_expr.expr);
else
if getValue(current_expression, process) = process.EMPTY then
c_expr.expr &:= "/*process.EMPTY*/NULL";
else
c_expr.expr &:= "o_";
create_name(current_expression, c_expr.expr);
end if;
end if;
elsif exprCategory = PROGOBJECT then
if isVar(current_expression) then
c_expr.expr &:= "o_";
create_name(current_expression, c_expr.expr);
else
if getValue(current_expression, program) = program.EMPTY then
c_expr.expr &:= "/*program.EMPTY*/NULL";
else
c_expr.expr &:= "o_";
create_name(current_expression, c_expr.expr);
end if;
end if;
elsif exprCategory = DATABASEOBJECT then
if isVar(current_expression) then
c_expr.expr &:= "o_";
create_name(current_expression, c_expr.expr);
else
c_expr.expr &:= "/*database.value*/NULL";
end if;
elsif exprCategory = SQLSTMTOBJECT then
if isVar(current_expression) then
c_expr.expr &:= "o_";
create_name(current_expression, c_expr.expr);
else
c_expr.expr &:= "/*sqlStatement.value*/NULL";
end if;
elsif exprCategory = CONSTENUMOBJECT then
if isVar(current_expression) then
c_expr.expr &:= "o_";
create_name(current_expression, c_expr.expr);
else
c_expr.expr &:= enum_value(getValue(current_expression, reference));
end if;
elsif exprCategory = VARENUMOBJECT then
if current_expression in funcparam_data then
c_expr.expr &:= funcparam_data[current_expression];
else
c_expr.expr &:= "o_";
create_name(current_expression, c_expr.expr);
end if;
elsif exprCategory = ENUMLITERALOBJECT then
if getType(current_expression) = voidtype then
c_expr.expr &:= "/* empty */\n";
else
c_expr.expr &:= "o_";
create_name(current_expression, c_expr.expr);
end if;
elsif exprCategory = EXPROBJECT then
c_expr.expr &:= "o_";
create_name(current_expression, c_expr.expr);
elsif exprCategory = SYMBOLOBJECT then
c_expr.expr &:= "/* SYMBOLOBJECT ";
c_expr.expr &:= str(current_expression);
c_expr.expr &:= " */";
else
c_expr.expr &:= "/* ";
c_expr.expr &:= str(exprCategory);
c_expr.expr &:= " */";
end if;
end func;
const proc: process_call_by_name_expr (in var reference: current_expression, inout expr_type: c_expr) is func
local
var category: exprCategory is category.value;
begin
exprCategory := category(current_expression);
if exprCategory = MATCHOBJECT then
process_call(current_expression, c_expr);
elsif exprCategory = LOCALVOBJECT then
if isFunc(getType(current_expression)) or
isVarfunc(getType(current_expression)) then
process_func_call(current_expression, ref_list.EMPTY, c_expr);
else
process_expr(current_expression, c_expr);
end if;
elsif exprCategory = BLOCKOBJECT then
c_expr.expr &:= "o_";
create_name(current_expression, c_expr.expr);
if not isVar(current_expression) then
c_expr.expr &:= "()";
if resultType(getType(current_expression)) = voidtype then
c_expr.expr &:= ";\n";
end if;
end if;
elsif exprCategory = ACTOBJECT then
c_expr.expr &:= "/* process_call_by_name_expr ACTOBJECT ";
c_expr.expr &:= str(getValue(current_expression, ACTION));
c_expr.expr &:= " */";
process_action(current_expression, ref_list.EMPTY, c_expr);
else
process_expr(current_expression, c_expr);
end if;
end func;
const proc: declare_types_of_params (in ref_list: formal_params, inout expr_type: c_expr) is func
local
var reference: formal_param is NIL;
var category: paramCategory is category.value;
begin
for formal_param range formal_params do
paramCategory := category(formal_param);
if paramCategory <> SYMBOLOBJECT and paramCategory <> TYPEOBJECT then
declare_type_if_necessary(getType(formal_param), c_expr);
end if;
end for;
end func;
const proc: process_param_declaration (in reference: formal_param, inout expr_type: c_expr) is func
local
var type: param_type is void;
var string: param_name is "";
begin
param_type := getType(formal_param);
if isPointerParam(formal_param) then
if isFunc(param_type) or isVarfunc(param_type) then
c_expr.expr &:= type_name(param_type);
c_expr.expr &:= " o_";
create_name(formal_param, c_expr.expr);
else
if not isVar(formal_param) then
c_expr.expr &:= "const ";
end if;
c_expr.expr &:= type_name(param_type);
c_expr.expr &:= " *const o_";
create_name(formal_param, c_expr.expr);
end if;
elsif isCopyParam(formal_param) then
create_name(formal_param, param_name);
c_expr.expr &:= "const ";
if useConstPrefix(formal_param) then
c_expr.expr &:= "const_";
end if;
c_expr.expr &:= type_name(param_type);
c_expr.expr &:= " value_o_";
c_expr.expr &:= param_name;
if not isVar(formal_param) and useConstPrefix(param_type) then
c_expr.temp_decls &:= "const_";
end if;
c_expr.temp_decls &:= type_name(param_type);
c_expr.temp_decls &:= " o_";
c_expr.temp_decls &:= param_name;
c_expr.temp_decls &:= ";\n";
c_expr.temp_assigns &:= "o_";
c_expr.temp_assigns &:= param_name;
c_expr.temp_assigns &:= "=";
process_create_declaration(param_type, global_c_expr);
process_create_call(param_type,
"value_o_" & param_name, c_expr.temp_assigns);
c_expr.temp_assigns &:= ";\n";
process_destr_declaration(param_type, global_c_expr);
process_destr_call(param_type,
"o_" & param_name, c_expr.temp_frees);
else
if not isVar(formal_param) then
c_expr.expr &:= "const ";
if useConstPrefix(formal_param) then
c_expr.expr &:= "const_";
end if;
end if;
c_expr.expr &:= type_name(param_type);
c_expr.expr &:= " o_";
create_name(formal_param, c_expr.expr);
end if;
end func;
const proc: process_param_list_declaration (in ref_list: formal_params, inout expr_type: c_expr) is func
local
var reference: formal_param is NIL;
var category: paramCategory is category.value;
var boolean: first_element is TRUE;
begin
for formal_param range formal_params do
paramCategory := category(formal_param);
if paramCategory <> SYMBOLOBJECT then
if paramCategory = TYPEOBJECT then
c_expr.expr &:= "/* attr t_";
c_expr.expr &:= str(typeNumber(getValue(formal_param, type)));
c_expr.expr &:= " ";
c_expr.expr &:= str(getValue(formal_param, type));
c_expr.expr &:= "*/ ";
elsif getType(formal_param) <> voidtype then
if first_element then
first_element := FALSE;
else
c_expr.expr &:= ", ";
end if;
process_param_declaration(formal_param, c_expr);
end if;
end if;
end for;
if first_element then
c_expr.expr &:= "void";
end if;
end func;
const proc: process_result_declaration (in reference: result_object,
in var reference: result_init, inout expr_type: c_expr) is func
local
var reference: evaluatedExpr is NIL;
begin
if result_object <> NIL then
if evaluate_const_expr >= 2 and isConstant(result_init) then
block
evaluatedExpr := evaluate(prog, result_init);
if evaluatedExpr <> NIL then
incr(countEvaluations);
result_init := evaluatedExpr;
end if;
exception
catch NUMERIC_ERROR: noop;
catch OVERFLOW_ERROR: noop;
catch RANGE_ERROR: noop;
catch INDEX_ERROR: noop;
catch FILE_ERROR: noop;
catch DATABASE_ERROR: noop;
end block;
end if;
process_local_declaration(result_object, result_init, c_expr);
end if;
end func;
const proc: process_return (in reference: result_object,
inout expr_type: c_expr) is func
begin
if result_object <> NIL then
c_expr.expr &:= "return o_";
create_name(result_object, c_expr.expr);
c_expr.expr &:= ";\n";
end if;
end func;
const proc: process_return_value (in reference: function,
in type: result_type, in expr_type: c_func_body,
inout expr_type: c_expr) is func
begin
if isVarfunc(getType(function)) then
c_expr.expr &:= "&(";
if c_func_body.result_expr <> "" then
c_expr.expr &:= c_func_body.result_expr;
else
c_expr.expr &:= c_func_body.expr;
end if;
else
c_expr.expr &:= "(";
if c_func_body.result_expr <> "" then
c_expr.expr &:= c_func_body.result_expr;
else
if function in prototype_declared then
process_create_declaration(result_type, global_c_expr);
process_create_call(result_type, c_func_body.expr, c_expr.expr);
else
if valueIsAtHeap(result_type) then
return_ref_to_value @:= [function] TRUE;
c_expr.expr &:= "/*ref_to_value*/ ";
end if;
c_expr.expr &:= c_func_body.expr;
end if;
end if;
end if;
c_expr.expr &:= ")";
end func;
const proc: process_local_consts (in reference: function,
inout expr_type: c_expr) is forward;
const proc: process_const_func_declaration (in reference: function,
inout expr_type: c_expr) is func
local
var expr_type: c_local_consts is expr_type.value;
var expr_type: c_param_list is expr_type.value;
var expr_type: c_result is expr_type.value;
var expr_type: c_local_vars is expr_type.value;
var expr_type: c_func_body is expr_type.value;
var type: function_type is void;
var type: result_type is void;
var ref_list: param_list is ref_list.EMPTY;
var reference: result_object is NIL;
var reference: result_init is NIL;
begin
function_type := getType(function);
result_type := resultType(function_type);
param_list := formalParams(function);
result_object := resultVar(function);
if param_list_okay(param_list) or
recursiveFunctionCall(function, body(function)) or
result_object <> NIL then
function_declared @:= [function] TRUE;
declare_types_of_params(param_list, global_c_expr);
c_local_consts.currentFile := c_expr.currentFile;
c_local_consts.currentLine := c_expr.currentLine;
process_local_consts(function, c_local_consts);
global_c_expr.expr &:= c_local_consts.temp_decls;
global_init.expr &:= c_local_consts.temp_assigns;
global_c_expr.expr &:= c_local_consts.expr;
c_expr.expr &:= diagnosticLine(function);
c_expr.expr &:= "static ";
c_expr.expr &:= type_name(result_type);
if isVarfunc(getType(function)) then
c_expr.expr &:= " /*varfunc*/ *o_";
else
c_expr.expr &:= " o_";
end if;
create_name(function, c_expr.expr);
c_expr.expr &:= " (";
process_param_list_declaration(param_list, c_param_list);
c_expr.expr &:= c_param_list.expr;
c_expr.expr &:= ")\n";
c_expr.expr &:= "{\n";
if function_type <> proctype and result_object = NIL then
if isFunctionCallingSpecialAction(function) then
write_object_declaration := FALSE;
end if;
c_func_body.demand := REQUIRE_RESULT;
currentProfiledFunction := function;
process_expr(body(function), c_func_body);
if c_param_list.temp_decls <> "" or c_func_body.temp_decls <> "" or
trace_function or profile_function then
c_expr.currentFile := file(body(function));
c_expr.currentLine := line(body(function));
setDiagnosticLine(c_expr);
c_expr.expr &:= type_name(result_type);
if isVarfunc(getType(function)) then
c_expr.expr &:= " *result;\n";
else
c_expr.expr &:= " result;\n";
end if;
appendWithDiagnostic(c_param_list.temp_decls, c_expr);
appendWithDiagnostic(c_func_body.temp_decls, c_expr);
if trace_function then
c_expr.expr &:= "fprintf(";
c_expr.expr &:= trace_output;
c_expr.expr &:= ", \"-> ";
create_name(function, c_expr.expr);
c_expr.expr &:= "\\n\");\n";
if flush_trace_output then
c_expr.expr &:= "fflush(";
c_expr.expr &:= trace_output;
c_expr.expr &:= ");\n";
end if;
end if;
if profile_function then
profiledFunctions @:= [objNumber(function)] function;
c_expr.expr &:= "profile[";
c_expr.expr &:= str(objNumber(function));
c_expr.expr &:= "].count++;\n";
c_expr.expr &:= "if (profile[";
c_expr.expr &:= str(objNumber(function));
c_expr.expr &:= "].depth == 0) {\n";
c_expr.expr &:= " profile[";
c_expr.expr &:= str(objNumber(function));
c_expr.expr &:= "].time -= timMicroSec();\n";
c_expr.expr &:= "}\n";
c_expr.expr &:= "profile[";
c_expr.expr &:= str(objNumber(function));
c_expr.expr &:= "].depth++;\n";
end if;
appendWithDiagnostic(c_param_list.temp_assigns, c_expr);
appendWithDiagnostic(c_func_body.temp_assigns, c_expr);
setDiagnosticLine(c_expr);
c_expr.expr &:= "result=(";
c_expr.expr &:= type_name(result_type);
if isVarfunc(getType(function)) then
c_expr.expr &:= " *";
end if;
c_expr.expr &:= ")(";
process_return_value(function, result_type, c_func_body, c_expr);
c_expr.expr &:= ");\n";
appendWithDiagnostic(c_param_list.temp_frees, c_expr);
appendWithDiagnostic(c_func_body.temp_frees, c_expr);
if profile_function then
c_expr.expr &:= "profile[";
c_expr.expr &:= str(objNumber(function));
c_expr.expr &:= "].depth--;\n";
c_expr.expr &:= "if (profile[";
c_expr.expr &:= str(objNumber(function));
c_expr.expr &:= "].depth == 0) {\n";
c_expr.expr &:= " profile[";
c_expr.expr &:= str(objNumber(function));
c_expr.expr &:= "].time += timMicroSec();\n";
c_expr.expr &:= "}\n";
end if;
if trace_function then
c_expr.expr &:= "fprintf(";
c_expr.expr &:= trace_output;
c_expr.expr &:= ", \"<- ";
create_name(function, c_expr.expr);
c_expr.expr &:= "\\n\");\n";
if flush_trace_output then
c_expr.expr &:= "fflush(";
c_expr.expr &:= trace_output;
c_expr.expr &:= ");\n";
end if;
end if;
setDiagnosticLine(c_expr);
c_expr.expr &:= "return result;\n";
else
c_expr.expr &:= diagnosticLine(body(function));
c_expr.expr &:= "return (";
c_expr.expr &:= type_name(result_type);
if isVarfunc(getType(function)) then
c_expr.expr &:= " *";
end if;
c_expr.expr &:= ")(";
process_return_value(function, result_type, c_func_body, c_expr);
c_expr.expr &:= ");\n";
end if;
else
result_init := resultInitValue(function);
c_result.temp_num := c_expr.temp_num;
process_result_declaration(result_object, result_init, c_result);
c_local_vars.temp_num := c_result.temp_num;
process_local_var_declaration(function, c_local_vars);
c_expr.temp_num := c_local_vars.temp_num;
currentProfiledFunction := function;
process_expr(body(function), c_func_body);
c_expr.currentFile := file(function);
c_expr.currentLine := line(function);
appendWithDiagnostic(c_param_list.temp_decls, c_expr);
c_expr.expr &:= c_result.temp_decls;
c_expr.expr &:= c_local_vars.temp_decls;
appendWithDiagnostic(c_func_body.temp_decls, c_expr);
if trace_function then
c_expr.expr &:= "fprintf(";
c_expr.expr &:= trace_output;
c_expr.expr &:= ", \"-> ";
create_name(function, c_expr.expr);
c_expr.expr &:= "\\n\");\n";
if flush_trace_output then
c_expr.expr &:= "fflush(";
c_expr.expr &:= trace_output;
c_expr.expr &:= ");\n";
end if;
end if;
if profile_function then
profiledFunctions @:= [objNumber(function)] function;
c_expr.expr &:= "profile[";
c_expr.expr &:= str(objNumber(function));
c_expr.expr &:= "].count++;\n";
c_expr.expr &:= "if (profile[";
c_expr.expr &:= str(objNumber(function));
c_expr.expr &:= "].depth == 0) {\n";
c_expr.expr &:= " profile[";
c_expr.expr &:= str(objNumber(function));
c_expr.expr &:= "].time -= timMicroSec();\n";
c_expr.expr &:= "}\n";
c_expr.expr &:= "profile[";
c_expr.expr &:= str(objNumber(function));
c_expr.expr &:= "].depth++;\n";
end if;
appendWithDiagnostic(c_param_list.temp_assigns, c_expr);
c_expr.expr &:= c_result.temp_assigns;
c_expr.expr &:= c_local_vars.temp_assigns;
appendWithDiagnostic(c_func_body.temp_assigns, c_expr);
c_expr.expr &:= c_func_body.expr;
appendWithDiagnostic(c_param_list.temp_frees, c_expr);
appendWithDiagnostic(c_local_vars.temp_frees, c_expr);
appendWithDiagnostic(c_func_body.temp_frees, c_expr);
if profile_function then
c_expr.expr &:= "profile[";
c_expr.expr &:= str(objNumber(function));
c_expr.expr &:= "].depth--;\n";
c_expr.expr &:= "if (profile[";
c_expr.expr &:= str(objNumber(function));
c_expr.expr &:= "].depth == 0) {\n";
c_expr.expr &:= " profile[";
c_expr.expr &:= str(objNumber(function));
c_expr.expr &:= "].time += timMicroSec();\n";
c_expr.expr &:= "}\n";
end if;
if trace_function then
c_expr.expr &:= "fprintf(";
c_expr.expr &:= trace_output;
c_expr.expr &:= ", \"<- ";
create_name(function, c_expr.expr);
c_expr.expr &:= "\\n\");\n";
if flush_trace_output then
c_expr.expr &:= "fflush(";
c_expr.expr &:= trace_output;
c_expr.expr &:= ");\n";
end if;
end if;
process_return(result_object, c_expr);
end if;
c_expr.expr &:= "}\n";
c_expr.expr &:= noDiagnosticLine;
c_expr.expr &:= "\n";
if write_object_declaration then
prototype_declared @:= [function] TRUE;
count_declarations(c_expr);
else
excl(function_declared, function);
function_not_declared @:= [function] TRUE;
c_expr.expr &:= "/* declare inline o_";
create_name2(function, c_expr.expr);
c_expr.expr &:= "*/\n\n";
end if;
else
function_not_declared @:= [function] TRUE;
c_expr.expr &:= "/* declare inline o_";
create_name2(function, c_expr.expr);
c_expr.expr &:= "*/\n\n";
end if;
end func;
const proc: process_library_initialisation (in reference: current_object,
inout expr_type: c_expr) is func
local
var string: libraryName is "";
begin
libraryName := name(prog);
c_expr.expr &:= "void init_";
c_expr.expr &:= libraryName;
c_expr.expr &:= " (void)\n";
c_expr.expr &:= "{\n";
c_expr.expr &:= "init_values();\n";
c_expr.expr &:= "init_globals();\n";
c_expr.expr &:= "}\n";
c_expr.expr &:= "\n";
prototype_declared @:= [current_object] TRUE;
count_declarations(c_expr);
end func;
const proc: declare_exception_name (inout expr_type: c_expr) is func
local
var reference: exceptionRef is NIL;
var type: enumType is void;
var number_element_hash: enumsByIntValue is number_element_hash.value;
var integer: intValueOfEnum is 0;
var reference: enumLiteral is NIL;
begin
exceptionRef := sysVar(prog, "memory_error");
enumType := getType(exceptionRef);
c_expr.expr &:= "static const char *exception_name[] = {\n";
c_expr.expr &:= " \"OKAY_NO_ERROR\",\n";
enumsByIntValue := flip(enum_literal[enumType]);
for intValueOfEnum range sort(keys(enumsByIntValue)) do
enumLiteral := enumsByIntValue[intValueOfEnum][1];
c_expr.expr &:= " ";
c_expr.expr &:= c_literal(str(enumLiteral));
c_expr.expr &:= ",\n";
end for;
c_expr.expr &:= " };\n\n";
end func;
const proc: process_main_declaration (in reference: current_object,
inout expr_type: c_expr) is func
local
var expr_type: c_local_vars is expr_type.value;
var expr_type: c_func_body is expr_type.value;
var string: main_prolog is "";
var string: main_epilog is "";
begin
if category(current_object) = BLOCKOBJECT then
function_declared @:= [current_object] TRUE;
process_local_consts(current_object, c_expr);
c_local_vars.temp_num := c_expr.temp_num;
process_local_var_declaration(current_object, c_local_vars);
currentProfiledFunction := main_object;
c_func_body.temp_num := c_local_vars.temp_num;
process_expr(body(current_object), c_func_body);
c_expr.temp_num := c_func_body.temp_num;
elsif category(current_object) = ACTOBJECT then
if str(getValue(current_object, ACTION)) <> "PRC_NOOP" then
currentProfiledFunction := main_object;
c_func_body.temp_num := c_expr.temp_num;
process_expr(current_object, c_func_body);
c_expr.temp_num := c_func_body.temp_num;
end if;
end if;
declare_exception_name(c_expr);
c_expr.currentFile := file(current_object);
c_expr.currentLine := line(current_object);
if ccConf.USE_WMAIN then
main_prolog := "int wmain (int argc, wchar_t **argv)\n";
elsif ccConf.USE_WINMAIN then
main_prolog := "int WinMain (HINSTANCE hInstance, HINSTANCE hPrevInstance, char *lpCmdLine, int nShowCmd)\n";
elsif ccConf.USE_START_MAIN then
main_prolog := "typedef int (*tp_startMain) (int argc, char **argv);\n";
main_prolog &:= "int executeStartMainOnButtonClick (tp_startMain startMain, int argc, char **argv);\n";
main_prolog &:= "int startMain (int argc, char **argv);\n\n";
main_prolog &:= "int main (int argc, char **argv)\n";
main_prolog &:= "\n";
main_prolog &:= "{\n";
main_prolog &:= " return executeStartMainOnButtonClick(startMain, argc, argv);\n";
main_prolog &:= "}\n\n";
main_prolog &:= "int startMain (int argc, char **argv)\n";
else
main_prolog := "int main (int argc, char **argv)\n";
end if;
main_prolog &:= "\n";
main_prolog &:= "{\n";
main_prolog &:= "int fail_value;\n";
main_prolog &:= "catch_stack_pos = 0;\n";
main_prolog &:= "max_catch_stack = 128;\n";
if trace_function then
main_prolog &:= "fprintf(";
main_prolog &:= trace_output;
main_prolog &:= ", \"-> main\\n\");\n";
if flush_trace_output then
main_prolog &:= "fflush(";
main_prolog &:= trace_output;
main_prolog &:= ");\n";
end if;
end if;
if profile_function then
main_prolog &:= "initProfile();\n";
profiledFunctions @:= [objNumber(main_object)] main_object;
main_prolog &:= "profile[";
main_prolog &:= str(objNumber(main_object));
main_prolog &:= "].count++;\n";
main_prolog &:= "if (profile[";
main_prolog &:= str(objNumber(main_object));
main_prolog &:= "].depth == 0) {\n";
main_prolog &:= " profile[";
main_prolog &:= str(objNumber(main_object));
main_prolog &:= "].time -= timMicroSec();\n";
main_prolog &:= "}\n";
main_prolog &:= "profile[";
main_prolog &:= str(objNumber(main_object));
main_prolog &:= "].depth++;\n";
end if;
main_prolog &:= "catch_stack = (catch_type *)(malloc(max_catch_stack * sizeof(catch_type)));\n";
main_prolog &:= "if ((fail_value = do_setjmp(catch_stack[catch_stack_pos])) == 0) {\n";
main_prolog &:= "setupStack(" <& stack_size <& ");\n";
main_prolog &:= "setupRand();\n";
main_prolog &:= "setupFiles();\n";
if ccConf.USE_WINMAIN then
main_prolog &:= "arg_v = getArgv(0, NULL, &arg_0, &programName, &programPath);\n";
else
main_prolog &:= "arg_v = getArgv(argc, argv, &arg_0, &programName, &programPath);\n";
end if;
main_prolog &:= "setupFloat();\n";
main_prolog &:= "setupBig();\n";
if drawLibraryUsed then
main_prolog &:= "drawInit();\n";
end if;
if compilerLibraryUsed then
main_prolog &:= "init_primitiv();\n";
end if;
main_prolog &:= "init_values();\n";
main_prolog &:= "setupSignalHandlers(1, " <& ord(trace_signal) <& ", " <&
ord(ccConf.OVERFLOW_SIGNAL <> "") <&
", 1, NULL);\n";
main_prolog &:= "init_globals();\n";
main_prolog &:= "{\n";
if ccConf.USE_WINMAIN then
c_expr.expr &:= "typedef struct {\n";
c_expr.expr &:= " int dummy;\n";
c_expr.expr &:= " } HINSTANCE__;\n";
c_expr.expr &:= "typedef HINSTANCE__* HINSTANCE;\n";
c_expr.expr &:= "\n";
end if;
appendWithDiagnostic(main_prolog, c_expr);
c_expr.expr &:= c_local_vars.temp_decls;
appendWithDiagnostic(c_func_body.temp_decls, c_expr);
c_expr.expr &:= c_local_vars.temp_assigns;
appendWithDiagnostic(c_func_body.temp_assigns, c_expr);
c_expr.expr &:= c_func_body.expr;
appendWithDiagnostic(c_local_vars.temp_frees, c_expr);
appendWithDiagnostic(c_func_body.temp_frees, c_expr);
c_expr.expr &:= "}\n";
c_expr.expr &:= global_init.temp_frees;
if profile_function then
main_epilog &:= "profile[";
main_epilog &:= str(objNumber(main_object));
main_epilog &:= "].depth--;\n";
main_epilog &:= "if (profile[";
main_epilog &:= str(objNumber(main_object));
main_epilog &:= "].depth == 0) {\n";
main_epilog &:= " profile[";
main_epilog &:= str(objNumber(main_object));
main_epilog &:= "].time += timMicroSec();\n";
main_epilog &:= "}\n";
main_epilog &:= "{\n";
main_epilog &:= " FILE *profile_file;\n";
main_epilog &:= " int index;\n";
main_epilog &:= " profile_file = fopen(\"profile_out\", \"wb\");\n";
main_epilog &:= " if (profile_file != NULL) {\n";
main_epilog &:= " qsort(profile, profile_size, sizeof(struct profileElement),\n";
main_epilog &:= " cmpProfileElement);\n";
main_epilog &:= " fprintf(profile_file, \"usecs\\tcalls\\tplace\\tname\\n\");\n";
main_epilog &:= " for (index = 0; index < profile_size; index++) {\n";
main_epilog &:= " if (profile[index].count != 0) {\n";
main_epilog &:= " if (profile[index].depth == 0) {\n";
main_epilog &:= " fprintf(profile_file, \"%ld\\t%ld\\t%s(%lu)\\t%s\\n\",\n";
main_epilog &:= " (long) profile[index].time, (long) profile[index].count,\n";
main_epilog &:= " profile[index].file, (long unsigned) profile[index].line,\n";
main_epilog &:= " profile[index].name);\n";
main_epilog &:= " } else {\n";
main_epilog &:= " fprintf(profile_file, \"*%ld\\t%ld\\t%s(%lu)\\t%s\\n\",\n";
main_epilog &:= " (long) (profile[index].time + timMicroSec()), (long) profile[index].count,\n";
main_epilog &:= " profile[index].file, (long unsigned) profile[index].line,\n";
main_epilog &:= " profile[index].name);\n";
main_epilog &:= " }\n";
main_epilog &:= " }\n";
main_epilog &:= " }\n";
main_epilog &:= " fclose(profile_file);\n";
main_epilog &:= " }\n";
main_epilog &:= "}\n";
end if;
if trace_function then
main_epilog &:= "fprintf(";
main_epilog &:= trace_output;
main_epilog &:= ", \"<- main\\n\");\n";
if flush_trace_output then
main_epilog &:= "fflush(";
main_epilog &:= trace_output;
main_epilog &:= ");\n";
end if;
end if;
if ccConf.USE_DO_EXIT then
main_epilog &:= "doExit(0);\n";
end if;
main_epilog &:= "return 0;\n";
main_epilog &:= "} else {\n";
main_epilog &:= " printf(\"\\n*** Uncaught exception \");\n";
main_epilog &:= " if (fail_value >= 0 && fail_value < sizeof(exception_name) / sizeof(char *)) {\n";
main_epilog &:= " printf(\"%s\", exception_name[fail_value]);\n";
main_epilog &:= " } else {\n";
main_epilog &:= " printf(\"%d\", fail_value);\n";
main_epilog &:= " }\n";
main_epilog &:= " printf(\" raised\");\n";
main_epilog &:= " if (error_file != NULL) {\n";
main_epilog &:= " printf(\" at %s(%d)\", error_file, error_line);\n";
main_epilog &:= " }\n";
main_epilog &:= " printf(\"\\n\");\n";
if databaseLibraryUsed then
main_epilog &:= " if (fail_value == 6 /*DATABASE_ERROR*/) {\n";
main_epilog &:= " striType message;\n";
main_epilog &:= " message = sqlErrMessage();\n";
main_epilog &:= " printf(\"\\nMessage from the DATABASE_ERROR exception:\\n\");\n";
if consoleLibraryUsed then
main_epilog &:= " conWrite(message);\n";
else
main_epilog &:= " ut8Write(&stdoutFileRecord, message);\n";
end if;
main_epilog &:= " printf(\"\\n\");\n";
main_epilog &:= " strDestr(message);\n";
main_epilog &:= " }\n";
end if;
if ccConf.USE_DO_EXIT then
main_epilog &:= " doExit(1);\n";
end if;
main_epilog &:= " return 1;\n";
main_epilog &:= "}\n";
main_epilog &:= "}\n";
appendWithDiagnostic(main_epilog, c_expr);
c_expr.expr &:= noDiagnosticLine;
c_expr.expr &:= "\n";
prototype_declared @:= [current_object] TRUE;
count_declarations(c_expr);
end func;
const proc: process_var_func_declaration (in reference: function,
inout expr_type: c_expr) is func
local
var expr_type: c_value is expr_type.value;
var string: valueName is "";
begin
declare_type_if_necessary(getType(function), global_c_expr);
create_name(function, objNumber(function), valueName);
processFuncValue(valueName, getType(function), function, c_value);
c_expr.expr &:= c_value.temp_decls;
global_init.expr &:= diagnosticLine(function);
global_init.expr &:= c_value.temp_assigns;
c_expr.expr &:= type_name(getType(function));
c_expr.expr &:= " o_";
create_name(function, c_expr.expr);
c_expr.expr &:= " = ";
c_expr.expr &:= c_value.expr;
c_expr.expr &:= ";\n\n";
function_declared @:= [function] TRUE;
function_var_declared @:= [function] TRUE;
end func;
const proc: process_func_declaration (in reference: function,
inout expr_type: c_expr) is func
begin
if isVar(function) then
process_var_func_declaration(function, c_expr);
else
process_const_func_declaration(function, c_expr);
end if;
end func;
const proc: process_prototype_declaration (in reference: current_object,
inout expr_type: c_expr) is func
local
var expr_type: c_param_list is expr_type.value;
var type: current_type is void;
var type: result_type is void;
var ref_list: param_list is ref_list.EMPTY;
begin
current_type := getType(current_object);
if isFunc(current_type) or isVarfunc(current_type) then
result_type := resultType(current_type);
param_list := formalParams(current_object);
function_declared @:= [current_object] TRUE;
declare_types_of_params(param_list, global_c_expr);
c_expr.expr &:= "static ";
c_expr.expr &:= type_name(result_type);
if isVarfunc(current_type) then
c_expr.expr &:= " *o_";
else
c_expr.expr &:= " o_";
end if;
create_name(current_object, c_expr.expr);
c_expr.expr &:= " (";
process_param_list_declaration(param_list, c_param_list);
c_expr.expr &:= c_param_list.expr;
c_expr.expr &:= ");\n\n";
else
c_expr.expr &:= "extern ";
c_expr.expr &:= type_name(current_type);
c_expr.expr &:= " o_";
create_name(current_object, c_expr.expr);
c_expr.expr &:= ";\n\n";
end if;
end func;
const proc: process_forward_declaration (in reference: fwd_ref,
inout expr_type: c_expr) is func
local
var reference: function is NIL;
begin
function := getValue(fwd_ref, reference);
if function not in prototype_declared then
process_prototype_declaration(function, c_expr);
prototype_declared @:= [function] TRUE;
end if;
end func;
const proc: process_type_declaration (in reference: current_object,
inout expr_type: c_expr) is func
local
var type: aType is void;
begin
if isVar(current_object) then
c_expr.expr &:= "typeType o_";
create_name(current_object, c_expr.expr);
c_expr.expr &:= ";\n\n";
global_init.expr &:= diagnosticLine(current_object);
global_init.expr &:= "o_";
create_name(current_object, global_init.expr);
global_init.expr &:= "=";
global_init.expr &:= typeLiteral(getValue(current_object, type));
global_init.expr &:= ";\n";
else
aType := getValue(current_object, type);
declare_type_if_necessary(aType, c_expr);
end if;
count_declarations(c_expr);
end func;
const proc: process_int_declaration (in reference: current_object,
inout expr_type: c_expr) is func
local
var ref_list: param_list is ref_list.EMPTY;
begin
if isVar(current_object) then
c_expr.expr &:= "intType o_";
create_name(current_object, c_expr.expr);
c_expr.expr &:= "=";
c_expr.expr &:= integerLiteral(getValue(current_object, integer));
c_expr.expr &:= ";\n\n";
count_declarations(c_expr);
elsif optimizeFixedSizeArrays then
param_list := formalParams(current_object);
if param_list <> ref_list.EMPTY then
if length(param_list) = 2 and
category(param_list[1]) = TYPEOBJECT and
category(param_list[2]) = SYMBOLOBJECT then
case str(param_list[2]) of
when {"minIdx"}: array_minIdx @:= [getValue(param_list[1], type)] getValue(current_object, integer);
when {"maxIdx"}: array_maxIdx @:= [getValue(param_list[1], type)] getValue(current_object, integer);
end case;
end if;
end if;
end if;
end func;
const proc: process_bigint_declaration (in reference: current_object,
inout expr_type: c_expr) is func
begin
if isVar(current_object) then
c_expr.expr &:= "bigIntType o_";
create_name(current_object, c_expr.expr);
c_expr.expr &:= ";\n\n";
global_init.expr &:= diagnosticLine(current_object);
global_init.expr &:= "o_";
create_name(current_object, global_init.expr);
global_init.expr &:= "=";
process_big_create_call(getValue(current_object, bigInteger), global_init.expr);
count_declarations(c_expr);
end if;
end func;
const proc: process_char_declaration (in reference: current_object,
inout expr_type: c_expr) is func
begin
if isVar(current_object) then
c_expr.expr &:= "charType o_";
create_name(current_object, c_expr.expr);
c_expr.expr &:= "=";
c_expr.expr &:= charLiteral(getValue(current_object, char));
c_expr.expr &:= ";\n\n";
count_declarations(c_expr);
end if;
end func;
const proc: process_stri_declaration (in reference: current_object,
inout expr_type: c_expr) is func
begin
if isVar(current_object) then
c_expr.expr &:= "striType o_";
create_name(current_object, c_expr.expr);
c_expr.expr &:= ";\n\n";
global_init.expr &:= diagnosticLine(current_object);
global_init.expr &:= "o_";
create_name(current_object, global_init.expr);
global_init.expr &:= "=";
process_str_create_call(getValue(current_object, string), global_init.expr);
count_declarations(c_expr);
end if;
end func;
const proc: process_bstri_declaration (in reference: current_object,
inout expr_type: c_expr) is func
begin
if isVar(current_object) then
c_expr.expr &:= "bstriType o_";
create_name(current_object, c_expr.expr);
c_expr.expr &:= ";\n\n";
global_init.expr &:= diagnosticLine(current_object);
global_init.expr &:= "o_";
create_name(current_object, global_init.expr);
global_init.expr &:= "=bstCreate(";
global_init.expr &:= bstriLiteral(getValue(current_object, bstring));
global_init.expr &:= ");\n";
count_declarations(c_expr);
end if;
end func;
const proc: process_float_declaration (in reference: current_object,
inout expr_type: c_expr) is func
begin
if isVar(current_object) then
c_expr.expr &:= "floatType o_";
create_name(current_object, c_expr.expr);
c_expr.expr &:= "=";
c_expr.expr &:= floatLiteral(getValue(current_object, float));
c_expr.expr &:= ";\n\n";
count_declarations(c_expr);
end if;
end func;
const proc: action_address (in reference: function, inout expr_type: c_expr) is func
local
var ACTION: current_action is action "PRC_NOOP";
var string: action_name is "";
var type: object_type is void;
begin
current_action := getValue(function, ACTION);
action_name := str(current_action);
if action_name = "ARR_CPY" then
object_type := getType(formalParams(function)[1]);
process_generic_cpy_declaration(object_type, global_c_expr);
c_expr.expr &:= "&generic_cpy_";
c_expr.expr &:= str(typeNumber(object_type));
elsif action_name = "ARR_CREATE" then
object_type := getType(formalParams(function)[1]);
typeCategory @:= [object_type] ARRAYOBJECT;
process_generic_create_declaration(object_type, global_c_expr);
c_expr.expr &:= "&generic_create_";
c_expr.expr &:= str(typeNumber(object_type));
elsif action_name = "ARR_DESTR" then
object_type := getType(formalParams(function)[1]);
process_generic_destr_declaration(object_type, global_c_expr);
c_expr.expr &:= "&generic_destr_";
c_expr.expr &:= str(typeNumber(object_type));
elsif action_name = "BIG_CMP" then
c_expr.expr &:= "&bigCmpGeneric";
elsif action_name = "BIG_CPY" then
c_expr.expr &:= "&bigCpyGeneric";
elsif action_name = "BIG_CREATE" then
c_expr.expr &:= "&bigCreateGeneric";
elsif action_name = "BIG_DESTR" then
c_expr.expr &:= "&bigDestrGeneric";
elsif action_name = "BIG_HASHCODE" then
c_expr.expr &:= "&bigHashCodeGeneric";
elsif action_name = "BIN_CMP" then
c_expr.expr &:= "&uintCmpGeneric";
elsif action_name = "BLN_ORD" then
c_expr.expr &:= "&genericHashCode";
elsif action_name = "BLN_CPY" then
c_expr.expr &:= "&genericCpy";
elsif action_name = "BLN_CREATE" then
c_expr.expr &:= "&genericCreate";
elsif action_name = "BST_CMP" then
c_expr.expr &:= "&bstCmpGeneric";
elsif action_name = "BST_CPY" then
c_expr.expr &:= "&bstCpyGeneric";
elsif action_name = "BST_CREATE" then
c_expr.expr &:= "&bstCreateGeneric";
elsif action_name = "BST_DESTR" then
c_expr.expr &:= "&bstDestrGeneric";
elsif action_name = "BST_HASHCODE" then
c_expr.expr &:= "&bstHashCodeGeneric";
elsif action_name = "CHR_CMP" then
c_expr.expr &:= "&chrCmpGeneric";
elsif action_name = "CHR_CPY" then
c_expr.expr &:= "&genericCpy";
elsif action_name = "CHR_CREATE" then
c_expr.expr &:= "&genericCreate";
elsif action_name = "CHR_HASHCODE" then
c_expr.expr &:= "&genericHashCode";
elsif action_name = "DRW_CMP" then
c_expr.expr &:= "&ptrCmpGeneric";
elsif action_name = "DRW_CPY" then
c_expr.expr &:= "&drwCpyGeneric";
elsif action_name = "DRW_CREATE" then
c_expr.expr &:= "&drwCreateGeneric";
elsif action_name = "DRW_DESTR" then
c_expr.expr &:= "&drwDestrGeneric";
elsif action_name = "DRW_HASHCODE" then
c_expr.expr &:= "&ptrHashCodeGeneric";
elsif action_name = "ENU_CPY" then
c_expr.expr &:= "&genericCpy";
elsif action_name = "ENU_CREATE" then
c_expr.expr &:= "&genericCreate";
elsif action_name = "FIL_CPY" then
c_expr.expr &:= "&filCpyGeneric";
elsif action_name = "FIL_CREATE" then
c_expr.expr &:= "&filCreateGeneric";
elsif action_name = "FIL_DESTR" then
c_expr.expr &:= "&filDestrGeneric";
elsif action_name = "FLT_CMP" then
c_expr.expr &:= "&fltCmpGeneric";
elsif action_name = "FLT_CPY" then
c_expr.expr &:= "&fltCpyGeneric";
elsif action_name = "FLT_CREATE" then
c_expr.expr &:= "&genericCreate";
elsif action_name = "FLT_HASHCODE" then
c_expr.expr &:= "&genericHashCode";
elsif action_name = "GEN_DESTR" then
c_expr.expr &:= "&genericDestr";
elsif action_name = "INT_CMP" then
c_expr.expr &:= "&intCmpGeneric";
elsif action_name = "INT_CPY" then
c_expr.expr &:= "&genericCpy";
elsif action_name = "INT_CREATE" then
c_expr.expr &:= "&genericCreate";
elsif action_name = "INT_HASHCODE" then
c_expr.expr &:= "&genericHashCode";
elsif action_name = "ITF_CMP" then
c_expr.expr &:= "&ptrCmpGeneric";
elsif action_name = "ITF_CPY" then
object_type := getType(formalParams(function)[1]);
process_generic_cpy_declaration(object_type, global_c_expr);
c_expr.expr &:= "&generic_cpy_";
c_expr.expr &:= str(typeNumber(object_type));
elsif action_name = "ITF_CREATE" then
c_expr.expr &:= "&itfCreateGeneric";
elsif action_name = "ITF_DESTR" then
object_type := getType(formalParams(function)[1]);
process_generic_destr_declaration(object_type, global_c_expr);
c_expr.expr &:= "&generic_destr_";
c_expr.expr &:= str(typeNumber(object_type));
elsif action_name = "ITF_HASHCODE" then
c_expr.expr &:= "&ptrHashCodeGeneric";
elsif action_name = "PCS_CMP" then
c_expr.expr &:= "&pcsCmpGeneric";
elsif action_name = "PCS_CPY" then
c_expr.expr &:= "&pcsCpyGeneric";
elsif action_name = "PCS_CREATE" then
c_expr.expr &:= "&pcsCreateGeneric";
elsif action_name = "PCS_DESTR" then
c_expr.expr &:= "&pcsDestrGeneric";
elsif action_name = "PCS_HASHCODE" then
c_expr.expr &:= "&pcsHashCodeGeneric";
elsif action_name = "PLT_CMP" then
c_expr.expr &:= "&bstCmpGeneric";
elsif action_name = "PLT_CPY" then
c_expr.expr &:= "&bstCpyGeneric";
elsif action_name = "PLT_CREATE" then
c_expr.expr &:= "&bstCreateGeneric";
elsif action_name = "PLT_DESTR" then
c_expr.expr &:= "&bstDestrGeneric";
elsif action_name = "PLT_HASHCODE" then
c_expr.expr &:= "&bstHashCodeGeneric";
elsif action_name = "PRC_NOOP" then
c_expr.expr &:= "&prcNoop";
elsif action_name = "REF_CMP" then
c_expr.expr &:= "&ptrCmpGeneric";
elsif action_name = "REF_CPY" then
c_expr.expr &:= "&ptrCpyGeneric";
elsif action_name = "REF_CREATE" then
c_expr.expr &:= "&ptrCreateGeneric";
elsif action_name = "REF_HASHCODE" then
c_expr.expr &:= "&ptrHashCodeGeneric";
elsif action_name = "RFL_CMP" then
c_expr.expr &:= "&rflCmpGeneric";
elsif action_name = "RFL_CPY" then
c_expr.expr &:= "&rflCpyGeneric";
elsif action_name = "RFL_CREATE" then
c_expr.expr &:= "&rflCreateGeneric";
elsif action_name = "RFL_DESTR" then
c_expr.expr &:= "&rflDestrGeneric";
elsif action_name = "SCT_CPY" then
object_type := getType(formalParams(function)[1]);
process_generic_cpy_declaration(object_type, global_c_expr);
c_expr.expr &:= "&generic_cpy_";
c_expr.expr &:= str(typeNumber(object_type));
elsif action_name = "SCT_CREATE" then
object_type := getType(formalParams(function)[1]);
typeCategory @:= [object_type] STRUCTOBJECT;
process_generic_create_declaration(object_type, global_c_expr);
c_expr.expr &:= "&generic_create_";
c_expr.expr &:= str(typeNumber(object_type));
elsif action_name = "SCT_DESTR" then
object_type := getType(formalParams(function)[1]);
process_generic_destr_declaration(object_type, global_c_expr);
c_expr.expr &:= "&generic_destr_";
c_expr.expr &:= str(typeNumber(object_type));
elsif action_name = "SET_CMP" then
c_expr.expr &:= "&setCmpGeneric";
elsif action_name = "SET_CPY" then
c_expr.expr &:= "&setCpyGeneric";
elsif action_name = "SET_CREATE" then
c_expr.expr &:= "&setCreateGeneric";
elsif action_name = "SET_DESTR" then
c_expr.expr &:= "&setDestrGeneric";
elsif action_name = "SET_HASHCODE" then
c_expr.expr &:= "&setHashCodeGeneric";
elsif action_name = "SQL_CMP_DB" then
c_expr.expr &:= "&ptrCmpGeneric";
elsif action_name = "SQL_CPY_DB" then
c_expr.expr &:= "&sqlCpyDbGeneric";
elsif action_name = "SQL_CREATE_DB" then
c_expr.expr &:= "&sqlCreateDbGeneric";
elsif action_name = "SQL_DESTR_DB" then
c_expr.expr &:= "&sqlDestrDbGeneric";
elsif action_name = "SQL_CMP_STMT" then
c_expr.expr &:= "&ptrCmpGeneric";
elsif action_name = "SQL_CPY_STMT" then
c_expr.expr &:= "&sqlCpyStmtGeneric";
elsif action_name = "SQL_CREATE_STMT" then
c_expr.expr &:= "&sqlCreateStmtGeneric";
elsif action_name = "SQL_DESTR_STMT" then
c_expr.expr &:= "&sqlDestrStmtGeneric";
elsif action_name = "STR_CMP" then
c_expr.expr &:= "&strCmpGeneric";
elsif action_name = "STR_CPY" then
c_expr.expr &:= "&strCpyGeneric";
elsif action_name = "STR_CREATE" then
c_expr.expr &:= "&strCreateGeneric";
elsif action_name = "STR_DESTR" then
c_expr.expr &:= "&strDestrGeneric";
elsif action_name = "STR_HASHCODE" then
c_expr.expr &:= "&strHashCodeGeneric";
elsif action_name = "TYP_CMP" then
c_expr.expr &:= "&typCmpGeneric";
elsif action_name = "TYP_CPY" then
c_expr.expr &:= "&ptrCpyGeneric";
elsif action_name = "TYP_CREATE" then
c_expr.expr &:= "&ptrCreateGeneric";
elsif action_name = "TYP_DESTR" then
c_expr.expr &:= "&genericDestr";
elsif action_name = "TYP_HASHCODE" then
c_expr.expr &:= "&ptrHashCodeGeneric";
else
c_expr.expr &:= "NULL /* ACTOBJECT { ";
c_expr.expr &:= action_name;
c_expr.expr &:= " }*/";
end if;
end func;
const proc: block_address (in reference: function, inout expr_type: c_expr) is func
local
var ref_list: formal_params is ref_list.EMPTY;
var reference: formal_param is NIL;
var type: object_type is void;
var boolean: address_written is FALSE;
begin
formal_params := formalParams(function);
if length(formal_params) = 2 and category(formal_params[2]) = SYMBOLOBJECT and
str(formal_params[2]) = "hashCode" then
formal_param := formal_params[1];
object_type := getType(formal_param);
process_generic_hashCode_declaration(function, object_type, global_c_expr);
c_expr.expr &:= "&generic_hashCode_";
c_expr.expr &:= str(typeNumber(object_type));
address_written := TRUE;
elsif length(formal_params) = 3 and category(formal_params[2]) = SYMBOLOBJECT and
str(formal_params[2]) = ":=" then
formal_param := formal_params[1];
object_type := getType(formal_param);
process_generic_cpy_declaration(object_type, global_c_expr);
c_expr.expr &:= "&generic_cpy_";
c_expr.expr &:= str(typeNumber(object_type));
address_written := TRUE;
elsif length(formal_params) = 3 and category(formal_params[2]) = SYMBOLOBJECT and
str(formal_params[2]) = "::=" then
formal_param := formal_params[1];
object_type := getType(formal_param);
process_generic_create_declaration(object_type, global_c_expr);
c_expr.expr &:= "&generic_create_";
c_expr.expr &:= str(typeNumber(object_type));
address_written := TRUE;
elsif length(formal_params) = 2 and category(formal_params[2]) = SYMBOLOBJECT and
str(formal_params[2]) = "destroy" then
formal_param := formal_params[1];
object_type := getType(formal_param);
process_generic_destr_declaration(object_type, global_c_expr);
c_expr.expr &:= "&generic_destr_";
c_expr.expr &:= str(typeNumber(object_type));
address_written := TRUE;
elsif length(formal_params) = 3 and category(formal_params[3]) = SYMBOLOBJECT and
str(formal_params[3]) = "compare" then
formal_param := formal_params[1];
object_type := getType(formal_param);
process_generic_cmp_declaration(function, object_type, global_c_expr);
c_expr.expr &:= "&generic_cmp_";
c_expr.expr &:= str(typeNumber(object_type));
address_written := TRUE;
end if;
if not address_written then
c_expr.expr &:= "&o_";
create_name(function, c_expr.expr);
end if;
end func;
const proc: object_address (in reference: curr_expr, inout expr_type: c_expr) is func
local
var category: exprCategory is category.value;
begin
if curr_expr = NIL then
c_expr.expr &:= "NULL";
else
exprCategory := category(curr_expr);
if exprCategory = ACTOBJECT then
action_address(curr_expr, c_expr);
elsif exprCategory = BLOCKOBJECT then
block_address(curr_expr, c_expr);
else
c_expr.expr &:= "/* ";
c_expr.expr &:= str(exprCategory);
c_expr.expr &:= " */";
block
c_expr.expr &:= "&(";
process_expr(curr_expr, c_expr);
c_expr.expr &:= ")";
exception
catch RANGE_ERROR:
c_expr.expr &:= "/*RANGE_ERROR*/";
writeln("] ");
TRACE(curr_expr);
writeln;
end block;
end if;
end if;
end func;
const proc: process_reference_declaration (in reference: current_object,
inout expr_type: c_expr) is func
begin
c_expr.expr &:= "/* ";
c_expr.expr &:= type_name2(getType(current_object));
c_expr.expr &:= " */ ";
if useFunctype(current_object) then
c_expr.expr &:= "intfunctype o_";
else
c_expr.expr &:= "objRefType o_";
end if;
create_name(current_object, c_expr.expr);
c_expr.expr &:= "=";
if useFunctype(current_object) then
c_expr.expr &:= "(intfunctype)(";
else
c_expr.expr &:= "(objRefType)(";
end if;
object_address(getValue(current_object, reference), c_expr);
c_expr.expr &:= ");\n\n";
function_pointer_declared @:= [current_object] TRUE;
count_declarations(c_expr);
end func;
const proc: process_ref_list_declaration (in reference: current_object,
inout expr_type: c_expr) is func
local
var ref_list: refListValue is ref_list.EMPTY;
var integer: index is 0;
begin
refListValue := getValue(current_object, ref_list);
for index range length(refListValue) downto 1 do
c_expr.expr &:= "struct listStruct rec_";
c_expr.expr &:= str(objNumber(current_object));
c_expr.expr &:= "_";
c_expr.expr &:= str(index);
c_expr.expr &:= "={";
if index = length(refListValue) then
c_expr.expr &:= "NULL";
else
c_expr.expr &:= "&rec_";
c_expr.expr &:= str(objNumber(current_object));
c_expr.expr &:= "_";
c_expr.expr &:= str(succ(index));
end if;
c_expr.expr &:= ", (objRefType) &(";
process_expr(refListValue[index], c_expr);
c_expr.expr &:= ")};\n";
end for;
c_expr.expr &:= "\n";
c_expr.expr &:= type_name(getType(current_object));
c_expr.expr &:= " o_";
create_name(current_object, c_expr.expr);
c_expr.expr &:= "=";
if length(refListValue) = 0 then
c_expr.expr &:= "NULL";
else
c_expr.expr &:= "&rec_";
c_expr.expr &:= str(objNumber(current_object));
c_expr.expr &:= "_1";
end if;
c_expr.expr &:= ";\n\n";
count_declarations(c_expr);
end func;
const proc: process_file_declaration (in reference: current_object,
inout expr_type: c_expr) is func
begin
c_expr.expr &:= "fileType o_";
create_name(current_object, c_expr.expr);
c_expr.expr &:= "=&";
c_expr.expr &:= lower(literal(getValue(current_object, clib_file)));
c_expr.expr &:= "FileRecord;\n\n";
count_declarations(c_expr);
end func;
const proc: process_socket_declaration (in reference: current_object,
inout expr_type: c_expr) is func
begin
c_expr.expr &:= "socketType o_";
create_name(current_object, c_expr.expr);
c_expr.expr &:= " = (socketType) -1;\n\n";
count_declarations(c_expr);
end func;
const proc: process_poll_declaration (in reference: current_object,
inout expr_type: c_expr) is func
begin
c_expr.expr &:= "pollType o_";
create_name(current_object, c_expr.expr);
c_expr.expr &:= ";\n\n";
global_init.expr &:= diagnosticLine(current_object);
global_init.expr &:= "o_";
create_name(current_object, global_init.expr);
global_init.expr &:= "=polEmpty();\n";
count_declarations(c_expr);
end func;
const proc: process_array_declaration (in reference: current_object,
inout expr_type: c_expr) is func
local
var string: param_value is "";
begin
typeCategory @:= [getType(current_object)] ARRAYOBJECT;
if isVar(current_object) then
c_expr.expr &:= type_name(getType(current_object));
c_expr.expr &:= " o_";
create_name(current_object, c_expr.expr);
c_expr.expr &:= ";\n\n";
if current_object not in const_table then
const_table @:= [current_object] length(const_table);
end if;
global_init.expr &:= diagnosticLine(current_object);
global_init.expr &:= "o_";
create_name(current_object, global_init.expr);
global_init.expr &:= "=";
param_value := "(";
param_value &:= type_name(getType(current_object));
param_value &:= ")(arr[";
param_value &:= str(const_table[current_object]);
param_value &:= "])";
process_create_declaration(getType(current_object), global_c_expr);
process_create_call(getType(current_object),
param_value, global_init.expr);
global_init.expr &:= ";\n";
count_declarations(c_expr);
end if;
end func;
const proc: process_hash_declaration (in reference: current_object,
inout expr_type: c_expr) is func
local
var string: param_value is "";
begin
typeCategory @:= [getType(current_object)] HASHOBJECT;
c_expr.expr &:= type_name(getType(current_object));
c_expr.expr &:= " o_";
create_name(current_object, c_expr.expr);
c_expr.expr &:= ";\n\n";
if current_object not in const_table then
const_table @:= [current_object] length(const_table);
end if;
global_init.expr &:= diagnosticLine(current_object);
global_init.expr &:= "o_";
create_name(current_object, global_init.expr);
global_init.expr &:= "=";
param_value := "(";
param_value &:= type_name(getType(current_object));
param_value &:= ")(hsh[";
param_value &:= str(const_table[current_object]);
param_value &:= "])";
if isVar(current_object) then
process_create_declaration(getType(current_object), global_c_expr);
process_create_call(getType(current_object),
param_value, global_init.expr);
else
global_init.expr &:= param_value;
end if;
global_init.expr &:= ";\n";
count_declarations(c_expr);
end func;
const proc: process_set_declaration (in reference: current_object,
inout expr_type: c_expr) is func
begin
if isVar(current_object) then
c_expr.expr &:= type_name(getType(current_object));
c_expr.expr &:= " o_";
create_name(current_object, c_expr.expr);
c_expr.expr &:= ";\n\n";
global_init.expr &:= diagnosticLine(current_object);
global_init.expr &:= "o_";
create_name(current_object, global_init.expr);
global_init.expr &:= "=setCreate(";
global_init.expr &:= bitsetLiteral(getValue(current_object, bitset));
global_init.expr &:= ");\n";
count_declarations(c_expr);
end if;
end func;
const proc: process_struct_declaration (in reference: current_object,
inout expr_type: c_expr) is func
local
var string: param_value is "";
var string: init_expr is "";
begin
declare_type_if_necessary(getType(current_object), c_expr);
c_expr.expr &:= type_name(getType(current_object));
c_expr.expr &:= " o_";
create_name(current_object, c_expr.expr);
c_expr.expr &:= ";\n\n";
if current_object not in const_table then
const_table @:= [current_object] length(const_table);
end if;
init_expr &:= diagnosticLine(current_object);
init_expr &:= "o_";
create_name(current_object, init_expr);
init_expr &:= "=";
param_value := "(";
param_value &:= type_name(getType(current_object));
param_value &:= ")(sct[";
param_value &:= str(const_table[current_object]);
param_value &:= "])";
if isVar(current_object) then
process_create_declaration(getType(current_object), global_c_expr);
process_create_call(getType(current_object),
param_value, init_expr);
else
init_expr &:= param_value;
end if;
init_expr &:= ";\n";
if current_object in globalInitalisations then
globalInitalisations @:= [current_object] globalInitalisations[current_object] & init_expr;
else
globalInitalisations @:= [current_object] init_expr;
end if;
count_declarations(c_expr);
end func;
const proc: process_interface_declaration (in reference: current_object,
inout expr_type: c_expr) is func
begin
c_expr.expr &:= type_name(getType(current_object));
c_expr.expr &:= " o_";
create_name(current_object, c_expr.expr);
c_expr.expr &:= ";\n\n";
if current_object not in const_table then
const_table @:= [current_object] length(const_table);
end if;
global_init.expr &:= diagnosticLine(current_object);
global_init.expr &:= "o_";
create_name(current_object, global_init.expr);
global_init.expr &:= "=(";
global_init.expr &:= type_name(getType(current_object));
global_init.expr &:= ")(itfCreate(itf[";
global_init.expr &:= str(const_table[current_object]);
global_init.expr &:= "]));\n";
count_declarations(c_expr);
end func;
const proc: process_win_declaration (in reference: current_object,
inout expr_type: c_expr) is func
begin
if isVar(current_object) then
c_expr.expr &:= "winType o_";
create_name(current_object, c_expr.expr);
c_expr.expr &:= ";\n\n";
global_init.expr &:= diagnosticLine(current_object);
global_init.expr &:= "o_";
create_name(current_object, global_init.expr);
global_init.expr &:= "=drwCreate(";
global_init.expr &:= windowLiteral(getValue(current_object, PRIMITIVE_WINDOW));
global_init.expr &:= ");\n";
count_declarations(c_expr);
end if;
end func;
const proc: process_plist_declaration (in reference: current_object,
inout expr_type: c_expr) is func
begin
if isVar(current_object) then
c_expr.expr &:= "bstriType o_";
create_name(current_object, c_expr.expr);
c_expr.expr &:= ";\n\n";
global_init.expr &:= diagnosticLine(current_object);
global_init.expr &:= "o_";
create_name(current_object, global_init.expr);
global_init.expr &:= "=bstCreate(";
global_init.expr &:= pointListLiteral(getValue(current_object, pointList));
global_init.expr &:= ");\n";
count_declarations(c_expr);
end if;
end func;
const proc: process_process_declaration (in reference: current_object,
inout expr_type: c_expr) is func
begin
if isVar(current_object) then
c_expr.expr &:= "processType o_";
create_name(current_object, c_expr.expr);
c_expr.expr &:= "=NULL;\n\n";
count_declarations(c_expr);
end if;
end func;
const proc: process_prog_declaration (in reference: current_object,
inout expr_type: c_expr) is func
begin
if isVar(current_object) then
c_expr.expr &:= "progType o_";
create_name(current_object, c_expr.expr);
c_expr.expr &:= "=NULL;\n\n";
count_declarations(c_expr);
end if;
end func;
const proc: process_enum_declaration (in reference: current_object,
inout expr_type: c_expr) is func
begin
if isVar(current_object) or not isFunc(getType(current_object)) then
if getType(current_object) = voidtype then
c_expr.expr &:= "/* do not declare void variable or constant o_";
create_name2(current_object, c_expr.expr);
c_expr.expr &:= " */\n\n";
else
if not isVar(current_object) then
c_expr.expr &:= "const ";
end if;
declare_type_if_necessary(getType(current_object), c_expr);
c_expr.expr &:= type_name(getType(current_object));
c_expr.expr &:= " o_";
create_name(current_object, c_expr.expr);
c_expr.expr &:= "=";
c_expr.expr &:= enum_value(getValue(current_object, reference));
c_expr.expr &:= ";\n\n";
end if;
end if;
count_declarations(c_expr);
end func;
const proc: process_enum_literal_declaration (in reference: current_object,
inout expr_type: c_expr) is func
local
var type: enum_type is void;
begin
enum_type := getType(current_object);
if enum_type = voidtype then
c_expr.expr &:= "/* do not declare: void o_4_empty */\n\n";
else
if enum_type not in enum_literal then
enum_literal @:= [enum_type] element_number_hash.EMPTY_HASH;
end if;
if current_object not in enum_literal[enum_type] then
enum_literal[enum_type] @:= [current_object] length(enum_literal[enum_type]);
end if;
c_expr.expr &:= "const ";
declare_type_if_necessary(enum_type, c_expr);
c_expr.expr &:= type_name(enum_type);
c_expr.expr &:= " o_";
create_name(current_object, c_expr.expr);
c_expr.expr &:= "=";
c_expr.expr &:= enum_value(current_object);
c_expr.expr &:= ";\n\n";
end if;
count_declarations(c_expr);
end func;
const proc: print_parameter_list (in ref_list: formal_params,
inout expr_type: c_expr) is func
local
var reference: formal_param is NIL;
var category: paramCategory is category.value;
var boolean: first_element is TRUE;
var type: param_type is void;
var type: implementationType is void;
begin
for formal_param range formal_params do
paramCategory := category(formal_param);
if paramCategory <> SYMBOLOBJECT then
if first_element then
first_element := FALSE;
else
c_expr.expr &:= " printf(\", \");\n";
end if;
param_type := getType(formal_param);
if param_type in implements then
c_expr.expr &:= " /*# ";
for implementationType range implements[param_type] do
c_expr.expr &:= type_name2(implementationType);
c_expr.expr &:= " ";
end for;
c_expr.expr &:= " */ ";
end if;
c_expr.expr &:= "printf(";
c_expr.expr &:= c_literal(str(paramCategory) & " ");
c_expr.expr &:= "); ";
if param_type in typeCategory then
case typeCategory[param_type] of
when {INTOBJECT}:
c_expr.expr &:= "printf(\"intType \"); ";
c_expr.expr &:= "printf(\"%ld\", ";
when {FLOATOBJECT}:
c_expr.expr &:= "printf(\"floatType \"); ";
c_expr.expr &:= "printf(\"%f\", ";
when {CHAROBJECT}:
c_expr.expr &:= "printf(\"charType \"); ";
c_expr.expr &:= "printf(\"%c\", ";
when {STRIOBJECT}:
c_expr.expr &:= "printf(\"striType \"); ";
c_expr.expr &:= "filPrint(";
when {TYPEOBJECT}:
c_expr.expr &:= "printf(\"typeType \"); ";
c_expr.expr &:= "printf(\"%X\", ";
otherwise:
c_expr.expr &:= "printf(\"";
c_expr.expr &:= type_name(param_type);
c_expr.expr &:= " \"); ";
c_expr.expr &:= "printf(\"%X\", ";
end case;
else
c_expr.expr &:= "printf(\"";
c_expr.expr &:= type_name(param_type);
c_expr.expr &:= " \"); ";
c_expr.expr &:= "printf(\"%X\", ";
end if;
if isPointerParam(formal_param) then
c_expr.expr &:= "(o_";
create_name(formal_param, c_expr.expr);
c_expr.expr &:= "?*o_";
create_name(formal_param, c_expr.expr);
c_expr.expr &:= ":0)";
else
c_expr.expr &:= "o_";
create_name(formal_param, c_expr.expr);
end if;
c_expr.expr &:= ");";
end if;
end for;
end func;
const proc: process_dynamic_parameter_list (in reference: function,
in ref_list: actual_params, inout expr_type: c_expr) is func
local
var ref_list: formal_params is ref_list.EMPTY;
var reference: formal_param is NIL;
var reference: actual_param is NIL;
var category: formalCategory is category.value;
var category: paramCategory is category.value;
var boolean: first_element is TRUE;
var integer: number is 0;
begin
formal_params := formalParams(function);
for number range 1 to length(formal_params) do
formal_param := formal_params[number];
actual_param := actual_params[number];
formalCategory := category(formal_param);
paramCategory := category(actual_param);
if paramCategory <> SYMBOLOBJECT and
formalCategory <> SYMBOLOBJECT then
if formalCategory = TYPEOBJECT then
c_expr.expr &:= "/* attr t_";
c_expr.expr &:= str(typeNumber(getValue(formal_param, type)));
c_expr.expr &:= " ";
c_expr.expr &:= str(getValue(formal_param, type));
c_expr.expr &:= "*/ ";
else
if first_element then
first_element := FALSE;
else
c_expr.expr &:= ", ";
end if;
if not isVar(actual_param) and isInOutParam(formal_param) then
c_expr.expr &:= "/* SHOULD NOT HAPPEN &o_";
create_name(actual_param, c_expr.expr);
c_expr.expr &:= " */";
elsif isPointerParam(actual_param) = isPointerParam(formal_param) then
c_expr.expr &:= "o_";
create_name(actual_param, c_expr.expr);
elsif isPointerParam(actual_param) and not isPointerParam(formal_param) then
c_expr.expr &:= "*o_";
create_name(actual_param, c_expr.expr);
else
c_expr.expr &:= "&o_";
create_name(actual_param, c_expr.expr);
end if;
end if;
end if;
end for;
end func;
const proc: process_dynamic_function_call (in reference: function,
in ref_list: actual_params, in reference: interface_object, inout expr_type: c_expr) is func
local
var expr_type: resultExpr is expr_type.value;
begin
resultExpr.currentFile := file(interface_object);
resultExpr.currentLine := line(interface_object);
resultExpr.temp_num := c_expr.temp_num;
if function in function_not_declared then
process_inline(function, actual_params, resultExpr);
if resultExpr.result_expr = "" then
c_expr.expr &:= "/* copy ref_to_value */ ";
process_create_declaration(resultType(getType(interface_object)), global_c_expr);
process_create_call(resultType(getType(interface_object)),
resultExpr.expr, c_expr.expr);
else
c_expr.expr &:= resultExpr.result_expr;
end if;
else
resultExpr.expr &:= "o_";
create_name(function, resultExpr.expr);
resultExpr.expr &:= "(";
process_dynamic_parameter_list(function, actual_params, resultExpr);
resultExpr.expr &:= ")";
if function in return_ref_to_value then
c_expr.expr &:= "/* copy ref_to_value */ ";
process_create_declaration(resultType(getType(interface_object)), global_c_expr);
process_create_call(resultType(getType(interface_object)),
resultExpr.expr, c_expr.expr);
else
c_expr.expr &:= resultExpr.expr;
end if;
end if;
c_expr.temp_num := resultExpr.temp_num;
c_expr.temp_decls &:= resultExpr.temp_decls;
c_expr.temp_assigns &:= resultExpr.temp_assigns;
c_expr.temp_frees &:= resultExpr.temp_frees;
c_expr.temp_to_null &:= resultExpr.temp_to_null;
end func;
const proc: process_dynamic_action_call (in reference: function,
in ref_list: actual_params, in reference: interface_object, inout expr_type: c_expr) is func
local
var expr_type: c_action_expr is expr_type.value;
begin
c_action_expr.currentFile := file(interface_object);
c_action_expr.currentLine := line(interface_object);
c_action_expr.temp_num := c_expr.temp_num;
process_action(function, actual_params, c_action_expr);
c_expr.temp_num := c_action_expr.temp_num;
c_expr.temp_decls &:= c_action_expr.temp_decls;
c_expr.temp_assigns &:= c_action_expr.temp_assigns;
c_expr.temp_frees &:= c_action_expr.temp_frees;
c_expr.temp_to_null &:= c_action_expr.temp_to_null;
if c_action_expr.result_expr <> "" then
c_expr.expr &:= c_action_expr.result_expr;
else
if isVarfunc(getType(interface_object)) or
getType(interface_object) = proctype then
c_expr.expr &:= c_action_expr.expr;
else
c_expr.expr &:= "/* copy ref_to_value */ ";
process_create_declaration(resultType(getType(interface_object)), global_c_expr);
process_create_call(resultType(getType(interface_object)),
c_action_expr.expr, c_expr.expr);
end if;
end if;
end func;
const proc: process_dynamic_call (in reference: function,
in ref_list: actual_params, in reference: interface_object,
inout expr_type: c_expr) is func
local
var category: objectCategory is category.value;
var expr_type: resultExpr is expr_type.value;
begin
if function = interface_object then
c_expr.expr &:= "/* ENDLESS RECURSION */\n";
c_expr.expr &:= diagnosticLine(interface_object);
c_expr.expr &:= "raiseError(ACTION_ERROR);\n";
elsif function <> NIL then
c_expr.expr &:= diagnosticLine(interface_object);
objectCategory := category(function);
if objectCategory = BLOCKOBJECT then
if resultType(getType(interface_object)) <> voidtype then
c_expr.expr &:= "return ";
end if;
process_dynamic_function_call(function, actual_params, interface_object, c_expr);
c_expr.expr &:= ";\n";
elsif objectCategory = ACTOBJECT then
if resultType(getType(interface_object)) <> voidtype then
c_expr.expr &:= "return ";
if isVarfunc(getType(interface_object)) then
c_expr.expr &:= "&(";
end if;
end if;
process_dynamic_action_call(function, actual_params, interface_object, c_expr);
if resultType(getType(interface_object)) <> voidtype then
if isVarfunc(getType(interface_object)) then
c_expr.expr &:= ")";
end if;
c_expr.expr &:= ";\n";
end if;
elsif objectCategory = INTOBJECT or
objectCategory = BIGINTOBJECT or
objectCategory = FLOATOBJECT or
objectCategory = CHAROBJECT or
objectCategory = STRIOBJECT or
objectCategory = BSTRIOBJECT or
objectCategory = ARRAYOBJECT or
objectCategory = STRUCTOBJECT or
objectCategory = SETOBJECT or
objectCategory = WINOBJECT or
objectCategory = POINTLISTOBJECT or
objectCategory = PROCESSOBJECT or
objectCategory = CONSTENUMOBJECT then
c_expr.expr &:= "return ";
getAnyParamToExpr(function, resultExpr);
process_create_declaration(getType(function), global_c_expr);
process_create_call(getType(function),
resultExpr.expr, c_expr.expr);
c_expr.expr &:= ";\n";
else
c_expr.expr &:= "/* ";
c_expr.expr &:= str(objectCategory);
c_expr.expr &:= " */\n";
end if;
else
c_expr.expr &:= "/* NOT FOUND */\n";
c_expr.expr &:= diagnosticLine(interface_object);
c_expr.expr &:= "raiseError(ACTION_ERROR);\n";
end if;
end func;
const proc: process_dynamic_condition (in reference: current_object,
inout ref_list: formal_params, in var integer: paramNum,
inout expr_type: c_expr) is forward;
const proc: process_dynamic_param_implements (in reference: current_object,
inout ref_list: formal_params, in var integer: paramNum,
in type: param_type, inout expr_type: c_expr) is func
local
var reference: formal_param is NIL;
var type: implementationType is void;
var bitset: usedCaseLabels is {};
begin
formal_param := formal_params[paramNum];
c_expr.expr &:= diagnosticLine(current_object);
c_expr.expr &:= "switch (((interfaceType) ";
if isPointerParam(formal_param) then
c_expr.expr &:= "*o_";
else
c_expr.expr &:= "o_";
end if;
create_name(formal_param, c_expr.expr);
c_expr.expr &:= ")->type_num) {\n";
for implementationType range implements[param_type] do
if typeNumber(implementationType) not in usedCaseLabels then
c_expr.expr &:= "case ";
c_expr.expr &:= str(typeNumber(implementationType));
c_expr.expr &:= "/*";
c_expr.expr &:= str(implementationType);
c_expr.expr &:= "*/";
c_expr.expr &:= ":\n";
setType(formal_params[paramNum], implementationType);
process_dynamic_condition(current_object,
formal_params, paramNum, c_expr);
setType(formal_params[paramNum], param_type);
c_expr.expr &:= diagnosticLine(current_object);
c_expr.expr &:= "break;\n";
incl(usedCaseLabels, typeNumber(implementationType));
end if;
end for;
c_expr.expr &:= "default:\n";
c_expr.expr &:= diagnosticLine(current_object);
c_expr.expr &:= "raiseError(ACTION_ERROR);\n";
c_expr.expr &:= diagnosticLine(current_object);
c_expr.expr &:= "break;\n";
c_expr.expr &:= "}\n";
end func;
const proc: process_dynamic_param_enumeration (in reference: current_object,
inout ref_list: formal_params, in var integer: paramNum,
in type: param_type, inout expr_type: c_expr) is func
local
var reference: formal_param is NIL;
var number_element_hash: enumsByIntValue is number_element_hash.value;
var integer: intValueOfEnum is 0;
var reference: enumLiteral is NIL;
var reference: backupParam is NIL;
begin
formal_param := formal_params[paramNum];
c_expr.expr &:= diagnosticLine(current_object);
c_expr.expr &:= "switch (";
if isPointerParam(formal_param) then
c_expr.expr &:= "*o_";
create_name(formal_param, c_expr.expr);
else
c_expr.expr &:= "o_";
create_name(formal_param, c_expr.expr);
end if;
c_expr.expr &:= ") {\n";
enumsByIntValue := flip(enum_literal[param_type]);
for intValueOfEnum range sort(keys(enumsByIntValue)) do
c_expr.expr &:= diagnosticLine(current_object);
c_expr.expr &:= "case ";
c_expr.expr &:= str(intValueOfEnum);
c_expr.expr &:= ": {\n";
enumLiteral := enumsByIntValue[intValueOfEnum][1];
backupParam := formal_params[paramNum];
formal_params @:= [paramNum] enumLiteral;
process_dynamic_condition(current_object,
formal_params, paramNum, c_expr);
formal_params @:= [paramNum] backupParam;
c_expr.expr &:= diagnosticLine(current_object);
c_expr.expr &:= "} break;\n";
end for;
c_expr.expr &:= diagnosticLine(current_object);
c_expr.expr &:= "default: {\n";
c_expr.expr &:= diagnosticLine(current_object);
c_expr.expr &:= "raiseError(ACTION_ERROR);\n";
c_expr.expr &:= "} break;\n";
c_expr.expr &:= "}\n";
end func;
const proc: process_dynamic_condition (in reference: current_object,
inout ref_list: formal_params, in var integer: paramNum,
inout expr_type: c_expr) is func
local
var reference: formal_param is NIL;
var category: paramCategory is category.value;
var type: param_type is void;
var ref_list: param_list is ref_list.EMPTY;
var reference: matched_object is NIL;
begin
incr(paramNum);
if paramNum <= length(formal_params) then
formal_param := formal_params[paramNum];
paramCategory := category(formal_param);
if paramCategory <> SYMBOLOBJECT then
param_type := getType(formal_param);
if param_type in implements then
process_dynamic_param_implements(current_object,
formal_params, paramNum, param_type, c_expr);
elsif param_type in enum_literal then
process_dynamic_param_enumeration(current_object,
formal_params, paramNum, param_type, c_expr);
else
process_dynamic_condition(current_object,
formal_params, paramNum, c_expr);
end if;
else
process_dynamic_condition(current_object,
formal_params, paramNum, c_expr);
end if;
else
param_list := formal_params;
matched_object := match(prog, param_list);
process_dynamic_call(matched_object, formal_params, current_object, c_expr);
end if;
end func;
const proc: process_dynamic_decision (in reference: current_object,
inout expr_type: c_expr) is func
local
var expr_type: c_param_list is expr_type.value;
var expr_type: c_func_body is expr_type.value;
var type: object_type is void;
var type: result_type is void;
var ref_list: param_list is ref_list.EMPTY;
begin
object_type := getType(current_object);
if isFunc(object_type) or isVarfunc(object_type) then
result_type := resultType(object_type);
declare_types_of_params(param_list, global_c_expr);
c_expr.expr &:= diagnosticLine(current_object);
c_expr.expr &:= "/* DYNAMIC */ static ";
c_expr.expr &:= type_name(result_type);
if isVarfunc(object_type) then
c_expr.expr &:= " *o_";
else
c_expr.expr &:= " o_";
end if;
create_name(current_object, c_expr.expr);
param_list := formalParams(current_object);
c_expr.expr &:= " (";
process_param_list_declaration(param_list, c_param_list);
c_expr.expr &:= c_param_list.expr;
c_expr.expr &:= ")\n";
c_expr.expr &:= diagnosticLine(current_object);
c_expr.expr &:= "{\n";
process_dynamic_condition(current_object,
param_list, 0, c_func_body);
appendWithDiagnostic(c_param_list.temp_decls, c_expr);
appendWithDiagnostic(c_func_body.temp_decls, c_expr);
c_expr.expr &:= c_param_list.temp_assigns;
if trace_dynamic_calls then
c_expr.expr &:= "fprintf(";
c_expr.expr &:= trace_output;
c_expr.expr &:= ", \"DYNAMIC ";
create_name(current_object, c_expr.expr);
c_expr.expr &:= "\\n\");\n";
c_expr.expr &:= "fflush(";
c_expr.expr &:= trace_output;
c_expr.expr &:= ");\n";
end if;
appendWithDiagnostic(c_func_body.temp_assigns, c_expr);
c_expr.expr &:= c_func_body.expr;
appendWithDiagnostic(c_param_list.temp_frees, c_expr);
appendWithDiagnostic(c_func_body.temp_frees, c_expr);
c_expr.expr &:= diagnosticLine(current_object);
c_expr.expr &:= "}\n\n";
end if;
end func;
const proc: process_dynamic_decisions (inout expr_type: c_expr) is func
local
var reference: current_object is NIL;
begin
for current_object range dynamic_functions do
process_dynamic_decision(current_object, c_expr);
end for;
end func;
const proc: process_dynamic_declaration (in reference: current_object,
inout expr_type: c_expr) is func
local
var expr_type: c_param_list is expr_type.value;
var type: object_type is void;
var type: result_type is void;
var ref_list: param_list is ref_list.EMPTY;
begin
object_type := getType(current_object);
if isFunc(object_type) or isVarfunc(object_type) then
result_type := resultType(object_type);
dynamic_functions &:= make_list(current_object);
declare_types_of_params(param_list, global_c_expr);
c_expr.expr &:= "/* DYNAMIC */ static ";
c_expr.expr &:= type_name(result_type);
if isVarfunc(object_type) then
c_expr.expr &:= " *o_";
else
c_expr.expr &:= " o_";
end if;
create_name(current_object, c_expr.expr);
param_list := formalParams(current_object);
c_expr.expr &:= " (";
process_param_list_declaration(param_list, c_param_list);
c_expr.expr &:= c_param_list.expr;
c_expr.expr &:= ");\n";
prototype_declared @:= [current_object] TRUE;
end if;
end func;
const proc: declare_literal_function_of_enum (in type: enumType,
inout expr_type: c_expr) is func
local
var number_element_hash: enumsByIntValue is number_element_hash.value;
var integer: intValueOfEnum is 0;
var reference: enumLiteral is NIL;
begin
c_expr.expr &:= noDiagnosticLine;
c_expr.expr &:= "static striType lit_";
c_expr.expr &:= str(typeNumber(enumType));
c_expr.expr &:= " (";
c_expr.expr &:= type_name(enumType);
c_expr.expr &:= " enumValue)\n";
c_expr.expr &:= "{\n";
c_expr.expr &:= noDiagnosticLine;
c_expr.expr &:= "switch (enumValue) {\n";
enumsByIntValue := flip(enum_literal[enumType]);
for intValueOfEnum range sort(keys(enumsByIntValue)) do
enumLiteral := enumsByIntValue[intValueOfEnum][1];
c_expr.expr &:= diagnosticLine(enumLiteral);
c_expr.expr &:= "case ";
c_expr.expr &:= str(intValueOfEnum);
c_expr.expr &:= ": return ";
c_expr.expr &:= stringLiteral(str(enumLiteral));
c_expr.expr &:= "; break;\n";
end for;
c_expr.expr &:= noDiagnosticLine;
c_expr.expr &:= "default: ";
c_expr.expr &:= raiseError("RANGE_ERROR");
c_expr.expr &:= " return NULL; break;\n";
c_expr.expr &:= "}\n";
c_expr.expr &:= "}\n";
c_expr.expr &:= "\n";
end func;
const proc: declare_literal_function_of_enums (inout expr_type: c_expr) is func
local
var type: enumType is void;
begin
for key enumType range enum_literal do
if enumType in literal_function_of_enum_used then
declare_literal_function_of_enum(enumType, c_expr);
end if;
end for;
end func;
const proc: process_hashcode (in reference: current_object, inout expr_type: c_expr) is func
local
var ref_list: param_list is ref_list.EMPTY;
var reference: expression is NIL;
begin
param_list := make_list(current_object);
param_list &:= make_list(syobject(prog, "hashCode"));
expression := matchExpr(prog, param_list);
setCategory(expression, CALLOBJECT);
process_expr(expression, c_expr);
end func;
const func reference: keyCreateObj (in type: hash_type) is func
result
var reference: keyCreate is NIL;
local
var ref_list: param_list is ref_list.EMPTY;
begin
param_list := make_list(typeObject(hash_type));
param_list &:= make_list(syobject(prog, "."));
param_list &:= make_list(syobject(prog, "keyCreate"));
keyCreate := match(prog, param_list);
keyCreate := getValue(keyCreate, reference);
end func;
const func reference: keyCompareObj (in type: hash_type) is func
result
var reference: keyCompare is NIL;
local
var ref_list: param_list is ref_list.EMPTY;
begin
param_list := make_list(typeObject(hash_type));
param_list &:= make_list(syobject(prog, "."));
param_list &:= make_list(syobject(prog, "keyCompare"));
keyCompare := match(prog, param_list);
keyCompare := getValue(keyCompare, reference);
end func;
const func reference: dataCreateObj (in type: hash_type) is func
result
var reference: dataCreate is NIL;
local
var ref_list: param_list is ref_list.EMPTY;
begin
param_list := make_list(typeObject(hash_type));
param_list &:= make_list(syobject(prog, "."));
param_list &:= make_list(syobject(prog, "dataCreate"));
dataCreate := match(prog, param_list);
dataCreate := getValue(dataCreate, reference);
end func;
const func reference: dataCopyObj (in type: hash_type) is func
result
var reference: dataCopy is NIL;
local
var ref_list: param_list is ref_list.EMPTY;
begin
param_list := make_list(typeObject(hash_type));
param_list &:= make_list(syobject(prog, "."));
param_list &:= make_list(syobject(prog, "dataCopy"));
dataCopy := match(prog, param_list);
dataCopy := getValue(dataCopy, reference);
end func;
const proc: process_arr_cpy_declaration (in reference: current_object) is func
local
var ref_list: params is ref_list.EMPTY;
var type: arrayType is void;
var type: elementType is void;
begin
params := formalParams(current_object);
if length(params) >= 1 then
arrayType := getType(params[1]);
copyFunction @:= [arrayType] current_object;
typeCategory @:= [arrayType] ARRAYOBJECT;
elementType := base_type(arrayType);
if elementType <> void then
if arrayType not in array_element then
array_element @:= [arrayType] elementType;
end if;
if elementType not in array_type then
array_type @:= [elementType] arrayType;
end if;
end if;
end if;
end func;
const proc: process_arr_create_declaration (in reference: current_object) is func
local
var ref_list: params is ref_list.EMPTY;
var type: arrayType is void;
var type: elementType is void;
begin
params := formalParams(current_object);
if length(params) >= 1 then
arrayType := getType(params[1]);
createFunction @:= [arrayType] current_object;
typeCategory @:= [arrayType] ARRAYOBJECT;
elementType := base_type(arrayType);
if elementType <> void then
if arrayType not in array_element then
array_element @:= [arrayType] elementType;
end if;
if elementType not in array_type then
array_type @:= [elementType] arrayType;
end if;
end if;
end if;
end func;
const proc: process_arr_destr_declaration (in reference: current_object) is func
local
var ref_list: params is ref_list.EMPTY;
var type: arrayType is void;
var type: elementType is void;
begin
params := formalParams(current_object);
if length(params) >= 1 then
arrayType := getType(params[1]);
destrFunction @:= [arrayType] current_object;
typeCategory @:= [arrayType] ARRAYOBJECT;
elementType := base_type(arrayType);
if elementType <> void then
if arrayType not in array_element then
array_element @:= [arrayType] elementType;
end if;
if elementType not in array_type then
array_type @:= [elementType] arrayType;
end if;
end if;
end if;
end func;
const proc: process_arr_gen_declaration (in reference: current_object,
inout expr_type: c_expr) is func
local
var ref_list: params is ref_list.EMPTY;
var type: arrayType is void;
var type: elementType is void;
begin
params := formalParams(current_object);
if length(params) >= 1 then
arrayType := resultType(getType(current_object));
elementType := getType(params[1]);
if arrayType not in array_element then
array_element @:= [arrayType] elementType;
end if;
if elementType not in array_type then
array_type @:= [elementType] arrayType;
end if;
c_expr.expr &:= "/* ACTION ARR_GEN for type ";
c_expr.expr &:= type_name2(arrayType);
c_expr.expr &:= " element is ";
c_expr.expr &:= type_name2(elementType);
c_expr.expr &:= " */\n\n";
end if;
end func;
const proc: process_arr_idx_declaration (in reference: current_object,
inout expr_type: c_expr) is func
local
var ref_list: params is ref_list.EMPTY;
var type: arrayType is void;
var type: elementType is void;
begin
params := formalParams(current_object);
if length(params) >= 1 then
arrayType := getType(params[1]);
elementType := resultType(getType(current_object));
if arrayType not in array_element then
array_element @:= [arrayType] elementType;
end if;
if elementType not in array_type then
array_type @:= [elementType] arrayType;
end if;
c_expr.expr &:= "/* ACTION ARR_IDX for type ";
c_expr.expr &:= type_name2(arrayType);
c_expr.expr &:= " element is ";
c_expr.expr &:= type_name2(elementType);
c_expr.expr &:= " */\n\n";
end if;
end func;
const proc: process_arr_times_declaration (in reference: current_object,
inout expr_type: c_expr) is func
local
var string: diagnosticLine is "";
var ref_list: params is ref_list.EMPTY;
var type: arrayType is void;
var type: elementType is void;
begin
diagnosticLine := diagnosticLine(current_object);
params := formalParams(current_object);
if length(params) >= 3 then
arrayType := resultType(getType(current_object));
elementType := getType(params[3]);
if elementType in typeCategory and
typeCategory[elementType] in simpleValueType then
c_expr.expr &:= "/* times_";
c_expr.expr &:= str(typeNumber(arrayType));
c_expr.expr &:= " not defined because arrTimes() is used instead. */\n";
else
process_create_declaration(elementType, c_expr);
c_expr.expr &:= diagnosticLine;
c_expr.expr &:= "static arrayType times_";
c_expr.expr &:= str(typeNumber(arrayType));
c_expr.expr &:= " (intType n, const ";
if useConstPrefix(elementType) then
c_expr.expr &:= "const_";
end if;
c_expr.expr &:= type_name(elementType);
c_expr.expr &:= " b)\n";
c_expr.expr &:= diagnosticLine;
times_prototype_declared @:= [arrayType] TRUE;
c_expr.expr &:= "{\n";
c_expr.expr &:= diagnosticLine;
c_expr.expr &:= "arrayType a;\n";
c_expr.expr &:= diagnosticLine;
c_expr.expr &:= "memSizeType i;\n";
c_expr.expr &:= diagnosticLine;
c_expr.expr &:= "a=arrMalloc(1, n);\n";
c_expr.expr &:= diagnosticLine;
c_expr.expr &:= "for (i = 0; i < (memSizeType)(n); i++) {\n";
c_expr.expr &:= diagnosticLine;
c_expr.expr &:= "a->arr[i]";
c_expr.expr &:= select_value_from_rtlObjectStruct(elementType);
c_expr.expr &:= "=";
process_create_call(elementType, "b", c_expr.expr);
c_expr.expr &:= ";\n";
c_expr.expr &:= diagnosticLine;
c_expr.expr &:= "}\n";
c_expr.expr &:= diagnosticLine;
c_expr.expr &:= "return a;\n";
c_expr.expr &:= diagnosticLine;
c_expr.expr &:= "}\n";
c_expr.expr &:= noDiagnosticLine;
c_expr.expr &:= "\n";
end if;
end if;
end func;
const proc: defineParam1TypeCategory (in reference: current_object,
in category: param1Category) is func
local
var ref_list: params is ref_list.EMPTY;
var type: param1Type is void;
begin
params := formalParams(current_object);
if length(params) >= 1 then
param1Type := getType(params[1]);
typeCategory @:= [param1Type] param1Category;
end if;
end func;
const proc: addImplementationToInterface (in type: implementationType, in type: interfaceType) is func
begin
if interfaceType in implements then
implements[interfaceType] &:= implementationType;
else
implements @:= [interfaceType] [] (implementationType);
end if;
if implementationType in interfaceOfType then
interfaceOfType[implementationType] &:= interfaceType;
else
interfaceOfType @:= [implementationType] [] (interfaceType);
end if;
end func;
const proc: process_itf_cpy2_declaration (in reference: current_object,
inout expr_type: c_expr) is func
local
var ref_list: params is ref_list.EMPTY;
var type: interfaceType is void;
var type: implementationType is void;
begin
params := formalParams(current_object);
if length(params) >= 1 then
interfaceType := getType(params[1]);
implementationType := getType(params[3]);
addImplementationToInterface(implementationType, interfaceType);
c_expr.expr &:= "/* itf_cpy2: ";
c_expr.expr &:= type_name2(interfaceType);
c_expr.expr &:= " := ";
c_expr.expr &:= type_name2(implementationType);
c_expr.expr &:= " */\n";
end if;
end func;
const proc: process_itf_next_file_declaration (in reference: current_object) is func
local
var type: object_type is void;
begin
object_type := getType(current_object);
if isFunc(object_type) or isVarfunc(object_type) then
fileInterfaceType := resultType(object_type);
end if;
end func;
const proc: process_hsh_cpy_declaration (in reference: current_object) is func
local
var ref_list: params is ref_list.EMPTY;
var type: hashType is void;
begin
params := formalParams(current_object);
if length(params) >= 1 then
hashType := getType(params[1]);
copyFunction @:= [hashType] current_object;
typeCategory @:= [hashType] HASHOBJECT;
end if;
end func;
const proc: process_hsh_create_declaration (in reference: current_object) is func
local
var ref_list: params is ref_list.EMPTY;
var type: hashType is void;
begin
params := formalParams(current_object);
if length(params) >= 1 then
hashType := getType(params[1]);
createFunction @:= [hashType] current_object;
typeCategory @:= [hashType] HASHOBJECT;
end if;
end func;
const proc: process_hsh_destr_declaration (in reference: current_object) is func
local
var ref_list: params is ref_list.EMPTY;
var type: hashType is void;
begin
params := formalParams(current_object);
if length(params) >= 1 then
hashType := getType(params[1]);
destrFunction @:= [hashType] current_object;
typeCategory @:= [hashType] HASHOBJECT;
end if;
end func;
const proc: addStructElem (in type: structType, in type: elemType, in reference: elementOfStruct) is func
local
var integer: elementIndex is 0;
var element_idx_hash: element_index is element_idx_hash.EMPTY_HASH;
begin
if structType in struct_element_idx then
elementIndex := struct_size[structType];
struct_element_idx[structType] @:= [elementOfStruct] elementIndex;
struct_element_type[structType] &:= elemType;
struct_element[structType] &:= elementOfStruct;
struct_size @:= [structType] succ(elementIndex);
else
struct_size @:= [structType] 1;
element_index @:= [elementOfStruct] 0;
struct_element_idx @:= [structType] element_index;
struct_element_type @:= [structType] [0] elemType;
struct_element @:= [structType] [0] elementOfStruct;
end if;
end func;
const proc: process_ref_select_declaration (in reference: current_object,
inout expr_type: c_expr) is func
local
var ref_list: params is ref_list.EMPTY;
var type: elemType is void;
var type: structType is void;
var reference: elementOfStruct is NIL;
begin
params := formalParams(current_object);
if length(params) >= 3 and not isVar(params[1]) then
structType := getType(params[1]);
elementOfStruct := params[3];
elemType := resultType(getType(current_object));
addStructElem(structType, elemType, elementOfStruct);
c_expr.expr &:= "/* ref struct element ";
c_expr.expr &:= type_name2(elemType);
c_expr.expr &:= " ** ";
c_expr.expr &:= type_name2(structType);
c_expr.expr &:= "->o_";
create_name2(elementOfStruct, c_expr.expr);
c_expr.expr &:= " = ";
c_expr.expr &:= str(struct_element_idx[structType][elementOfStruct]);
c_expr.expr &:= " */\n";
end if;
end func;
const proc: process_sct_cpy_declaration (in reference: current_object) is func
local
var ref_list: params is ref_list.EMPTY;
var type: sct_type is void;
var type: meta_type is void;
var type: interfaceType is void;
var integer: structIndex is 0;
begin
params := formalParams(current_object);
if length(params) >= 1 then
sct_type := getType(params[1]);
copyFunction @:= [sct_type] current_object;
typeCategory @:= [sct_type] STRUCTOBJECT;
if isDerived(sct_type) then
meta_type := meta(sct_type);
if meta_type in struct_element_idx then
for structIndex range 0 to pred(struct_size[meta_type]) do
addStructElem(sct_type, struct_element_type[meta_type][structIndex],
struct_element[meta_type][structIndex]);
end for;
end if;
if meta_type in interfaceOfType then
for interfaceType range interfaceOfType[meta_type] do
addImplementationToInterface(sct_type, interfaceType);
end for;
end if;
end if;
end if;
end func;
const proc: process_sct_create_declaration (in reference: current_object) is func
local
var ref_list: params is ref_list.EMPTY;
var type: object_type is void;
begin
params := formalParams(current_object);
object_type := getType(params[1]);
createFunction @:= [object_type] current_object;
typeCategory @:= [object_type] STRUCTOBJECT;
end func;
const proc: process_sct_destr_declaration (in reference: current_object) is func
local
var ref_list: params is ref_list.EMPTY;
var type: object_type is void;
begin
params := formalParams(current_object);
object_type := getType(params[1]);
destrFunction @:= [object_type] current_object;
typeCategory @:= [object_type] STRUCTOBJECT;
end func;
const proc: process_sct_select_declaration (in reference: current_object,
inout expr_type: c_expr) is func
local
var ref_list: params is ref_list.EMPTY;
var type: elemType is void;
var type: structType is void;
var reference: elementOfStruct is NIL;
begin
params := formalParams(current_object);
if length(params) >= 3 and not isVar(params[1]) then
structType := getType(params[1]);
elementOfStruct := params[3];
elemType := resultType(getType(current_object));
addStructElem(structType, elemType, elementOfStruct);
c_expr.expr &:= "/* struct element ";
c_expr.expr &:= type_name2(elemType);
c_expr.expr &:= " ** ";
c_expr.expr &:= type_name2(structType);
c_expr.expr &:= "->o_";
create_name2(elementOfStruct, c_expr.expr);
c_expr.expr &:= " = ";
c_expr.expr &:= str(struct_element_idx[structType][elementOfStruct]);
c_expr.expr &:= " */\n";
end if;
end func;
const proc: process_var_action_declaration (in reference: current_object,
inout expr_type: c_expr) is func
local
var expr_type: c_value is expr_type.value;
var string: valueName is "";
begin
create_name(current_object, objNumber(current_object), valueName);
processFuncValue(valueName, getType(current_object), current_object, c_value);
c_expr.expr &:= c_value.temp_decls;
global_init.expr &:= diagnosticLine(current_object);
global_init.expr &:= c_value.temp_assigns;
c_expr.expr &:= type_name(getType(current_object));
c_expr.expr &:= " o_";
create_name(current_object, c_expr.expr);
c_expr.expr &:= " = ";
c_expr.expr &:= c_value.expr;
c_expr.expr &:= ";\n\n";
function_declared @:= [current_object] TRUE;
end func;
const proc: process_action_declaration (in reference: current_object,
inout expr_type: c_expr) is func
local
var ACTION: current_action is action "PRC_NOOP";
var string: action_name is "";
begin
if isVar(current_object) then
process_var_action_declaration(current_object, c_expr);
else
current_action := getValue(current_object, ACTION);
action_name := str(current_action);
if action_name = "PRC_DYNAMIC" then
process_dynamic_declaration(current_object, c_expr);
count_declarations(c_expr);
elsif action_name = "ACT_CPY" then
defineParam1TypeCategory(current_object, ACTOBJECT);
count_declarations(c_expr);
elsif action_name = "ARR_CPY" then
process_arr_cpy_declaration(current_object);
count_declarations(c_expr);
elsif action_name = "ARR_CREATE" then
process_arr_create_declaration(current_object);
count_declarations(c_expr);
elsif action_name = "ARR_DESTR" then
process_arr_destr_declaration(current_object);
count_declarations(c_expr);
elsif action_name = "ARR_GEN" then
process_arr_gen_declaration(current_object, c_expr);
count_declarations(c_expr);
elsif action_name = "ARR_IDX" then
process_arr_idx_declaration(current_object, c_expr);
count_declarations(c_expr);
elsif action_name = "ARR_TIMES" then
process_arr_times_declaration(current_object, c_expr);
count_declarations(c_expr);
elsif action_name = "BIG_CPY" or action_name = "BIG_CREATE" then
defineParam1TypeCategory(current_object, BIGINTOBJECT);
count_declarations(c_expr);
elsif action_name = "BLN_CPY" then
defineParam1TypeCategory(current_object, BOOLOBJECT);
count_declarations(c_expr);
elsif action_name = "BST_CPY" or action_name = "BST_CREATE" then
defineParam1TypeCategory(current_object, BSTRIOBJECT);
count_declarations(c_expr);
elsif action_name = "DRW_CPY" or action_name = "DRW_CREATE" then
defineParam1TypeCategory(current_object, WINOBJECT);
count_declarations(c_expr);
elsif action_name = "PLT_CPY" or action_name = "PLT_CREATE" then
defineParam1TypeCategory(current_object, POINTLISTOBJECT);
count_declarations(c_expr);
elsif action_name = "PCS_CPY" or action_name = "PCS_CREATE" then
defineParam1TypeCategory(current_object, PROCESSOBJECT);
count_declarations(c_expr);
elsif action_name = "ENU_CPY" then
defineParam1TypeCategory(current_object, ENUMOBJECT);
count_declarations(c_expr);
elsif action_name = "FIL_CPY" or action_name = "FIL_CREATE" then
defineParam1TypeCategory(current_object, FILEOBJECT);
count_declarations(c_expr);
elsif action_name = "FLT_CPY" or action_name = "FLT_CREATE" then
defineParam1TypeCategory(current_object, FLOATOBJECT);
count_declarations(c_expr);
elsif action_name = "HSH_CONCAT_KEY_VALUE" then
defineParam1TypeCategory(current_object, HASHELEMOBJECT);
count_declarations(c_expr);
elsif action_name = "HSH_CPY" then
process_hsh_cpy_declaration(current_object);
count_declarations(c_expr);
elsif action_name = "HSH_CREATE" then
process_hsh_create_declaration(current_object);
count_declarations(c_expr);
elsif action_name = "HSH_DESTR" then
process_hsh_destr_declaration(current_object);
count_declarations(c_expr);
elsif action_name = "INT_CPY" or action_name = "INT_CREATE" then
defineParam1TypeCategory(current_object, INTOBJECT);
count_declarations(c_expr);
elsif action_name = "ITF_CPY" then
defineParam1TypeCategory(current_object, INTERFACEOBJECT);
count_declarations(c_expr);
elsif action_name = "ITF_CPY2" then
process_itf_cpy2_declaration(current_object, c_expr);
count_declarations(c_expr);
elsif action_name = "POL_CPY" or action_name = "POL_CREATE" then
defineParam1TypeCategory(current_object, POLLOBJECT);
count_declarations(c_expr);
elsif action_name = "POL_NEXT_FILE" then
process_itf_next_file_declaration(current_object);
count_declarations(c_expr);
elsif action_name = "PRG_CPY" or action_name = "PRG_CREATE" then
defineParam1TypeCategory(current_object, PROGOBJECT);
count_declarations(c_expr);
elsif action_name = "REF_CPY" or action_name = "REF_CREATE" then
defineParam1TypeCategory(current_object, REFOBJECT);
count_declarations(c_expr);
elsif action_name = "REF_SELECT" then
process_ref_select_declaration(current_object, c_expr);
count_declarations(c_expr);
elsif action_name = "RFL_CPY" or action_name = "RFL_CREATE" then
defineParam1TypeCategory(current_object, REFLISTOBJECT);
count_declarations(c_expr);
elsif action_name = "SCT_CPY" then
process_sct_cpy_declaration(current_object);
count_declarations(c_expr);
elsif action_name = "SCT_CREATE" then
process_sct_create_declaration(current_object);
count_declarations(c_expr);
elsif action_name = "SCT_DESTR" then
process_sct_destr_declaration(current_object);
count_declarations(c_expr);
elsif action_name = "SCT_SELECT" then
process_sct_select_declaration(current_object, c_expr);
count_declarations(c_expr);
elsif action_name = "SET_CPY" or action_name = "SET_CREATE" then
defineParam1TypeCategory(current_object, SETOBJECT);
count_declarations(c_expr);
elsif action_name = "SOC_CPY" or action_name = "SOC_CREATE" then
defineParam1TypeCategory(current_object, SOCKETOBJECT);
count_declarations(c_expr);
elsif action_name = "SQL_CPY_DB" or action_name = "SQL_CREATE_DB" then
defineParam1TypeCategory(current_object, DATABASEOBJECT);
count_declarations(c_expr);
elsif action_name = "SQL_CPY_STMT" or action_name = "SQL_CREATE_STMT" then
defineParam1TypeCategory(current_object, SQLSTMTOBJECT);
count_declarations(c_expr);
end if;
end if;
end func;
const proc: process_object_declaration (in reference: current_object,
inout expr_type: c_expr) is func
local
var category: objectCategory is category.value;
begin
objectCategory := category(current_object);
if current_object = main_object then
if category(current_object) = FORWARDOBJECT then
process_library_initialisation(current_object, c_expr);
else
process_main_declaration(current_object, c_expr);
end if;
elsif objectCategory = BLOCKOBJECT then
process_func_declaration(current_object, c_expr);
elsif objectCategory = TYPEOBJECT then
process_type_declaration(current_object, c_expr);
elsif objectCategory = INTOBJECT then
process_int_declaration(current_object, c_expr);
elsif objectCategory = BIGINTOBJECT then
process_bigint_declaration(current_object, c_expr);
elsif objectCategory = CHAROBJECT then
process_char_declaration(current_object, c_expr);
elsif objectCategory = STRIOBJECT then
process_stri_declaration(current_object, c_expr);
elsif objectCategory = BSTRIOBJECT then
process_bstri_declaration(current_object, c_expr);
elsif objectCategory = FLOATOBJECT then
process_float_declaration(current_object, c_expr);
elsif objectCategory = REFOBJECT then
process_reference_declaration(current_object, c_expr);
elsif objectCategory = REFLISTOBJECT then
process_ref_list_declaration(current_object, c_expr);
elsif objectCategory = FILEOBJECT then
process_file_declaration(current_object, c_expr);
elsif objectCategory = SOCKETOBJECT then
process_socket_declaration(current_object, c_expr);
elsif objectCategory = POLLOBJECT then
process_poll_declaration(current_object, c_expr);
elsif objectCategory = ARRAYOBJECT then
process_array_declaration(current_object, c_expr);
elsif objectCategory = HASHOBJECT then
process_hash_declaration(current_object, c_expr);
elsif objectCategory = SETOBJECT then
process_set_declaration(current_object, c_expr);
elsif objectCategory = STRUCTOBJECT then
process_struct_declaration(current_object, c_expr);
elsif objectCategory = INTERFACEOBJECT then
process_interface_declaration(current_object, c_expr);
elsif objectCategory = WINOBJECT then
process_win_declaration(current_object, c_expr);
elsif objectCategory = POINTLISTOBJECT then
process_plist_declaration(current_object, c_expr);
elsif objectCategory = PROCESSOBJECT then
process_process_declaration(current_object, c_expr);
elsif objectCategory = PROGOBJECT then
process_prog_declaration(current_object, c_expr);
elsif objectCategory = CONSTENUMOBJECT then
process_enum_declaration(current_object, c_expr);
elsif objectCategory = VARENUMOBJECT then
process_enum_declaration(current_object, c_expr);
elsif objectCategory = ENUMLITERALOBJECT then
process_enum_literal_declaration(current_object, c_expr);
elsif objectCategory = ACTOBJECT then
process_action_declaration(current_object, c_expr);
elsif objectCategory = FWDREFOBJECT then
process_forward_declaration(current_object, c_expr);
else
c_expr.expr &:= "/* ";
c_expr.expr &:= str(objectCategory);
c_expr.expr &:= ": ";
create_name2(current_object, c_expr.expr);
c_expr.expr &:= " */\n";
end if;
end func;
const proc: replaceLocalsFromOutside (in reference: local_function,
inout reference: current_expression, in ref_list: local_objects,
inout ref_list: additional_act_params, inout ref_list: additional_form_params) is func
local
var ref_list: params is ref_list.EMPTY;
var integer: paramNum is 0;
var reference: aParam is NIL;
var category: paramCategory is category.value;
var reference: formalRefParam is NIL;
begin
params := getValue(current_expression, ref_list);
for paramNum range 2 to length(params) do
aParam := params[paramNum];
paramCategory := category(aParam);
if paramCategory = MATCHOBJECT or paramCategory = CALLOBJECT then
replaceLocalsFromOutside(local_function, aParam, local_objects,
additional_act_params, additional_form_params);
elsif paramCategory = LOCALVOBJECT or
paramCategory = VALUEPARAMOBJECT or
paramCategory = REFPARAMOBJECT or
paramCategory = RESULTOBJECT then
if aParam not in local_objects then
if aParam in additional_act_params then
formalRefParam := additional_form_params[pos(additional_act_params, aParam)];
elsif local_function in params_added and
aParam in params_added[local_function] then
formalRefParam := params_added[local_function][aParam];
else
additional_act_params &:= make_list(aParam);
formalRefParam := alloc(aParam);
setCategory(formalRefParam, REFPARAMOBJECT);
additional_form_params &:= make_list(formalRefParam);
end if;
params @:= [paramNum] formalRefParam;
end if;
end if;
end for;
setValue(current_expression, params);
end func;
const proc: changeCallsOfLocalFunction (inout reference: current_expression,
in reference: local_function, in ref_list: additional_params) is func
local
var ref_list: params is ref_list.EMPTY;
var integer: paramNum is 0;
var reference: aParam is NIL;
var category: paramCategory is category.value;
begin
params := getValue(current_expression, ref_list);
for paramNum range 2 to length(params) do
aParam := params[paramNum];
paramCategory := category(aParam);
if paramCategory = MATCHOBJECT or paramCategory = CALLOBJECT then
changeCallsOfLocalFunction(aParam, local_function, additional_params);
elsif aParam = local_function then
aParam := alloc(aParam);
setCategory(aParam, MATCHOBJECT);
setValue(aParam, make_list(params[paramNum]) & additional_params);
params @:= [paramNum] aParam;
setValue(current_expression, params);
end if;
end for;
if params[1] = local_function then
params &:= additional_params;
setValue(current_expression, params);
end if;
end func;
const proc: changeCallsFromSubFunctions (in reference: parent_function,
in reference: local_function, in ref_list: additional_params) is func
local
var reference: parent_body is NIL;
var reference: obj is NIL;
begin
if parent_function <> local_function then
parent_body := body(parent_function);
changeCallsOfLocalFunction(parent_body, local_function, additional_params);
end if;
for obj range localConsts(parent_function) do
if category(obj) = BLOCKOBJECT then
changeCallsFromSubFunctions(obj, local_function, additional_params);
end if;
end for;
end func;
const proc: adjustParamsToAdd (in reference: local_function,
inout ref_list: additional_act_params, inout ref_list: additional_form_params) is func
local
var integer: paramNum is 0;
var reference: actParam is NIL;
var reference: formParam is NIL;
begin
if length(additional_act_params) <> 0 then
if local_function not in params_added then
params_added @:= [local_function] act_to_form_param_hash.value;
end if;
paramNum := 1;
while paramNum <= length(additional_act_params) do
actParam := additional_act_params[paramNum];
if actParam in params_added[local_function] then
additional_act_params := additional_act_params[.. pred(paramNum)] &
additional_act_params[succ(paramNum) ..];
additional_form_params := additional_form_params[.. pred(paramNum)] &
additional_form_params[succ(paramNum) ..];
else
incr(paramNum);
end if;
end while;
for paramNum range 1 to length(additional_act_params) do
actParam := additional_act_params[paramNum];
formParam := additional_form_params[paramNum];
if actParam not in params_added[local_function] then
params_added[local_function] @:= [actParam] formParam;
end if;
end for;
end if;
end func;
const func boolean: fixLocalFunction (in reference: parent_function,
in reference: local_function) is func
result
var boolean: fix_done is FALSE;
local
var reference: body_expression is NIL;
var category: bodyCategory is category.value;
var ref_list: local_objects is ref_list.EMPTY;
var ref_list: additional_act_params is ref_list.EMPTY;
var ref_list: additional_form_params is ref_list.EMPTY;
begin
body_expression := body(local_function);
bodyCategory := category(body_expression);
if bodyCategory = MATCHOBJECT or bodyCategory = CALLOBJECT then
local_objects := formalParams(local_function) & localVars(local_function) &
make_list(resultVar(local_function));
replaceLocalsFromOutside(local_function, body_expression, local_objects,
additional_act_params, additional_form_params);
adjustParamsToAdd(local_function, additional_act_params, additional_form_params);
if length(additional_act_params) <> 0 then
setFormalParams(local_function, formalParams(local_function) & additional_form_params);
changeCallsOfLocalFunction(body_expression, local_function, additional_form_params);
changeCallsFromSubFunctions(parent_function, local_function, additional_act_params);
fix_done := TRUE;
end if;
end if;
end func;
const proc: processLocalFunctions (in reference: current_object) is func
local
var ref_list: objects is ref_list.EMPTY;
var reference: obj is NIL;
var boolean: fix_done is FALSE;
begin
objects := localConsts(current_object);
repeat
fix_done := FALSE;
for obj range objects do
if category(obj) = BLOCKOBJECT then
processLocalFunctions(obj);
if fixLocalFunction(current_object, obj) then
fix_done := TRUE;
end if;
end if;
end for;
until not fix_done;
end func;
const proc: addTypeCategoryForLocalVars (in reference: function) is func
local
var ref_list: objects is ref_list.EMPTY;
var reference: obj is NIL;
var reference: object_value is NIL;
var type: objectType is void;
var category: valueCategory is category.value;
begin
objects := localVars(function);
for obj range objects do
object_value := getValue(obj, reference);
valueCategory := category(object_value);
objectType := getType(obj);
if objectType = getType(object_value) and objectType not in typeCategory then
typeCategory @:= [objectType] valueCategory;
end if;
end for;
end func;
const proc: process_local_consts (in reference: function,
inout expr_type: c_expr) is func
local
var ref_list: objects is ref_list.EMPTY;
var reference: obj is NIL;
begin
addTypeCategoryForLocalVars(function);
processLocalFunctions(function);
objects := localConsts(function);
for obj range objects do
if category(obj) <> FWDREFOBJECT then
declare_type_if_necessary(getType(obj), global_c_expr);
end if;
process_object_declaration(obj, c_expr);
end for;
end func;
const proc: process_object (in reference: current_object) is func
local
var expr_type: c_expr is expr_type.value;
begin
write_object_declaration := TRUE;
process_object_declaration(current_object, c_expr);
write(c_prog, global_c_expr.expr);
if write_object_declaration then
write(c_prog, c_expr.expr);
end if;
flush(c_prog);
global_c_expr := expr_type.value;
end func;
const proc: process_library_import_object (in reference: current_object) is func
local
var expr_type: c_expr is expr_type.value;
begin
process_object_declaration(current_object, c_expr);
global_c_expr := expr_type.value;
end func;
const proc: write_file_head is func
begin
writeln(c_prog, temp_marker);
writeln(c_prog, "#include <stdlib.h>");
writeln(c_prog, "#include <stdio.h>");
writeln(c_prog, "#include <string.h>");
writeln(c_prog, "#include <math.h>");
writeln(c_prog, "#include <setjmp.h>");
writeln(c_prog, "#include <signal.h>");
writeln(c_prog, "typedef short int int16Type;");
writeln(c_prog, "typedef unsigned short int uint16Type;");
writeln(c_prog, "typedef " <& ccConf.INT32TYPE <& " int32Type;");
writeln(c_prog, "typedef " <& ccConf.UINT32TYPE <& " uint32Type;");
writeln(c_prog, "typedef " <& ccConf.INT64TYPE <& " int64Type;");
writeln(c_prog, "typedef " <& ccConf.UINT64TYPE <& " uint64Type;");
if ccConf.INT128TYPE <> "" then
writeln(c_prog, "typedef " <& ccConf.INT128TYPE <& " int128Type;");
writeln(c_prog, "typedef " <& ccConf.UINT128TYPE <& " uint128Type;");
end if;
if ccConf.TWOS_COMPLEMENT_INTTYPE then
writeln(c_prog, "#define INT32TYPE_MIN ((int32Type) -2147483648" <&
ccConf.INT32TYPE_LITERAL_SUFFIX <& ")");
else
writeln(c_prog, "#define INT32TYPE_MIN (-2147483647" <&
ccConf.INT32TYPE_LITERAL_SUFFIX <& ")");
end if;
writeln(c_prog, "#define INT32TYPE_MAX 2147483647" <&
ccConf.INT32TYPE_LITERAL_SUFFIX);
if ccConf.INTTYPE_SIZE = 64 then
writeln(c_prog, "#define INTTYPE_DECIMAL_SIZE 20");
writeln(c_prog, "typedef int64Type intType;");
writeln(c_prog, "typedef uint64Type uintType;");
if ccConf.INT128TYPE <> "" then
writeln(c_prog, "typedef int128Type doubleIntType;");
writeln(c_prog, "typedef uint128Type doubleUintType;");
writeln(c_prog, "#define inIntTypeRange(num) ((doubleIntType) (intType) (num) == (num))");
end if;
elsif ccConf.INTTYPE_SIZE = 32 then
writeln(c_prog, "#define INTTYPE_DECIMAL_SIZE 11");
writeln(c_prog, "typedef int32Type intType;");
writeln(c_prog, "typedef uint32Type uintType;");
writeln(c_prog, "typedef int64Type doubleIntType;");
writeln(c_prog, "typedef uint64Type doubleUintType;");
writeln(c_prog, "#define inIntTypeRange(num) ((doubleIntType) (intType) (num) == (num))");
end if;
writeln(c_prog, "typedef " <& ccConf.BOOLTYPE <& " boolType;");
writeln(c_prog, "typedef int enumType;");
if ccConf.FLOATTYPE_DOUBLE then
writeln(c_prog, "typedef double floatType;");
else
writeln(c_prog, "typedef float floatType;");
end if;
writeln(c_prog, "typedef uint32Type charType;");
writeln(c_prog, "typedef int32Type scharType;");
writeln(c_prog, "typedef uint32Type strElemType;");
writeln(c_prog, "typedef uintType bitSetType;");
writeln(c_prog, "typedef uint" <& ccConf.POINTER_SIZE <& "Type memSizeType;");
writeln(c_prog, "typedef FILE *cFileType;");
writeln(c_prog, "typedef unsigned char *ustriType;");
writeln(c_prog, "typedef const unsigned char *const_ustriType;");
writeln(c_prog, "typedef struct striStruct {");
writeln(c_prog, " memSizeType size;");
if ccConf.WITH_STRI_CAPACITY then
writeln(c_prog, " memSizeType capacity;");
end if;
if ccConf.ALLOW_STRITYPE_SLICES then
writeln(c_prog, " strElemType *mem;");
writeln(c_prog, " strElemType mem1[1];");
else
writeln(c_prog, " strElemType mem[1];");
end if;
writeln(c_prog, "} *striType;");
writeln(c_prog, "typedef const struct striStruct *const_striType;");
writeln(c_prog, "#define SIZ_STRI(len) ((sizeof(struct striStruct) - sizeof(strElemType)) + (len) * sizeof(strElemType))");
writeln(c_prog, "typedef struct bstriStruct {");
writeln(c_prog, " memSizeType size;");
if ccConf.ALLOW_BSTRITYPE_SLICES then
writeln(c_prog, " unsigned char *mem;");
writeln(c_prog, " unsigned char mem1[1];");
else
writeln(c_prog, " unsigned char mem[1];");
end if;
writeln(c_prog, "} *bstriType;");
writeln(c_prog, "typedef const struct bstriStruct *const_bstriType;");
writeln(c_prog, "typedef struct fileStruct {");
writeln(c_prog, " cFileType cFile;");
writeln(c_prog, " uintType usage_count;");
writeln(c_prog, "} *fileType;");
writeln(c_prog, "typedef const struct fileStruct *const_fileType;");
writeln(c_prog, "typedef struct setStruct {");
writeln(c_prog, " intType min_position;");
writeln(c_prog, " intType max_position;");
writeln(c_prog, " bitSetType bitset[1];");
writeln(c_prog, "} *setType;");
writeln(c_prog, "typedef const struct setStruct *const_setType;");
writeln(c_prog, "typedef struct {");
writeln(c_prog, " int dummy;");
writeln(c_prog, "} bigIntRecord;");
writeln(c_prog, "typedef bigIntRecord *bigIntType;");
writeln(c_prog, "typedef const bigIntRecord *const_bigIntType;");
writeln(c_prog, "typedef struct pollStruct {");
writeln(c_prog, " int dummy;");
writeln(c_prog, "} *pollType;");
writeln(c_prog, "typedef const struct pollStruct *const_pollType;");
writeln(c_prog, "typedef struct winStruct {");
writeln(c_prog, " uintType usage_count;");
writeln(c_prog, "} *winType;");
writeln(c_prog, "typedef const struct winStruct *const_winType;");
writeln(c_prog, "typedef struct processStruct {");
writeln(c_prog, " uintType usage_count;");
writeln(c_prog, " fileType stdIn;");
writeln(c_prog, " fileType stdOut;");
writeln(c_prog, " fileType stdErr;");
writeln(c_prog, "} *processType;");
writeln(c_prog, "typedef const struct processStruct *const_processType;");
writeln(c_prog, "typedef struct databaseStruct {");
writeln(c_prog, " uintType usage_count;");
writeln(c_prog, "} *databaseType;");
writeln(c_prog, "typedef const struct databaseStruct *const_databaseType;");
writeln(c_prog, "typedef struct sqlStmtStruct {");
writeln(c_prog, " uintType usage_count;");
writeln(c_prog, "} *sqlStmtType;");
writeln(c_prog, "typedef const struct sqlStmtStruct *const_sqlStmtType;");
writeln(c_prog, "typedef struct progStruct {");
writeln(c_prog, " uintType usage_count;");
writeln(c_prog, "} *progType;");
writeln(c_prog, "typedef const struct progStruct *const_progType;");
writeln(c_prog, "typedef struct typeStruct *typeType;");
writeln(c_prog, "typedef const struct typeStruct *const_typeType;");
writeln(c_prog, "typedef struct rtlArrayStruct *arrayType;");
writeln(c_prog, "typedef const struct rtlArrayStruct *const_arrayType;");
writeln(c_prog, "typedef struct rtlHashStruct *hashType;");
writeln(c_prog, "typedef const struct rtlHashStruct *const_hashType;");
writeln(c_prog, "typedef struct rtlStructStruct *structType;");
writeln(c_prog, "typedef const struct rtlStructStruct *const_structType;");
writeln(c_prog, "typedef struct rtlStructStruct *interfaceType;");
writeln(c_prog, "typedef const struct rtlStructStruct *const_interfaceType;");
writeln(c_prog, "typedef struct objectStruct *objRefType;");
writeln(c_prog, "typedef const struct objectStruct *const_objRefType;");
writeln(c_prog, "typedef struct listStruct *listType;");
writeln(c_prog, "typedef const struct listStruct *const_listType;");
writeln(c_prog, "typedef objRefType (*actType) (listType);");
writeln(c_prog, "typedef int socketType;");
writeln(c_prog, "typedef uint" <& ccConf.GENERIC_SIZE <& "Type genericType;");
writeln(c_prog, "typedef union {");
writeln(c_prog, " genericType genericValue;");
writeln(c_prog, " typeType typeValue;");
writeln(c_prog, " boolType boolValue;");
writeln(c_prog, " enumType enumValue;");
writeln(c_prog, " intType intValue;");
writeln(c_prog, " bigIntType bigIntValue;");
writeln(c_prog, " floatType floatValue;");
writeln(c_prog, " charType charValue;");
writeln(c_prog, " striType striValue;");
writeln(c_prog, " bstriType bstriValue;");
writeln(c_prog, " fileType fileValue;");
writeln(c_prog, " socketType socketValue;");
writeln(c_prog, " pollType pollValue;");
writeln(c_prog, " setType setValue;");
writeln(c_prog, " winType winValue;");
writeln(c_prog, " processType processValue;");
writeln(c_prog, " progType progValue;");
writeln(c_prog, " databaseType databaseValue;");
writeln(c_prog, " sqlStmtType sqlStmtValue;");
writeln(c_prog, " arrayType arrayValue;");
writeln(c_prog, " hashType hashValue;");
writeln(c_prog, " structType structValue;");
writeln(c_prog, " interfaceType interfaceValue;");
writeln(c_prog, " objRefType objRefValue;");
writeln(c_prog, " listType listValue;");
writeln(c_prog, " actType actValue;");
writeln(c_prog, "} rtlValueUnion;");
writeln(c_prog, "typedef union {");
writeln(c_prog, " genericType genericValue;");
writeln(c_prog, " const_typeType typeValue;");
writeln(c_prog, " boolType boolValue;");
writeln(c_prog, " enumType enumValue;");
writeln(c_prog, " intType intValue;");
writeln(c_prog, " const_bigIntType bigIntValue;");
writeln(c_prog, " floatType floatValue;");
writeln(c_prog, " charType charValue;");
writeln(c_prog, " const_striType striValue;");
writeln(c_prog, " const_bstriType bstriValue;");
writeln(c_prog, " fileType fileValue;");
writeln(c_prog, " socketType socketValue;");
writeln(c_prog, " const_pollType pollValue;");
writeln(c_prog, " const_setType setValue;");
writeln(c_prog, " const_winType winValue;");
writeln(c_prog, " const_processType processValue;");
writeln(c_prog, " const_progType progValue;");
writeln(c_prog, " const_arrayType arrayValue;");
writeln(c_prog, " const_hashType hashValue;");
writeln(c_prog, " const_structType structValue;");
writeln(c_prog, " const_interfaceType interfaceValue;");
writeln(c_prog, " const_objRefType objRefValue;");
writeln(c_prog, " const_listType listValue;");
writeln(c_prog, " actType actValue;");
writeln(c_prog, "} const_rtlValueUnion;");
writeln(c_prog, "typedef struct rtlObjectStruct {");
writeln(c_prog, " rtlValueUnion value;");
writeln(c_prog, "} rtlObjectType;");
writeln(c_prog, "typedef const struct rtlObjectStruct const_rtlObjectType;");
writeln(c_prog, "typedef intType (*intfunctype)();");
writeln(c_prog, "typedef uint16Type categoryType;");
writeln(c_prog, "struct objectStruct {");
writeln(c_prog, " typeType type_of;");
writeln(c_prog, " uint" <& ccConf.POINTER_SIZE <& "Type descriptor;");
writeln(c_prog, " rtlValueUnion value;");
writeln(c_prog, " categoryType objcategory;");
writeln(c_prog, "};");
writeln(c_prog, "struct typeStruct {");
writeln(c_prog, " objRefType match_obj;");
writeln(c_prog, " typeType meta;");
writeln(c_prog, " typeType func_type;");
writeln(c_prog, " typeType varfunc_type;");
writeln(c_prog, " typeType result_type;");
writeln(c_prog, " boolType is_varfunc_type;");
writeln(c_prog, " void *interfaces;");
writeln(c_prog, " void *name;");
writeln(c_prog, "};");
writeln(c_prog, "struct listStruct {");
writeln(c_prog, " listType next;");
writeln(c_prog, " objRefType obj;");
writeln(c_prog, "};");
writeln(c_prog, "struct rtlArrayStruct {");
writeln(c_prog, " intType min_position;");
writeln(c_prog, " intType max_position;");
writeln(c_prog, " rtlObjectType arr[1];");
writeln(c_prog, "};");
writeln(c_prog, "struct rtlStructStruct {");
writeln(c_prog, " memSizeType usage_count;");
writeln(c_prog, " uint32Type type_num;");
writeln(c_prog, " rtlObjectType stru[1];");
writeln(c_prog, "};");
writeln(c_prog, "typedef struct freeListElemStruct {");
writeln(c_prog, " struct freeListElemStruct *next;");
writeln(c_prog, "} *freeListElemType;");
writeln(c_prog, "typedef struct rtlHashElemStruct *hashElemType;");
writeln(c_prog, "typedef const struct rtlHashElemStruct *const_hashElemType;");
writeln(c_prog, "typedef struct rtlHashElemStruct *const hashElemType_const;");
writeln(c_prog, "struct rtlHashElemStruct {");
writeln(c_prog, " hashElemType next_less;");
writeln(c_prog, " hashElemType next_greater;");
writeln(c_prog, " rtlObjectType key;");
writeln(c_prog, " rtlObjectType data;");
writeln(c_prog, "};");
writeln(c_prog, "struct rtlHashStruct {");
writeln(c_prog, " unsigned int bits;");
writeln(c_prog, " unsigned int mask;");
writeln(c_prog, " unsigned int table_size;");
writeln(c_prog, " memSizeType size;");
writeln(c_prog, " hashElemType table[1];");
writeln(c_prog, "};");
writeln(c_prog, "typedef struct hashElemListStruct {");
writeln(c_prog, " struct hashElemListStruct *next;");
writeln(c_prog, " hashElemType obj;");
writeln(c_prog, "} *hashElemListType;");
writeln(c_prog, "typedef union {");
writeln(c_prog, " uint32Type bits;");
writeln(c_prog, " float aFloat;");
writeln(c_prog, "} float2BitsUnion;");
writeln(c_prog, "typedef union {");
writeln(c_prog, " uint64Type bits;");
writeln(c_prog, " double aDouble;");
writeln(c_prog, "} double2BitsUnion;");
writeln(c_prog, "typedef intType (*hashCodeFuncType) (genericType);");
writeln(c_prog, "typedef intType (*compareType) (genericType, genericType);");
writeln(c_prog, "typedef genericType (*createFuncType) (genericType);");
writeln(c_prog, "typedef void (*destrFuncType) (genericType);");
writeln(c_prog, "typedef void (*copyFuncType) (genericType *, genericType);");
writeln(c_prog, "#define bitset_shift " <& log2(ccConf.INTTYPE_SIZE));
writeln(c_prog, "#define bitset_mask ((1 << bitset_shift) - 1)");
if ccConf.RSHIFT_DOES_SIGN_EXTEND then
writeln(c_prog, "#define bitset_pos(number) ((number)>>bitset_shift)");
else
writeln(c_prog, "#define bitset_pos(number) ((number)<0?~(~(number)>>bitset_shift):(number)>>bitset_shift)");
end if;
writeln(c_prog, "striType arg_0;");
writeln(c_prog, "striType programName;");
writeln(c_prog, "striType programPath;");
writeln(c_prog, "arrayType arg_v;");
if ccConf.ALLOW_STRITYPE_SLICES then
writeln(c_prog, "extern struct striStruct str[];");
else
writeln(c_prog, "extern striType str[];");
end if;
if ccConf.ALLOW_BSTRITYPE_SLICES then
writeln(c_prog, "extern struct bstriStruct bst[];");
else
writeln(c_prog, "extern bstriType bst[];");
end if;
writeln(c_prog, "extern setType set[];");
writeln(c_prog, "extern typeType typ[];");
writeln(c_prog, "extern double2BitsUnion nanValue[];");
writeln(c_prog, "bigIntType *big;");
writeln(c_prog, "winType *win;");
writeln(c_prog, "bstriType *plist;");
writeln(c_prog, "arrayType *arr;");
writeln(c_prog, "structType *sct;");
writeln(c_prog, "hashType *hsh;");
writeln(c_prog, "interfaceType *itf;");
writeln(c_prog, "hashType *caseLabels;");
writeln(c_prog, "rtlValueUnion flt2int;");
writeln(c_prog, "extern memSizeType hs;");
writeln(c_prog);
writeln(c_prog, "static const intType fact[] = {");
writeln(c_prog, " 1, 1, 2, 6, 24, 120, 720, 5040, 40320,");
writeln(c_prog, " 362880, 3628800, 39916800, 479001600,");
if ccConf.INTTYPE_SIZE = 64 then
writeln(c_prog, " 6227020800, 87178291200, 1307674368000, 20922789888000,");
writeln(c_prog, " 355687428096000, 6402373705728000, 121645100408832000,");
writeln(c_prog, " 2432902008176640000");
end if;
writeln(c_prog, " };");
if ccConf.FLOAT_ZERO_DIV_ERROR then
writeln(c_prog, "extern const rtlValueUnion f_const[];");
writeln(c_prog, "#define NOT_A_NUMBER f_const[0].floatValue");
writeln(c_prog, "#define POSITIVE_INFINITY f_const[1].floatValue");
writeln(c_prog, "#define NEGATIVE_INFINITY f_const[2].floatValue");
else
writeln(c_prog, "#define NOT_A_NUMBER ( 0.0 / 0.0)");
writeln(c_prog, "#define POSITIVE_INFINITY ( 1.0 / 0.0)");
writeln(c_prog, "#define NEGATIVE_INFINITY (-1.0 / 0.0)");
end if;
writeln(c_prog, "extern const floatType negativeZero;");
writeln(c_prog, "extern struct fileStruct nullFileRecord;");
writeln(c_prog, "extern struct fileStruct stdinFileRecord;");
writeln(c_prog, "extern struct fileStruct stdoutFileRecord;");
writeln(c_prog, "extern struct fileStruct stderrFileRecord;");
writeln(c_prog, "typedef int errInfoType;");
writeln(c_prog, "#define OKAY_NO_ERROR 0");
writeln(c_prog, "#define MEMORY_ERROR 1");
writeln(c_prog, "#define NUMERIC_ERROR 2");
writeln(c_prog, "#define OVERFLOW_ERROR 3");
writeln(c_prog, "#define RANGE_ERROR 4");
writeln(c_prog, "#define INDEX_ERROR 5");
writeln(c_prog, "#define FILE_ERROR 6");
writeln(c_prog, "#define DATABSE_ERROR 7");
writeln(c_prog, "#define GRAPHIC_ERROR 8");
writeln(c_prog, "#define ACTION_ERROR 9");
writeln(c_prog, "#define CREATE_ERROR 10");
writeln(c_prog, "#define DESTROY_ERROR 11");
writeln(c_prog, "#define COPY_ERROR 12");
writeln(c_prog, "#define IN_ERROR 13");
writeln(c_prog, ccConf.MACRO_DEFS);
writeln(c_prog, "#define ovfChk(x) unlikely(x)");
writeln(c_prog, "#define divChk(x) unlikely(x)");
writeln(c_prog, "#define numChk(x) unlikely(x)");
writeln(c_prog, "#define idxChk(x) unlikely(x)");
writeln(c_prog, "#define rngChk(x) unlikely(x)");
writeln(c_prog, "#define push_stack(stack,elem) \\");
writeln(c_prog, "{\\");
writeln(c_prog, " hashElemListType new_head = (hashElemListType)(malloc(sizeof(struct hashElemListStruct)));\\");
writeln(c_prog, " if (new_head == NULL) {\\");
writeln(c_prog, " raiseError(MEMORY_ERROR);\\");
writeln(c_prog, " } else {\\");
writeln(c_prog, " new_head->next = stack;\\");
writeln(c_prog, " new_head->obj = elem;\\");
writeln(c_prog, " stack = new_head;\\");
writeln(c_prog, " }\\");
writeln(c_prog, "}");
writeln(c_prog, "#define pop_stack(stack,elem) \\");
writeln(c_prog, "{\\");
writeln(c_prog, " hashElemListType old_head = stack;\\");
writeln(c_prog, " if (old_head == NULL) {\\");
writeln(c_prog, " elem = NULL;\\");
writeln(c_prog, " } else {\\");
writeln(c_prog, " stack = old_head->next;\\");
writeln(c_prog, " elem = old_head->obj;\\");
writeln(c_prog, " free(old_head);\\");
writeln(c_prog, " }\\");
writeln(c_prog, "}");
if ccConf.HAS_SIGSETJMP then
writeln(c_prog, "#define do_setjmp(jump_buf) sigsetjmp(jump_buf, 1)");
writeln(c_prog, "typedef sigjmp_buf catch_type;");
else
writeln(c_prog, "#define do_setjmp(jump_buf) setjmp(jump_buf)");
writeln(c_prog, "typedef jmp_buf catch_type;");
end if;
writeln(c_prog, "catch_type *catch_stack;");
writeln(c_prog, "size_t catch_stack_pos;");
writeln(c_prog, "size_t max_catch_stack;");
writeln(c_prog, "const char *error_file = NULL;");
writeln(c_prog, "int error_line = 0;");
if profile_function then
writeln(c_prog, "intType timMicroSec (void);");
writeln(c_prog, "static unsigned int profile_size;");
writeln(c_prog, "struct profileElement {");
writeln(c_prog, " intType time;");
writeln(c_prog, " intType count;");
writeln(c_prog, " intType depth;");
writeln(c_prog, " char *file;");
writeln(c_prog, " intType line;");
writeln(c_prog, " char *name;");
writeln(c_prog, "};");
writeln(c_prog, "static struct profileElement *profile;");
writeln(c_prog, "static void initProfile (void);");
writeln(c_prog, "static int cmpProfileElement (const void *elem1, const void *elem2)");
writeln(c_prog, "{");
writeln(c_prog, " int signumValue;");
writeln(c_prog, " if (((struct profileElement *) elem1)->time <");
writeln(c_prog, " ((struct profileElement *) elem2)->time) {");
writeln(c_prog, " signumValue = 1;");
writeln(c_prog, " } else if (((struct profileElement *) elem1)->time >");
writeln(c_prog, " ((struct profileElement *) elem2)->time) {");
writeln(c_prog, " signumValue = -1;");
writeln(c_prog, " } else if (((struct profileElement *) elem1)->count <");
writeln(c_prog, " ((struct profileElement *) elem2)->count) {");
writeln(c_prog, " signumValue = 1;");
writeln(c_prog, " } else if (((struct profileElement *) elem1)->count >");
writeln(c_prog, " ((struct profileElement *) elem2)->count) {");
writeln(c_prog, " signumValue = -1;");
writeln(c_prog, " } else {");
writeln(c_prog, " signumValue = strcmp(((struct profileElement *) elem1)->name,");
writeln(c_prog, " ((struct profileElement *) elem2)->name);");
writeln(c_prog, " }");
writeln(c_prog, " return signumValue;");
writeln(c_prog, "}");
end if;
end func;
const proc: declareExtern (in string: prototype) is func
begin
write(c_prog, "extern ");
if declare_with_extern_c then
write(c_prog, "\"C\" ");
end if;
writeln(c_prog, prototype);
end func;
const proc: write_prototypes is func
begin
act_prototypes(c_prog);
arr_prototypes(c_prog);
big_prototypes(c_prog);
bin_prototypes(c_prog);
bln_prototypes(c_prog);
bst_prototypes(c_prog);
chr_prototypes(c_prog);
cmd_prototypes(c_prog);
con_prototypes(c_prog);
drw_prototypes(c_prog);
fil_prototypes(c_prog);
flt_prototypes(c_prog);
gkb_prototypes(c_prog);
hsh_prototypes(c_prog);
int_prototypes(c_prog);
itf_prototypes(c_prog);
kbd_prototypes(c_prog);
pcs_prototypes(c_prog);
pol_prototypes(c_prog);
prc_prototypes(c_prog);
prg_prototypes(c_prog);
ref_prototypes(c_prog);
rfl_prototypes(c_prog);
set_prototypes(c_prog);
soc_prototypes(c_prog);
sql_prototypes(c_prog);
str_prototypes(c_prog);
tim_prototypes(c_prog);
typ_prototypes(c_prog);
ut8_prototypes(c_prog);
if ccConf.USE_WMAIN then
declareExtern("arrayType getArgv (const int, wchar_t *const *const, striType *, striType *, striType *);");
else
declareExtern("arrayType getArgv (const int, char *const *const, striType *, striType *, striType *);");
end if;
declareExtern("intType heapsize (void);");
declareExtern("void setupStack (memSizeType);");
declareExtern("void setupFiles (void);");
declareExtern("void setupRand (void);");
declareExtern("void setupFloat (void);");
declareExtern("void setupBig (void);");
declareExtern("void init_primitiv (void);");
writeln(c_prog, "static void prcNoop (void) {}");
writeln(c_prog, "static void init_values (void);");
writeln(c_prog, "static void init_globals (void);");
declareExtern("void initPollOperations (const createFuncType, const destrFuncType);");
declareExtern("void genericCpy (genericType *const, const genericType);");
declareExtern("genericType genericCreate (genericType);");
declareExtern("void genericDestr (genericType);");
declareExtern("intType genericHashCode (genericType);");
declareExtern("intType ptrCmp (const void *const, const void *const);");
declareExtern("intType ptrCmpGeneric (const genericType, const genericType);");
declareExtern("void ptrCpyGeneric (genericType *const, const genericType);");
declareExtern("genericType ptrCreateGeneric (const genericType);");
declareExtern("intType ptrHashCodeGeneric (const genericType);");
writeln(c_prog, "typedef void (*suspendInterprType) (int signalNum);");
declareExtern("void setupSignalHandlers (boolType, boolType, boolType, boolType, suspendInterprType);");
declareExtern("void triggerSigfpe (void);");
declareExtern("void rtlRaiseError (int, const char *, int) NORETURN;");
writeln(c_prog, "#define raiseError(num) rtlRaiseError(num, __FILE__, __LINE__)");
writeln(c_prog, "#define intRaiseError(num) (rtlRaiseError(num, __FILE__, __LINE__), 0)");
writeln(c_prog, "#define bigRaiseError(num) (bigIntType)(rtlRaiseError(num, __FILE__, __LINE__), NULL)");
writeln(c_prog, "#define strRaiseError(num) (striType)(rtlRaiseError(num, __FILE__, __LINE__), NULL)");
writeln(c_prog, "#define refRaiseError(num) (objRefType)(rtlRaiseError(num, __FILE__, __LINE__), NULL)");
if trace_signal then
writeln(c_prog, "#define filGetc(inFile) filGetcChkCtrlC(inFile)");
writeln(c_prog, "#define filGets(inFile, length) filGetsChkCtrlC(inFile, length)");
writeln(c_prog, "#define filHasNext(inFile) filHasNextChkCtrlC(inFile)");
writeln(c_prog, "#define filLineRead(inFile, terminationChar) filLineReadChkCtrlC(inFile, terminationChar)");
writeln(c_prog, "#define filWordRead(inFile, terminationChar) filWordReadChkCtrlC(inFile, terminationChar)");
else
writeln(c_prog, "#define filGetc(inFile) (unlikely((inFile)->cFile==NULL)?intRaiseError(FILE_ERROR):fgetc((inFile)->cFile))");
end if;
if ccConf.USE_DO_EXIT then
writeln(c_prog, "void doExit (int returnCode);");
else
writeln(c_prog, "#define doExit(returnCode) exit(returnCode)");
end if;
end func;
const proc: write_resize_catch_stack is func
begin
writeln(c_prog);
writeln(c_prog);
writeln(c_prog, "static void resize_catch_stack (void)");
writeln(c_prog);
writeln(c_prog, " {");
writeln(c_prog, " catch_type *resized_stack;");
writeln(c_prog);
writeln(c_prog, " max_catch_stack += 128;");
writeln(c_prog, " resized_stack = (catch_type *)(realloc(catch_stack, max_catch_stack * sizeof(catch_type)));");
writeln(c_prog, " if (resized_stack == NULL) {");
writeln(c_prog, " catch_stack_pos--;");
writeln(c_prog, " raiseError(MEMORY_ERROR);");
writeln(c_prog, " } else {");
writeln(c_prog, " catch_stack = resized_stack;");
writeln(c_prog, " }");
writeln(c_prog, " }");
writeln(c_prog);
writeln(c_prog);
end func;
const proc: initPollOperations (inout expr_type: c_expr) is func
begin
if fileInterfaceType <> void then
c_expr.expr &:= "initPollOperations((createFuncType)(&itfCreate), ";
process_destr_declaration(fileInterfaceType, global_c_expr);
c_expr.expr &:= "(destrFuncType)(&destr_";
c_expr.expr &:= str(typeNumber(fileInterfaceType));
c_expr.expr &:= "));\n";
end if;
end func;
const func ref_list: determine_multiple_array_elements (in ref_list: array_list) is func
result
var ref_list: elements_to_walk is ref_list.EMPTY;
local
var reference: element is NIL;
var reference: previous_element is NIL;
var reference: repeat_block_element is NIL;
var integer: repeat_count is 0;
begin
for element range array_list do
if previous_element <> NIL then
if identical_values(previous_element, element) then
if repeat_block_element = NIL then
repeat_block_element := previous_element;
repeat_count := 2;
else
incr(repeat_count);
end if;
else
elements_to_walk &:= make_list(element);
if repeat_block_element <> NIL then
element_repeat_count @:= [repeat_block_element] repeat_count;
repeat_block_element := NIL;
end if;
end if;
else
elements_to_walk &:= make_list(element);
end if;
previous_element := element;
end for;
if repeat_block_element <> NIL then
element_repeat_count @:= [repeat_block_element] repeat_count;
end if;
end func;
const proc: walk_const_list (in ref_list: const_list, inout ref_list: sorted_list) is func
local
var reference: current_object is NIL;
var reference: struct_of_interface is NIL;
var category: objectCategory is category.value;
var ref_list: elements_to_walk is ref_list.EMPTY;
var pointList: aPointList is pointList.value;
begin
for current_object range const_list do
objectCategory := category(current_object);
if objectCategory = BIGINTOBJECT then
if getValue(current_object, bigInteger) not in bigint_const_table then
bigint_const_table @:= [getValue(current_object, bigInteger)] length(bigint_const_table);
end if;
elsif objectCategory = STRIOBJECT then
if getValue(current_object, string) not in stri_const_table then
stri_const_table @:= [getValue(current_object, string)] length(stri_const_table);
end if;
elsif objectCategory = BSTRIOBJECT then
if getValue(current_object, bstring) not in bstri_const_table then
bstri_const_table @:= [getValue(current_object, bstring)] length(bstri_const_table);
end if;
elsif objectCategory = SETOBJECT then
if getValue(current_object, bitset) not in set_const_table then
set_const_table @:= [getValue(current_object, bitset)] length(set_const_table);
end if;
elsif objectCategory = WINOBJECT then
if getValue(current_object, PRIMITIVE_WINDOW) not in win_const_table then
win_const_table @:= [getValue(current_object, PRIMITIVE_WINDOW)] length(win_const_table);
end if;
elsif objectCategory = POINTLISTOBJECT then
aPointList := getValue(current_object, pointList);
if aPointList not in plist_const_table then
plist_const_table @:= [aPointList] length(plist_const_table);
end if;
elsif objectCategory = ARRAYOBJECT then
if current_object not in const_table then
const_table @:= [current_object] length(const_table);
end if;
elements_to_walk := determine_multiple_array_elements(arrayToList(current_object));
walk_const_list(elements_to_walk, sorted_list);
sorted_list &:= make_list(current_object);
elsif objectCategory = STRUCTOBJECT then
if current_object not in const_table then
const_table @:= [current_object] length(const_table);
end if;
walk_const_list(structToList(current_object), sorted_list);
sorted_list &:= make_list(current_object);
elsif objectCategory = HASHOBJECT then
if current_object not in const_table then
const_table @:= [current_object] length(const_table);
end if;
walk_const_list(hashKeysToList(current_object), sorted_list);
walk_const_list(hashDataToList(current_object), sorted_list);
sorted_list &:= make_list(current_object);
elsif objectCategory = INTERFACEOBJECT then
if current_object not in const_table then
const_table @:= [current_object] length(const_table);
end if;
struct_of_interface := interfaceToStruct(current_object);
if struct_of_interface not in const_table then
const_table @:= [struct_of_interface] length(const_table);
walk_const_list(structToList(struct_of_interface), sorted_list);
sorted_list &:= make_list(struct_of_interface);
elsif const_table[struct_of_interface] >= const_table[current_object] then
sorted_list &:= make_list(struct_of_interface);
end if;
sorted_list &:= make_list(current_object);
elsif objectCategory = MATCHOBJECT or objectCategory = ACTOBJECT or
objectCategory = BLOCKOBJECT then
if current_object not in const_table then
const_table @:= [current_object] length(const_table);
end if;
sorted_list &:= make_list(current_object);
end if;
end for;
end func;
const proc: prepare_func_literal (in reference: current_object,
inout expr_type: c_expr) is func
local
var expr_type: c_value is expr_type.value;
var string: valueName is "";
begin
create_name(current_object, objNumber(current_object), valueName);
processFuncValue(valueName, getType(current_object), current_object, c_value);
global_c_expr.expr &:= c_value.temp_decls;
global_init.expr &:= diagnosticLine(current_object);
global_init.expr &:= c_value.temp_assigns;
function_declared @:= [current_object] TRUE;
end func;
const proc: process_func_literal (in reference: current_object,
inout expr_type: c_expr) is func
local
var string: valueName is "";
begin
create_name(current_object, objNumber(current_object), valueName);
c_expr.expr &:= "&funcvalue_";
c_expr.expr &:= valueName;
end func;
const proc: process_pollData_literal (in var pollData: aPollData,
inout expr_type: c_expr) is func
begin
c_expr.expr &:= "polEmpty()";
end func;
const proc: init_const_value (in reference: current_object, inout expr_type: c_expr) is func
local
var category: objectCategory is category.value;
begin
objectCategory := category(current_object);
if objectCategory = INTOBJECT then
c_expr.expr &:= ".value.intValue=";
c_expr.expr &:= integerLiteral(getValue(current_object, integer));
elsif objectCategory = BIGINTOBJECT then
c_expr.expr &:= ".value.bigIntValue=";
c_expr.expr &:= bigIntegerLiteral(getValue(current_object, bigInteger));
elsif objectCategory = CHAROBJECT then
c_expr.expr &:= ".value.charValue=";
c_expr.expr &:= charLiteral(getValue(current_object, char));
elsif objectCategory = STRIOBJECT then
c_expr.expr &:= ".value.striValue=";
c_expr.expr &:= stringLiteral(getValue(current_object, string));
elsif objectCategory = BSTRIOBJECT then
c_expr.expr &:= ".value.bstriValue=";
c_expr.expr &:= bstriLiteral(getValue(current_object, bstring));
elsif objectCategory = SETOBJECT then
c_expr.expr &:= ".value.setValue=";
c_expr.expr &:= bitsetLiteral(getValue(current_object, bitset));
elsif objectCategory = FLOATOBJECT then
c_expr.expr &:= ".value.floatValue=";
c_expr.expr &:= floatLiteral(getValue(current_object, float));
elsif objectCategory = REFOBJECT then
c_expr.expr &:= ".value.objRefValue=";
if getValue(current_object, reference) = NIL then
c_expr.expr &:= "NULL";
else
c_expr.expr &:= "(objRefType)(&(";
process_expr(getValue(current_object, reference), c_expr);
c_expr.expr &:= "))";
end if;
elsif objectCategory = REFLISTOBJECT then
c_expr.expr &:= ".value.listValue=NULL";
elsif objectCategory = FILEOBJECT then
c_expr.expr &:= ".value.fileValue=&";
c_expr.expr &:= lower(literal(getValue(current_object, clib_file)));
c_expr.expr &:= "FileRecord";
elsif objectCategory = SOCKETOBJECT then
c_expr.expr &:= ".value.intValue=";
c_expr.expr &:= "-1";
elsif objectCategory = POLLOBJECT then
c_expr.expr &:= ".value.pollValue=";
process_pollData_literal(getValue(current_object, pollData), c_expr);
elsif objectCategory = WINOBJECT then
c_expr.expr &:= ".value.winValue=drwCreate(";
c_expr.expr &:= windowLiteral(getValue(current_object, PRIMITIVE_WINDOW));
c_expr.expr &:= ")";
elsif objectCategory = POINTLISTOBJECT then
c_expr.expr &:= ".value.bstriValue=";
c_expr.expr &:= pointListLiteral(getValue(current_object, pointList));
elsif objectCategory = PROCESSOBJECT then
c_expr.expr &:= ".value.processValue=";
c_expr.expr &:= "NULL";
elsif objectCategory = PROGOBJECT then
c_expr.expr &:= ".value.progValue=";
c_expr.expr &:= "NULL";
elsif objectCategory = TYPEOBJECT then
c_expr.expr &:= ".value.typeValue=";
c_expr.expr &:= typeLiteral(getValue(current_object, type));
elsif objectCategory = CONSTENUMOBJECT then
c_expr.expr &:= select_value_from_rtlObjectStruct(
getType(getValue(current_object, reference)));
c_expr.expr &:= "=";
c_expr.expr &:= enum_value(getValue(current_object, reference));
elsif objectCategory = VARENUMOBJECT then
c_expr.expr &:= select_value_from_rtlObjectStruct(
getType(getValue(current_object, reference)));
c_expr.expr &:= "=";
c_expr.expr &:= enum_value(getValue(current_object, reference));
elsif objectCategory = ARRAYOBJECT then
c_expr.expr &:= ".value.arrayValue=";
c_expr.expr &:= "arr[";
c_expr.expr &:= str(const_table[current_object]);
c_expr.expr &:= "]";
elsif objectCategory = STRUCTOBJECT then
c_expr.expr &:= ".value.structValue=";
c_expr.expr &:= "sct[";
c_expr.expr &:= str(const_table[current_object]);
c_expr.expr &:= "]";
elsif objectCategory = HASHOBJECT then
c_expr.expr &:= ".value.hashValue=";
c_expr.expr &:= "hsh[";
c_expr.expr &:= str(const_table[current_object]);
c_expr.expr &:= "]";
elsif objectCategory = INTERFACEOBJECT then
c_expr.expr &:= ".value.interfaceValue=itfCreate(itf[";
c_expr.expr &:= str(const_table[current_object]);
c_expr.expr &:= "])";
elsif objectCategory = MATCHOBJECT or objectCategory = ACTOBJECT or
objectCategory = BLOCKOBJECT then
c_expr.expr &:= ".value.genericValue=";
process_func_literal(current_object, c_expr);
elsif objectCategory = DATABASEOBJECT then
c_expr.expr &:= ".value.databaseValue=NULL";
elsif objectCategory = SQLSTMTOBJECT then
c_expr.expr &:= ".value.sqlStmtValue=NULL";
else
c_expr.expr &:= "/* ";
c_expr.expr &:= str(objectCategory);
c_expr.expr &:= " */";
end if;
end func;
const func string: int32AsFourBytes (in integer: number) is func
result
var string: stri is "";
begin
if ccConf.LITTLE_ENDIAN_INTTYPE then
stri := bytes(number, UNSIGNED, LE, 4);
else
stri := bytes(number, UNSIGNED, BE, 4);
end if;
end func;
const func string: int64AsEightBytes (in integer: number) is func
result
var string: stri is "";
begin
if ccConf.LITTLE_ENDIAN_INTTYPE then
stri := bytes(number, UNSIGNED, LE, 8);
else
stri := bytes(number, UNSIGNED, BE, 8);
end if;
end func;
const func string: int64AsTwoInt32 (in bigInteger: number) is func
result
var string: literals is "";
begin
if ccConf.LITTLE_ENDIAN_INTTYPE then
literals := str( number mod 16#100000000_) &
"," &
str((number >> 32) mod 16#100000000_) &
",";
else
literals := str((number >> 32) mod 16#100000000_) &
"," &
str( number mod 16#100000000_) &
",";
end if;
end func;
const proc: init_bigint_constants is func
local
var bigint_index_hash: bigint_index is bigint_index_hash.EMPTY_HASH;
var integer: number is 0;
var bstring: bstri is bstring.value;
begin
bigint_index := flip(bigint_const_table);
for number range sort(keys(bigint_index)) do
bstri := bStriLe(bigint_index[number][1], TRUE);
if bstri not in bstri_const_table then
bstri_const_table @:= [bstri] length(bstri_const_table);
end if;
bigint_bstri_table @:= [number] bstri_const_table[bstri];
end for;
end func;
const proc: assign_bigint_constants (inout expr_type: c_expr) is func
local
var bigint_index_hash: bigint_index is bigint_index_hash.EMPTY_HASH;
var bigInteger: big1 is bigInteger.value;
var integer: number is 0;
begin
if length(bigint_const_table) = 0 then
c_expr.expr &:= "big = NULL;\n";
else
c_expr.expr &:= "big = (bigIntType *)(malloc(";
c_expr.expr &:= str(length(bigint_const_table));
c_expr.expr &:= " * sizeof(bigIntType)));\n";
bigint_index := flip(bigint_const_table);
for number range sort(keys(bigint_index)) do
big1 := bigint_index[number][1];
c_expr.expr &:= "big[";
c_expr.expr &:= str(number);
c_expr.expr &:= "]=bigFromBStriLe(";
if ccConf.ALLOW_BSTRITYPE_SLICES then
c_expr.expr &:= "&";
end if;
c_expr.expr &:= "bst[";
c_expr.expr &:= str(bigint_bstri_table[number]);
c_expr.expr &:= "], 1);";
if bitLength(big1) <= MAX_SHOWN_BIGINT_LITERAL_BITLENGTH then
c_expr.expr &:= " /* ";
c_expr.expr &:= str(big1);
c_expr.expr &:= " */";
end if;
c_expr.expr &:= "\n";
end for;
end if;
end func;
const func boolean: pixelEncodingIdentical is
return ord(colorPixel(color(65535, 0, 0))) =
ccConf.PIXEL_RED_MASK + ccConf.PIXEL_ALPHA_MASK and
ord(colorPixel(color( 0, 65535, 0))) =
ccConf.PIXEL_GREEN_MASK + ccConf.PIXEL_ALPHA_MASK and
ord(colorPixel(color( 0, 0, 65535))) =
ccConf.PIXEL_BLUE_MASK + ccConf.PIXEL_ALPHA_MASK;
const func boolean: pixelEncodingWithoutAlphaChannel is
return ccConf.PIXEL_ALPHA_MASK <> 0 and
ord(colorPixel(color(65535, 0, 0))) = ccConf.PIXEL_RED_MASK and
ord(colorPixel(color( 0, 65535, 0))) = ccConf.PIXEL_GREEN_MASK and
ord(colorPixel(color( 0, 0, 65535))) = ccConf.PIXEL_BLUE_MASK;
const func boolean: pixelEncodingWithRedAndBlueSwapped is
return ord(colorPixel(color(65535, 0, 0))) =
ccConf.PIXEL_BLUE_MASK + ccConf.PIXEL_ALPHA_MASK and
ord(colorPixel(color( 0, 65535, 0))) =
ccConf.PIXEL_GREEN_MASK + ccConf.PIXEL_ALPHA_MASK and
ord(colorPixel(color( 0, 0, 65535))) =
ccConf.PIXEL_RED_MASK + ccConf.PIXEL_ALPHA_MASK;
const func boolean: pixelEncodingWithRedAndBlueSwappedWithoutAlphaChannel is
return ccConf.PIXEL_ALPHA_MASK <> 0 and
ord(colorPixel(color(65535, 0, 0))) = ccConf.PIXEL_BLUE_MASK and
ord(colorPixel(color( 0, 65535, 0))) = ccConf.PIXEL_GREEN_MASK and
ord(colorPixel(color( 0, 0, 65535))) = ccConf.PIXEL_RED_MASK;
const func bstring: swapRedAndBlue (in bstring: bImage) is func
result
var bstring: swappedImage is bstring.value;
local
var string: image is "";
var integer: index is 0;
var char: aByte is ' ';
begin
image := string(bImage);
if ccConf.LITTLE_ENDIAN_INTTYPE then
for index range 1 to length(image) step 4 do
aByte := image[index];
image @:= [index] image[index + 2];
image @:= [index + 2] aByte;
end for;
else
for index range 1 to length(image) step 4 do
aByte := image[index + 1];
image @:= [index + 1] image[index + 3];
image @:= [index + 3] aByte;
end for;
end if;
swappedImage := bstring(image);
end func;
const func bstring: fixPixels (in var array array pixel: pixelArray) is func
result
var bstring: swappedImageData is bstring.value;
local
var integer: redRightShift is 0;
var integer: greenRightShift is 0;
var integer: blueRightShift is 0;
var integer: redLeftShift is 0;
var integer: greenLeftShift is 0;
var integer: blueLeftShift is 0;
var integer: line is 0;
var integer: column is 0;
var color: pixelColor is color.value;
var integer: pixelData is 0;
begin
redRightShift := 16 - (bitLength(ccConf.PIXEL_RED_MASK) - lowestSetBit(ccConf.PIXEL_RED_MASK));
redLeftShift := lowestSetBit(ccConf.PIXEL_RED_MASK);
greenRightShift := 16 - (bitLength(ccConf.PIXEL_GREEN_MASK) - lowestSetBit(ccConf.PIXEL_GREEN_MASK));
greenLeftShift := lowestSetBit(ccConf.PIXEL_GREEN_MASK);
blueRightShift := 16 - (bitLength(ccConf.PIXEL_BLUE_MASK) - lowestSetBit(ccConf.PIXEL_BLUE_MASK));
blueLeftShift := lowestSetBit(ccConf.PIXEL_BLUE_MASK);
for key line range pixelArray do
for column range 1 to length(pixelArray[line]) do
pixelColor := pixelToColor(pixelArray[line][column]);
pixelData := (pixelColor.redLight >> redRightShift << redLeftShift) +
(pixelColor.greenLight >> greenRightShift << greenLeftShift) +
(pixelColor.blueLight >> blueRightShift << blueLeftShift);
pixelArray[line][column] := pixel(pixelData);
end for;
end for;
swappedImageData := getPixelData(pixelArray);
end func;
const proc: init_win_constants is func
local
var win_index_hash: win_index is win_index_hash.EMPTY_HASH;
var PRIMITIVE_WINDOW: win1 is PRIMITIVE_WINDOW.value;
var integer: number is 0;
var bstring: bImage is bstring.value;
begin
win_index := flip(win_const_table);
if length(win_index) <> 0 and (length(win_index) > 1 or
width(win_index[keys(win_index)[1]][1]) <> 0 or
height(win_index[keys(win_index)[1]][1]) <> 0) then
if pixelEncodingIdentical or pixelEncodingWithoutAlphaChannel or
ccConf.PIXEL_RED_MASK = 0 or
ccConf.PIXEL_GREEN_MASK = 0 or
ccConf.PIXEL_BLUE_MASK = 0 then
for number range sort(keys(win_index)) do
win1 := win_index[number][1];
if width(win1) <> 0 or height(win1) <> 0 then
bImage := getPixelData(win1);
if bImage not in bstri_const_table then
bstri_const_table @:= [bImage] length(bstri_const_table);
end if;
win_bstri_table @:= [number] bstri_const_table[bImage];
end if;
end for;
elsif pixelEncodingWithRedAndBlueSwapped or
pixelEncodingWithRedAndBlueSwappedWithoutAlphaChannel then
for number range sort(keys(win_index)) do
win1 := win_index[number][1];
if width(win1) <> 0 or height(win1) <> 0 then
bImage := swapRedAndBlue(getPixelData(win1));
if bImage not in bstri_const_table then
bstri_const_table @:= [bImage] length(bstri_const_table);
end if;
win_bstri_table @:= [number] bstri_const_table[bImage];
end if;
end for;
else
for number range sort(keys(win_index)) do
win1 := win_index[number][1];
if width(win1) <> 0 or height(win1) <> 0 then
bImage := fixPixels(getPixelArray(win1));
if bImage not in bstri_const_table then
bstri_const_table @:= [bImage] length(bstri_const_table);
end if;
win_bstri_table @:= [number] bstri_const_table[bImage];
end if;
end for;
end if;
end if;
end func;
const proc: assign_win_constants (inout expr_type: c_expr) is func
local
var win_index_hash: win_index is win_index_hash.EMPTY_HASH;
var PRIMITIVE_WINDOW: win1 is PRIMITIVE_WINDOW.value;
var integer: number is 0;
begin
if length(win_const_table) = 0 then
c_expr.expr &:= "win = NULL;\n";
else
c_expr.expr &:= "win = (winType *)(malloc(";
c_expr.expr &:= str(length(win_const_table));
c_expr.expr &:= " * sizeof(winType)));\n";
win_index := flip(win_const_table);
for number range sort(keys(win_index)) do
win1 := win_index[number][1];
c_expr.expr &:= "win[";
c_expr.expr &:= str(number);
c_expr.expr &:= "]=";
if width(win1) = 0 and height(win1) = 0 then
c_expr.expr &:= "drwEmpty();\n";
else
c_expr.expr &:= "drwImage((int32Type *)((";
if ccConf.ALLOW_BSTRITYPE_SLICES then
c_expr.expr &:= "&";
end if;
c_expr.expr &:= "bst[";
c_expr.expr &:= str(win_bstri_table[number]);
c_expr.expr &:= "])->mem), ";
c_expr.expr &:= str(width(win1));
c_expr.expr &:= ", ";
c_expr.expr &:= str(height(win1));
c_expr.expr &:= ", 0);\n";
end if;
end for;
end if;
end func;
const func boolean: pointListEncodingIdentical is
return (ccConf.POINT_LIST_INT_SIZE = 16 and not ccConf.POINT_LIST_ABSOLUTE and
bstring(genPointList([] (597, 362, 219, 205))) =
bstring("U\2;j\1;\134;\254;c\255;")) or
(ccConf.POINT_LIST_INT_SIZE = 32 and ccConf.POINT_LIST_ABSOLUTE and
bstring(genPointList([] (597, 362, 219, 205))) =
bstring("U\2;\0;\0;j\1;\0;\0;\219;\0;\0;\0;\205;\0;\0;\0;"));
const func bstring: toPointListAbsolute (in pointList: aPointList) is func
result
var bstring: bstri is bstring("");
local
var array integer: xyArray is 0 times 0;
var integer: xOrY is 0;
var string: pointListData is "";
begin
xyArray := xyArray(aPointList);
if ccConf.POINT_LIST_INT_SIZE = 16 then
if ccConf.LITTLE_ENDIAN_INTTYPE then
for xOrY range xyArray do
pointListData &:= bytes(xOrY, SIGNED, LE, 2);
end for;
else
for xOrY range xyArray do
pointListData &:= bytes(xOrY, SIGNED, BE, 2);
end for;
end if;
elsif ccConf.POINT_LIST_INT_SIZE = 32 then
if ccConf.LITTLE_ENDIAN_INTTYPE then
for xOrY range xyArray do
pointListData &:= bytes(xOrY, SIGNED, LE, 4);
end for;
else
for xOrY range xyArray do
pointListData &:= bytes(xOrY, SIGNED, BE, 4);
end for;
end if;
else
raise RANGE_ERROR;
end if;
bstri := bstring(pointListData);
end func;
const func bstring: toPointListRelative16 (in pointList: aPointList) is func
result
var bstring: bstri is bstring("");
local
var array integer: xyArray is 0 times 0;
var integer: index is 0;
var integer: xOrY is 0;
var string: pointListData is "";
begin
xyArray := xyArray(aPointList);
if length(xyArray) <> 0 then
if ccConf.LITTLE_ENDIAN_INTTYPE then
pointListData &:= bytes(xyArray[1], SIGNED, LE, 2);
pointListData &:= bytes(xyArray[2], SIGNED, LE, 2);
for index range 3 to length(xyArray) step 2 do
pointListData &:= bytes(xyArray[index ] -
xyArray[index - 2], SIGNED, LE, 2);
pointListData &:= bytes(xyArray[index + 1] -
xyArray[index - 1], SIGNED, LE, 2);
end for;
else
pointListData &:= bytes(xyArray[1], SIGNED, BE, 2);
pointListData &:= bytes(xyArray[2], SIGNED, BE, 2);
for index range 3 to length(xyArray) step 2 do
pointListData &:= bytes(xyArray[index ] -
xyArray[index - 2], SIGNED, BE, 2);
pointListData &:= bytes(xyArray[index + 1] -
xyArray[index - 1], SIGNED, BE, 2);
end for;
end if;
end if;
bstri := bstring(pointListData);
end func;
const func bstring: toPointListRelative32 (in pointList: aPointList) is func
result
var bstring: bstri is bstring("");
local
var array integer: xyArray is 0 times 0;
var integer: index is 0;
var integer: xOrY is 0;
var string: pointListData is "";
begin
xyArray := xyArray(aPointList);
if length(xyArray) <> 0 then
if ccConf.LITTLE_ENDIAN_INTTYPE then
pointListData &:= bytes(xyArray[1], SIGNED, LE, 4);
pointListData &:= bytes(xyArray[2], SIGNED, LE, 4);
for index range 3 to length(xyArray) step 2 do
pointListData &:= bytes(xyArray[index ] -
xyArray[index - 2], SIGNED, LE, 4);
pointListData &:= bytes(xyArray[index + 1] -
xyArray[index - 1], SIGNED, LE, 4);
end for;
else
pointListData &:= bytes(xyArray[1], SIGNED, BE, 4);
pointListData &:= bytes(xyArray[2], SIGNED, BE, 4);
for index range 3 to length(xyArray) step 2 do
pointListData &:= bytes(xyArray[index ] -
xyArray[index - 2], SIGNED, BE, 4);
pointListData &:= bytes(xyArray[index + 1] -
xyArray[index - 1], SIGNED, BE, 4);
end for;
end if;
end if;
bstri := bstring(pointListData);
end func;
const func bstring: toTargetPointListBstring (in pointList: aPointList) is func
result
var bstring: bstri is bstring("");
begin
if pointListEncodingIdentical then
bstri := bstring(aPointList);
elsif ccConf.POINT_LIST_ABSOLUTE then
bstri := toPointListAbsolute(aPointList);
else
if ccConf.POINT_LIST_INT_SIZE = 16 then
bstri := toPointListRelative16(aPointList);
elsif ccConf.POINT_LIST_INT_SIZE = 32 then
bstri := toPointListRelative32(aPointList);
else
raise RANGE_ERROR;
end if;
end if;
end func;
const proc: init_plist_constants is func
local
var plist_index_hash: plist_index is plist_index_hash.EMPTY_HASH;
var pointList: plist is pointList.value;
var integer: number is 0;
var bstring: bstri is bstring.value;
begin
plist_index := flip(plist_const_table);
for number range sort(keys(plist_index)) do
plist := plist_index[number][1];
bstri := toTargetPointListBstring(plist);
if bstri not in bstri_const_table then
bstri_const_table @:= [bstri] length(bstri_const_table);
end if;
plist_bstri_table @:= [number] bstri_const_table[bstri];
end for;
end func;
const proc: assign_plist_constants (inout expr_type: c_expr) is func
local
var plist_index_hash: plist_index is plist_index_hash.EMPTY_HASH;
var pointList: plist is pointList.value;
var integer: number is 0;
begin
if length(win_const_table) = 0 then
c_expr.expr &:= "plist = NULL;\n";
else
c_expr.expr &:= "plist = (bstriType *)(malloc(";
c_expr.expr &:= str(length(plist_const_table));
c_expr.expr &:= " * sizeof(bstriType)));\n";
plist_index := flip(plist_const_table);
for number range sort(keys(plist_index)) do
plist := plist_index[number][1];
c_expr.expr &:= "plist[";
c_expr.expr &:= str(number);
c_expr.expr &:= "]=pltAlign(";
if ccConf.ALLOW_BSTRITYPE_SLICES then
c_expr.expr &:= "&";
end if;
c_expr.expr &:= "bst[";
c_expr.expr &:= str(plist_bstri_table[number]);
c_expr.expr &:= "]);\n";
end for;
end if;
end func;
const proc: write_striChars (in string: striChars, inout file: c_prog) is func
local
var integer: countChars is 0;
var char: ch is ' ';
begin
if length(striChars) <> 0 then
writeln(c_prog, "static strElemType striChars[" <&
str(length(striChars)) <&
"]={");
for ch range striChars do
write(c_prog, c_literal(ch) <& ",");
incr(countChars);
if countChars = 20 then
writeln(c_prog);
countChars := 0;
end if;
end for;
writeln(c_prog, "};");
writeln(c_prog);
end if;
end func;
const proc: write_str_table (in stri_index_hash: stri_index,
in array integer: stringPosition, inout expr_type: c_expr) is func
local
var integer: number is 0;
var string: stri is "";
begin
c_expr.expr &:= "struct striStruct str[]={\n";
if length(stri_const_table) > 0 then
for number range 0 to pred(length(stri_const_table)) do
stri := stri_index[number][1];
c_expr.expr &:= "/* str[";
c_expr.expr &:= str(number);
c_expr.expr &:= "] */ {";
c_expr.expr &:= str(length(stri));
c_expr.expr &:= ",";
if ccConf.WITH_STRI_CAPACITY then
c_expr.expr &:= str(length(stri));
c_expr.expr &:= ",";
end if;
if stri = "" then
c_expr.expr &:= "NULL";
else
c_expr.expr &:= "&striChars[";
c_expr.expr &:= str(pred(stringPosition[number]));
c_expr.expr &:= "]";
end if;
c_expr.expr &:= "},";
c_expr.expr &:= stringInComment(stri);
c_expr.expr &:= "\n";
end for;
else
c_expr.expr &:= "/* dummy */ {0,";
if ccConf.WITH_STRI_CAPACITY then
c_expr.expr &:= "0,";
end if;
c_expr.expr &:= "NULL}";
end if;
c_expr.expr &:= "};\n\n";
end func;
const proc: handleOverlappingStrings (inout string: striChars, in string: stri,
inout integer: stringPosition) is func
local
const integer: endLength is 8;
var string: striCharsEnd is "";
var integer: striIndex is 0;
var integer: startPosition is 0;
var integer: checkedLength is 0;
var boolean: found is FALSE;
begin
if length(striChars) >= endLength then
striCharsEnd :=
striChars[succ(length(striChars) - endLength) fixLen endLength];
else
striCharsEnd := striChars;
end if;
striIndex := rpos(stri, striCharsEnd);
found := FALSE;
while striIndex <> 0 and not found do
startPosition := length(striChars) - striIndex - length(striCharsEnd) + 2;
checkedLength := pred(striIndex + length(striCharsEnd));
if startPosition >= 1 and
stri[.. checkedLength] = striChars[startPosition ..] then
stringPosition := startPosition;
striChars &:= stri[succ(checkedLength) ..];
found := TRUE;
else
striIndex := rpos(stri, striCharsEnd, pred(striIndex));
end if;
end while;
if not found then
if length(stri) > 1 then
for checkedLength range min(length(stri), pred(endLength))
downto 1 until found do
if checkedLength <= length(stri) then
startPosition := succ(length(striChars) - checkedLength);
if startPosition >= 1 and
stri[.. checkedLength] = striChars[startPosition ..] then
stringPosition := startPosition;
striChars &:= stri[succ(checkedLength) ..];
found := TRUE;
end if;
end if;
end for;
end if;
if not found then
stringPosition := succ(length(striChars));
striChars &:= stri;
end if;
end if;
end func;
const proc: init_string_constants_with_slices (in stri_index_hash: stri_index,
inout expr_type: c_expr) is func
local
const integer: endLength is 8;
var stringLengthHash: stringLengths is stringLengthHash.value;
var lengthToStriNumHash: lengthToStriNum is lengthToStriNumHash.value;
var array integer: lengthList is 0 times 0;
var integer: lengthIndex is 0;
var integer: length is 0;
var array integer: stringPosition is 0 times 0;
var integer: number is 0;
var string: stri is "";
var integer: combinedStriLength is 0;
var string: striChars is "";
var integer: striPos is 0;
var string: striCharsEnd is "";
var integer: striIndex is 0;
var integer: startPosition is 0;
var integer: checkedLength is 0;
var boolean: found is FALSE;
begin
stringPosition := [0 .. pred(length(stri_const_table))] times 0;
for number range 0 to pred(length(stri_const_table)) do
stringLengths @:= [number] length(stri_index[number][1]);
end for;
lengthToStriNum := flip(stringLengths);
lengthList := sort(keys(lengthToStriNum));
for lengthIndex range maxIdx(lengthList) downto minIdx(lengthList) do
length := lengthList[lengthIndex];
if length in lengthToStriNum then
for number range lengthToStriNum[length] do
stri := stri_index[number][1];
combinedStriLength +:= length(stri);
striPos := pos(striChars, stri);
if striPos = 0 then
handleOverlappingStrings(striChars, stri, stringPosition[number]);
else
stringPosition[number] := striPos;
end if;
end for;
end if;
end for;
write(c_prog, global_c_expr.expr);
write(c_prog, c_expr.expr);
global_c_expr := expr_type.value;
c_expr := expr_type.value;
write_striChars(striChars, c_prog);
write_str_table(stri_index, stringPosition, c_expr);
if SHOW_STATISTIC then
writeln(combinedStriLength <& " chars in all strings");
writeln(length(striChars) <& " chars in string pool");
writeln(combinedStriLength - length(striChars) <& " chars of string memory saved");
end if;
end func;
const proc: init_string_constants_no_slices (in stri_index_hash: stri_index,
inout expr_type: c_expr) is func
local
var integer: number is 0;
var string: stri is "";
var char: ch is ' ';
begin
for number range sort(keys(stri_index)) do
stri := stri_index[number][1];
c_expr.expr &:= "/* str[";
c_expr.expr &:= str(number);
c_expr.expr &:= "] */ static strElemType stri_";
c_expr.expr &:= str(number);
c_expr.expr &:= "[]={";
if ccConf.POINTER_SIZE = 32 then
c_expr.expr &:= str(length(stri));
c_expr.expr &:= ",";
if ccConf.WITH_STRI_CAPACITY then
c_expr.expr &:= str(length(stri));
c_expr.expr &:= ",";
end if;
elsif ccConf.POINTER_SIZE = 64 then
c_expr.expr &:= int64AsTwoInt32(bigInteger(length(stri)));
if ccConf.WITH_STRI_CAPACITY then
c_expr.expr &:= int64AsTwoInt32(bigInteger(length(stri)));
end if;
end if;
for ch range stri do
c_expr.expr &:= c_literal(ch);
c_expr.expr &:= ",";
end for;
c_expr.expr &:= "};\n";
end for;
c_expr.expr &:= "striType str[]={\n";
if length(stri_const_table) > 0 then
for number range sort(keys(stri_index)) do
stri := stri_index[number][1];
c_expr.expr &:= "(striType) stri_";
c_expr.expr &:= str(number);
c_expr.expr &:= ",";
c_expr.expr &:= stringInComment(stri);
c_expr.expr &:= "\n";
end for;
else
c_expr.expr &:= "(striType) NULL";
end if;
c_expr.expr &:= "};\n\n";
end func;
const proc: init_string_constants (inout expr_type: c_expr) is func
local
var stri_index_hash: stri_index is stri_index_hash.EMPTY_HASH;
begin
stri_index := flip(stri_const_table);
if ccConf.ALLOW_STRITYPE_SLICES then
init_string_constants_with_slices(stri_index, c_expr);
else
init_string_constants_no_slices(stri_index, c_expr);
end if;
end func;
const proc: write_bstriChars (in string: bstriChars, inout file: c_prog) is func
local
var char: ch is ' ';
var integer: countChars is 0;
begin
if length(bstriChars) <> 0 then
write(c_prog, "static unsigned char bstriChars[/*" <&
str(length(bstriChars)) <&
"*/]");
countChars := 0;
if ccConf.LIMITED_CSTRI_LITERAL_LEN then
writeln(c_prog, "={");
for ch range bstriChars do
write(c_prog, c_literal(ch) <& ",");
incr(countChars);
if countChars = 20 then
writeln(c_prog);
countChars := 0;
end if;
end for;
writeln(c_prog, "};");
writeln(c_prog);
else
if length(bstriChars) <> 0 then
write(c_prog, "=");
for countChars range 1 to length(bstriChars) step 40 do
writeln(c_prog);
write(c_prog, c_literal(bstriChars[countChars len 40]));
end for;
end if;
writeln(c_prog, ";");
writeln(c_prog);
end if;
end if;
end func;
const proc: write_bst_table (in bstri_index_hash: bstri_index,
in array integer: stringPosition, inout expr_type: c_expr) is func
local
var integer: number is 0;
var string: stri is "";
begin
c_expr.expr &:= "struct bstriStruct bst[]={\n";
if length(bstri_const_table) > 0 then
for number range 0 to pred(length(bstri_const_table)) do
stri := str(bstri_index[number][1]);
c_expr.expr &:= "/* bst[";
c_expr.expr &:= str(number);
c_expr.expr &:= "] */ {";
c_expr.expr &:= str(length(stri));
c_expr.expr &:= ",";
if stri = "" then
c_expr.expr &:= "NULL";
else
c_expr.expr &:= "&bstriChars[";
c_expr.expr &:= str(pred(stringPosition[number]));
c_expr.expr &:= "]";
end if;
c_expr.expr &:= "},";
c_expr.expr &:= stringInComment(stri);
c_expr.expr &:= "\n";
end for;
else
c_expr.expr &:= "/* dummy */ {0,";
c_expr.expr &:= "NULL}";
end if;
c_expr.expr &:= "};\n\n";
end func;
const proc: init_bstri_constants_with_slices (in bstri_index_hash: bstri_index,
inout expr_type: c_expr) is func
local
const integer: endLength is 8;
var stringLengthHash: stringLengths is stringLengthHash.value;
var lengthToStriNumHash: lengthToStriNum is lengthToStriNumHash.value;
var array integer: lengthList is 0 times 0;
var integer: lengthIndex is 0;
var integer: length is 0;
var array integer: stringPosition is 0 times 0;
var integer: number is 0;
var string: stri is "";
var integer: combinedBStriLength is 0;
var string: bstriChars is "";
var integer: striPos is 0;
var string: bstriCharsEnd is "";
var integer: striIndex is 0;
var integer: startPosition is 0;
var integer: checkedLength is 0;
var boolean: found is FALSE;
begin
stringPosition := [0 .. pred(length(bstri_const_table))] times 0;
for number range 0 to pred(length(bstri_const_table)) do
stringLengths @:= [number] length(bstri_index[number][1]);
end for;
lengthToStriNum := flip(stringLengths);
lengthList := sort(keys(lengthToStriNum));
for lengthIndex range maxIdx(lengthList) downto minIdx(lengthList) do
length := lengthList[lengthIndex];
if length in lengthToStriNum then
for number range lengthToStriNum[length] do
stri := str(bstri_index[number][1]);
combinedBStriLength +:= length(stri);
striPos := pos(bstriChars, stri);
if striPos = 0 then
handleOverlappingStrings(bstriChars, stri, stringPosition[number]);
else
stringPosition[number] := striPos;
end if;
end for;
end if;
end for;
write(c_prog, global_c_expr.expr);
write(c_prog, c_expr.expr);
global_c_expr := expr_type.value;
c_expr := expr_type.value;
write_bstriChars(bstriChars, c_prog);
write_bst_table(bstri_index, stringPosition, c_expr);
if SHOW_STATISTIC then
writeln(combinedBStriLength <& " chars in all bstrings");
writeln(length(bstriChars) <& " chars in bstring pool");
writeln(combinedBStriLength - length(bstriChars) <& " chars of bstring memory saved");
end if;
end func;
const proc: init_bstri_constants_no_slices (in bstri_index_hash: bstri_index,
inout expr_type: c_expr) is func
local
var bstring: bstri is bstring.value;
var integer: number is 0;
var string: lengthAsChars is "";
var string: stri is "";
var integer: countChars is 0;
var char: ch is ' ';
begin
for number range sort(keys(bstri_index)) do
bstri := bstri_index[number][1];
c_expr.expr &:= "/* bst[";
c_expr.expr &:= str(number);
c_expr.expr &:= "] */ static const unsigned char bstri_";
c_expr.expr &:= str(number);
if ccConf.POINTER_SIZE = 32 then
lengthAsChars := int32AsFourBytes(length(bstri));
elsif ccConf.POINTER_SIZE = 64 then
lengthAsChars := int64AsEightBytes(length(bstri));
end if;
countChars := 0;
if ccConf.LIMITED_CSTRI_LITERAL_LEN then
c_expr.expr &:= "[]={";
for ch range lengthAsChars do
c_expr.expr &:= c_literal(ch);
c_expr.expr &:= ",";
end for;
c_expr.expr &:= "\n";
for ch range bstri do
c_expr.expr &:= c_literal(ch);
c_expr.expr &:= ",";
incr(countChars);
if countChars = 20 then
c_expr.expr &:= "\n";
countChars := 0;
end if;
end for;
c_expr.expr &:= "};\n";
else
c_expr.expr &:= "[]=";
c_expr.expr &:= c_literal(lengthAsChars);
if length(bstri) <> 0 then
stri := str(bstri);
for countChars range 1 to length(stri) step 40 do
c_expr.expr &:= "\n";
c_expr.expr &:= c_literal(stri[countChars len 40]);
end for;
end if;
c_expr.expr &:= ";\n";
end if;
end for;
c_expr.expr &:= "bstriType bst[]={\n";
if length(bstri_const_table) > 0 then
for number range sort(keys(bstri_index)) do
c_expr.expr &:= "(bstriType) bstri_";
c_expr.expr &:= str(number);
c_expr.expr &:= ",\n";
end for;
else
c_expr.expr &:= "(bstriType) NULL";
end if;
c_expr.expr &:= "};\n\n";
end func;
const proc: init_bstri_constants (inout expr_type: c_expr) is func
local
var bstri_index_hash: bstri_index is bstri_index_hash.EMPTY_HASH;
begin
bstri_index := flip(bstri_const_table);
if ccConf.ALLOW_BSTRITYPE_SLICES then
init_bstri_constants_with_slices(bstri_index, c_expr);
else
init_bstri_constants_no_slices(bstri_index, c_expr);
end if;
end func;
const proc: init_set_constants (inout expr_type: c_expr) is func
local
var set_index_hash: set_index is set_index_hash.EMPTY_HASH;
var bitset: set1 is EMPTY_SET;
var integer: min_position is 0;
var integer: max_position is 0;
var integer: number is 0;
var integer: elem_num is 0;
var integer: columnsFree is 0;
begin
set_index := flip(set_const_table);
for number range sort(keys(set_index)) do
set1 := set_index[number][1];
c_expr.expr &:= "/* set[";
c_expr.expr &:= str(number);
c_expr.expr &:= "] */ static bitSetType set_";
c_expr.expr &:= str(number);
c_expr.expr &:= "[]={";
if set1 = EMPTY_SET then
c_expr.expr &:= "0,0,0,";
else
min_position := min(set1) mdiv ccConf.INTTYPE_SIZE;
max_position := max(set1) mdiv ccConf.INTTYPE_SIZE;
if min_position < 0 then
c_expr.expr &:= "(bitSetType)";
end if;
c_expr.expr &:= str(min_position);
c_expr.expr &:= ",";
if max_position < 0 then
c_expr.expr &:= "(bitSetType)";
end if;
c_expr.expr &:= str(max_position);
c_expr.expr &:= ",";
columnsFree := 4;
for elem_num range min_position to max_position do
if columnsFree = 0 then
c_expr.expr &:= "\n";
columnsFree := 6;
end if;
c_expr.expr &:= "0x";
c_expr.expr &:= getBinary(set1, elem_num * ccConf.INTTYPE_SIZE) radix 16 lpad0 16;
c_expr.expr &:= ",";
decr(columnsFree);
end for;
end if;
c_expr.expr &:= "};\n";
end for;
c_expr.expr &:= "setType set[]={\n";
if length(set_const_table) > 0 then
for number range sort(keys(set_index)) do
c_expr.expr &:= "(setType) set_";
c_expr.expr &:= str(number);
c_expr.expr &:= ",\n";
end for;
else
c_expr.expr &:= "(setType) NULL";
end if;
c_expr.expr &:= "};\n\n";
end func;
const proc: init_type_constants (inout expr_type: c_expr) is func
local
var type_index_hash: type_index is type_index_hash.EMPTY_HASH;
var type: aType is void;
var integer: number is 0;
begin
type_index := flip(type_const_table);
for number range sort(keys(type_index)) do
aType := type_index[number][1];
c_expr.expr &:= "/* typ[";
c_expr.expr &:= str(number);
c_expr.expr &:= "] */ static struct typeStruct typ_";
c_expr.expr &:= str(number);
c_expr.expr &:= "={";
c_expr.expr &:= "NULL, NULL, NULL, NULL, NULL, 0, NULL, NULL";
c_expr.expr &:= "};\n";
end for;
c_expr.expr &:= "typeType typ[]={\n";
if length(type_const_table) > 0 then
for number range sort(keys(type_index)) do
aType := type_index[number][1];
c_expr.expr &:= "&typ_";
c_expr.expr &:= str(number);
c_expr.expr &:= ", /* ";
c_expr.expr &:= type_name2(aType);
c_expr.expr &:= " */\n";
end for;
else
c_expr.expr &:= "(typeType) NULL";
end if;
c_expr.expr &:= "};\n\n";
end func;
const proc: init_array_constants (in reference: const_object, inout expr_type: c_expr) is func
local
var ref_list: array_list is ref_list.EMPTY;
var integer: number is 0;
var integer: elem_num is 0;
var integer: elem_after_repeat_block is 0;
var reference: element is NIL;
begin
number := const_table[const_object];
array_list := arrayToList(const_object);
c_expr.expr &:= "arr[";
c_expr.expr &:= str(number);
c_expr.expr &:= "]=arrMalloc(";
c_expr.expr &:= str(arrayMinIdx(const_object));
c_expr.expr &:= ", ";
c_expr.expr &:= str(pred(arrayMinIdx(const_object) + length(array_list)));
c_expr.expr &:= ");\n";
elem_num := 0;
elem_after_repeat_block := 0;
for element range array_list do
if element in element_repeat_count then
c_expr.expr &:= "{\n";
c_expr.expr &:= "int idx;\n";
c_expr.expr &:= "for (idx=";
c_expr.expr &:= str(elem_num);
c_expr.expr &:= "; idx < ";
c_expr.expr &:= str(elem_num + element_repeat_count[element]);
c_expr.expr &:= "; idx++) {\n";
c_expr.expr &:= "arr[";
c_expr.expr &:= str(number);
c_expr.expr &:= "]->arr[idx]";
init_const_value(element, c_expr);
c_expr.expr &:= ";\n";
c_expr.expr &:= "}\n";
c_expr.expr &:= "}\n";
elem_after_repeat_block := elem_num + element_repeat_count[element];
elsif elem_num >= elem_after_repeat_block then
c_expr.expr &:= "arr[";
c_expr.expr &:= str(number);
c_expr.expr &:= "]->arr[";
c_expr.expr &:= str(elem_num);
c_expr.expr &:= "]";
init_const_value(element, c_expr);
c_expr.expr &:= ";\n";
end if;
incr(elem_num);
end for;
end func;
const proc: malloc_struct (in reference: const_object, inout expr_type: c_expr) is func
local
var ref_list: struct_list is ref_list.EMPTY;
var integer: number is 0;
begin
number := const_table[const_object];
struct_list := structToList(const_object);
c_expr.expr &:= "sct[";
c_expr.expr &:= str(number);
c_expr.expr &:= "]=(structType)(malloc(sizeof(struct rtlStructStruct) - sizeof(rtlObjectType)";
if length(struct_list) <> 0 then
c_expr.expr &:= " +\n ";
c_expr.expr &:= str(length(struct_list));
c_expr.expr &:= " * sizeof(rtlObjectType)";
end if;
c_expr.expr &:= "));\n";
end func;
const proc: init_struct_constants (in reference: const_object, inout expr_type: c_expr) is func
local
var ref_list: struct_list is ref_list.EMPTY;
var integer: number is 0;
var integer: elem_num is 0;
var reference: element is NIL;
begin
number := const_table[const_object];
struct_list := structToList(const_object);
c_expr.expr &:= "sct[";
c_expr.expr &:= str(number);
c_expr.expr &:= "]->usage_count=0;\n";
c_expr.expr &:= "sct[";
c_expr.expr &:= str(number);
c_expr.expr &:= "]->type_num=";
c_expr.expr &:= str(typeNumber(getType(const_object)));
c_expr.expr &:= "/*";
c_expr.expr &:= str(getType(const_object));
c_expr.expr &:= "*/";
c_expr.expr &:= ";\n";
elem_num := 1;
for element range struct_list do
c_expr.expr &:= "sct[";
c_expr.expr &:= str(number);
c_expr.expr &:= "]->stru[";
c_expr.expr &:= str(pred(elem_num));
c_expr.expr &:= "]";
init_const_value(element, c_expr);
c_expr.expr &:= ";\n";
incr(elem_num);
end for;
if const_object in globalInitalisations then
c_expr.expr &:= globalInitalisations[const_object];
end if;
end func;
const proc: init_hash_constants (in reference: const_object, inout expr_type: c_expr) is func
local
var ref_list: hash_key_list is ref_list.EMPTY;
var ref_list: hash_data_list is ref_list.EMPTY;
var integer: number is 0;
var integer: elem_num is 0;
var reference: key_element is NIL;
var expr_type: hashcode_expr is expr_type.value;
begin
number := const_table[const_object];
hash_key_list := hashKeysToList(const_object);
hash_data_list := hashDataToList(const_object);
c_expr.expr &:= "hsh[";
c_expr.expr &:= str(number);
c_expr.expr &:= "]=hshEmpty();\n";
if length(hash_key_list) <> 0 then
c_expr.expr &:= "{\n";
c_expr.expr &:= "rtlObjectType hash_key;\n";
c_expr.expr &:= "rtlObjectType hash_data;\n";
elem_num := 1;
for key_element range hash_key_list do
c_expr.expr &:= "hash_key";
init_const_value(key_element, c_expr);
c_expr.expr &:= ";\n";
c_expr.expr &:= "hash_data";
init_const_value(hash_data_list[elem_num], c_expr);
c_expr.expr &:= ";\n";
hashcode_expr := expr_type.value;
setVar(key_element, FALSE);
process_hashcode(key_element, hashcode_expr);
if hashcode_expr.temp_decls <> "" then
c_expr.expr &:= "{\n";
c_expr.expr &:= hashcode_expr.temp_decls;
c_expr.expr &:= hashcode_expr.temp_assigns;
end if;
c_expr.expr &:= "hshIncl(hsh[";
c_expr.expr &:= str(number);
c_expr.expr &:= "], hash_key.value.genericValue, hash_data.value.genericValue, ";
c_expr.expr &:= hashcode_expr.expr;
c_expr.expr &:= ", (compareType)(";
object_address(keyCompareObj(getType(const_object)), c_expr);
c_expr.expr &:= "), (createFuncType)(";
object_address(keyCreateObj(getType(const_object)), c_expr);
c_expr.expr &:= "), (createFuncType)(";
object_address(dataCreateObj(getType(const_object)), c_expr);
c_expr.expr &:= "), (copyFuncType)(";
object_address(dataCopyObj(getType(const_object)), c_expr);
c_expr.expr &:= "));\n";
if hashcode_expr.temp_decls <> "" then
c_expr.expr &:= hashcode_expr.temp_frees;
c_expr.expr &:= "}\n";
end if;
incr(elem_num);
end for;
c_expr.expr &:= "}\n";
end if;
end func;
const proc: init_interface_constants (in reference: const_object, inout expr_type: c_expr) is func
local
var reference: struct_of_interface is NIL;
var integer: number is 0;
begin
number := const_table[const_object];
struct_of_interface := interfaceToStruct(const_object);
c_expr.expr &:= "itf[";
c_expr.expr &:= str(number);
c_expr.expr &:= "]";
if isVar(struct_of_interface) and struct_of_interface in globalInitalisations then
c_expr.expr &:= "=o_";
create_name(struct_of_interface, c_expr.expr);
elsif category(struct_of_interface) = STRUCTOBJECT then
c_expr.expr &:= "=sct[";
c_expr.expr &:= str(const_table[struct_of_interface]);
c_expr.expr &:= "]";
else
c_expr.expr &:= " /* = ";
c_expr.expr &:= str(category(struct_of_interface));
c_expr.expr &:= " */";
end if;
c_expr.expr &:= ";\n";
end func;
const proc: init_nan_constants (inout expr_type: c_expr) is func
local
var nan_index_hash: nan_index is nan_index_hash.EMPTY_HASH;
var integer: number is 0;
var bin64: bits is bin64(0);
begin
c_expr.expr &:= "double2BitsUnion nanValue[] = {\n";
if length(nan_const_table) > 0 then
nan_index := flip(nan_const_table);
for number range sort(keys(nan_index)) do
bits := nan_index[number][1];
c_expr.expr &:= "{0x";
c_expr.expr &:= bits radix 16 lpad0 16;
c_expr.expr &:= "},\n";
end for;
else
c_expr.expr &:= "{0}";
end if;
c_expr.expr &:= "};\n\n";
end func;
const proc: initCaseLabelsOfWhen (in integer: numOfCaseStmt, in integer: numOfWhenPart,
in reference: whenLabels, inout expr_type: c_expr) is func
local
var ref_list: hash_key_list is ref_list.EMPTY;
var reference: key_element is NIL;
var expr_type: hashcode_expr is expr_type.value;
begin
hash_key_list := hashKeysToList(whenLabels);
if length(hash_key_list) <> 0 then
for key_element range hash_key_list do
c_expr.expr &:= "hash_key";
init_const_value(key_element, c_expr);
c_expr.expr &:= ";\n";
hashcode_expr := expr_type.value;
setVar(key_element, FALSE);
process_hashcode(key_element, hashcode_expr);
if hashcode_expr.temp_decls <> "" then
c_expr.expr &:= "{\n";
c_expr.expr &:= hashcode_expr.temp_decls;
c_expr.expr &:= hashcode_expr.temp_assigns;
end if;
c_expr.expr &:= "hshIncl(caseLabels[";
c_expr.expr &:= str(numOfCaseStmt);
c_expr.expr &:= "], hash_key.value.genericValue, ";
c_expr.expr &:= str(numOfWhenPart);
c_expr.expr &:= ", ";
c_expr.expr &:= hashcode_expr.expr;
c_expr.expr &:= ", (compareType)(";
object_address(keyCompareObj(getType(whenLabels)), c_expr);
c_expr.expr &:= "), (createFuncType)(";
object_address(keyCreateObj(getType(whenLabels)), c_expr);
c_expr.expr &:= "), (createFuncType)(&genericCreate), (copyFuncType)(&genericCpy));\n";
if hashcode_expr.temp_decls <> "" then
c_expr.expr &:= hashcode_expr.temp_frees;
c_expr.expr &:= "}\n";
end if;
end for;
end if;
end func;
const proc: initCaseLabelsOfCase (in integer: numOfCaseStmt,
in array reference: caseWhens, inout expr_type: c_expr) is func
local
var integer: numOfWhenPart is 0;
var reference: whenLabels is NIL;
begin
c_expr.expr &:= "caseLabels[";
c_expr.expr &:= str(numOfCaseStmt);
c_expr.expr &:= "]=hshEmpty();\n";
for whenLabels key numOfWhenPart range caseWhens do
initCaseLabelsOfWhen(numOfCaseStmt, numOfWhenPart, whenLabels, c_expr);
end for;
end func;
const proc: initCaseLabels (inout expr_type: c_expr) is func
local
var integer: numOfCaseStmt is 0;
begin
c_expr.expr &:= "void initCaseLabelsOfSwitch () {\n";
if length(case_table) <> 0 then
c_expr.expr &:= "rtlObjectType hash_key;\n";
c_expr.expr &:= "caseLabels = (hashType *)(malloc(";
c_expr.expr &:= str(length(case_table));
c_expr.expr &:= " * sizeof(hashType)));\n";
for key numOfCaseStmt range case_table do
initCaseLabelsOfCase(numOfCaseStmt, case_table[numOfCaseStmt], c_expr);
end for;
end if;
c_expr.expr &:= "}\n\n";
end func;
const proc: init_values (inout expr_type: c_expr) is func
local
var const_index_hash: const_index is const_index_hash.EMPTY_HASH;
var ref_list: sorted_list is ref_list.EMPTY;
var reference: struct_of_interface is NIL;
var reference: const_object is NIL;
var integer: number is 0;
var ref_list: elements_to_walk is ref_list.EMPTY;
var integer: functionNumber is 1;
var integer: functionBreakupLimit is 0;
const integer: intendedFunctionSize is 100000;
begin
const_index := flip(const_table);
for number range sort(keys(const_index)) do
const_object := const_index[number][1];
if category(const_object) = ARRAYOBJECT then
elements_to_walk := determine_multiple_array_elements(arrayToList(const_object));
walk_const_list(elements_to_walk, sorted_list);
sorted_list &:= make_list(const_object);
elsif category(const_object) = STRUCTOBJECT then
walk_const_list(structToList(const_object), sorted_list);
sorted_list &:= make_list(const_object);
elsif category(const_object) = HASHOBJECT then
walk_const_list(hashKeysToList(const_object), sorted_list);
walk_const_list(hashDataToList(const_object), sorted_list);
sorted_list &:= make_list(const_object);
elsif category(const_object) = INTERFACEOBJECT then
if const_object not in const_table then
const_table @:= [const_object] length(const_table);
end if;
struct_of_interface := interfaceToStruct(const_object);
if struct_of_interface not in const_table then
const_table @:= [struct_of_interface] length(const_table);
walk_const_list(structToList(struct_of_interface), sorted_list);
sorted_list &:= make_list(struct_of_interface);
elsif const_table[struct_of_interface] >= const_table[const_object] then
sorted_list &:= make_list(struct_of_interface);
end if;
sorted_list &:= make_list(const_object);
end if;
end for;
writeln("after walk_const_list");
for const_object range sorted_list do
if category(const_object) = MATCHOBJECT or category(const_object) = ACTOBJECT or
category(const_object) = BLOCKOBJECT then
prepare_func_literal(const_object, c_expr);
end if;
end for;
init_bigint_constants;
init_win_constants;
init_plist_constants;
init_string_constants(c_expr);
init_bstri_constants(c_expr);
init_set_constants(c_expr);
init_type_constants(c_expr);
functionBreakupLimit := length(c_expr.expr) + intendedFunctionSize;
c_expr.expr &:= "static void init_values1 (void)\n";
c_expr.expr &:= "{\n";
initPollOperations(c_expr);
assign_bigint_constants(c_expr);
assign_win_constants(c_expr);
assign_plist_constants(c_expr);
c_expr.expr &:= "arr = (arrayType *)(malloc(";
c_expr.expr &:= str(length(const_table));
c_expr.expr &:= " * sizeof(arrayType)));\n";
c_expr.expr &:= "sct = (structType *)(arr);\n";
c_expr.expr &:= "hsh = (hashType *)(arr);\n";
c_expr.expr &:= "itf = (interfaceType *)(arr);\n";
for const_object range sorted_list do
if category(const_object) = STRUCTOBJECT then
malloc_struct(const_object, c_expr);
end if;
end for;
for const_object range sorted_list do
if length(c_expr.expr) >= functionBreakupLimit then
c_expr.expr &:= "}\n\n";
functionBreakupLimit := length(c_expr.expr) + intendedFunctionSize;
incr(functionNumber);
c_expr.expr &:= "static void init_values";
c_expr.expr &:= str(functionNumber);
c_expr.expr &:= " (void)\n";
c_expr.expr &:= "{\n";
end if;
if category(const_object) = ARRAYOBJECT then
init_array_constants(const_object, c_expr);
elsif category(const_object) = STRUCTOBJECT then
init_struct_constants(const_object, c_expr);
elsif category(const_object) = HASHOBJECT then
init_hash_constants(const_object, c_expr);
elsif category(const_object) = INTERFACEOBJECT then
init_interface_constants(const_object, c_expr);
elsif category(const_object) <> MATCHOBJECT and
category(const_object) <> ACTOBJECT then
number := const_table[const_object];
c_expr.expr &:= "/* const ";
c_expr.expr &:= str(category(const_object));
c_expr.expr &:= " [";
c_expr.expr &:= str(number);
c_expr.expr &:= "] */\n";
end if;
end for;
c_expr.expr &:= "}\n\n";
c_expr.expr &:= "static void init_values (void)\n";
c_expr.expr &:= "{\n";
for number range 1 to functionNumber do
c_expr.expr &:= " init_values";
c_expr.expr &:= str(number);
c_expr.expr &:= "();\n";
end for;
c_expr.expr &:= " initCaseLabelsOfSwitch();\n";
c_expr.expr &:= "}\n\n";
init_nan_constants(c_expr);
end func;
const proc: declare_rtlRaiseError (inout expr_type: c_expr) is func
begin
c_expr.expr &:= "void rtlRaiseError (int fail_value, const char *file_name, int line_number)\n";
c_expr.expr &:= "{\n";
if trace_exception then
c_expr.expr &:= " int ch;\n";
c_expr.expr &:= " if (catch_stack_pos == 0) {\n";
c_expr.expr &:= " printf(\"\\n*** Uncaught exception \");\n";
c_expr.expr &:= " } else {\n";
c_expr.expr &:= " printf(\"\\n*** Exception \");\n";
c_expr.expr &:= " }\n";
c_expr.expr &:= " if (fail_value >= 0 && fail_value < sizeof(exception_name) / sizeof(char *)) {\n";
c_expr.expr &:= " printf(\"%s\", exception_name[fail_value]);\n";
c_expr.expr &:= " } else {\n";
c_expr.expr &:= " printf(\"%d\", fail_value);\n";
c_expr.expr &:= " }\n";
c_expr.expr &:= " printf(\" raised at %s(%d)\\n\", file_name, line_number);\n";
c_expr.expr &:= " printf(\"\\n*** The following commands are possible:\\n\"\n";
c_expr.expr &:= " \" RETURN Continue\\n\"\n";
c_expr.expr &:= " \" * Terminate\\n\"\n";
c_expr.expr &:= " \" / Trigger SIGFPE\\n\");\n";
c_expr.expr &:= " ch = fgetc(stdin);\n";
c_expr.expr &:= " if (ch == (int) '*') {\n";
c_expr.expr &:= " doExit(1);\n";
c_expr.expr &:= " } else if (ch == (int) '/') {\n";
c_expr.expr &:= " triggerSigfpe();\n";
c_expr.expr &:= " }\n";
end if;
c_expr.expr &:= " error_file = file_name;\n";
c_expr.expr &:= " error_line = line_number;\n";
if signal_exception then
c_expr.expr &:= " if (catch_stack_pos == 0) {\n";
c_expr.expr &:= " printf(\"\\n*** Uncaught exception \");\n";
c_expr.expr &:= " if (fail_value >= 0 && fail_value < sizeof(exception_name) / sizeof(char *)) {\n";
c_expr.expr &:= " printf(\"%s\", exception_name[fail_value]);\n";
c_expr.expr &:= " } else {\n";
c_expr.expr &:= " printf(\"%d\", fail_value);\n";
c_expr.expr &:= " }\n";
c_expr.expr &:= " printf(\" raised at %s(%d)\\n\", file_name, line_number);\n";
c_expr.expr &:= " triggerSigfpe();\n";
c_expr.expr &:= " }\n";
end if;
if ccConf.HAS_SIGSETJMP then
c_expr.expr &:= " siglongjmp(catch_stack[catch_stack_pos], fail_value);\n";
else
c_expr.expr &:= " longjmp(catch_stack[catch_stack_pos], fail_value);\n";
end if;
c_expr.expr &:= "}\n";
c_expr.expr &:= "\n";
end func;
const proc: declare_raise_error2 (inout expr_type: c_expr) is func
begin
if compilerLibraryUsed then
writeln(c_prog, "extern boolType interpreter_exception;");
declareExtern("void interprRaiseError (int, const char *, int);");
end if;
c_expr.expr &:= "void raise_error2 (int fail_value, const char *file_name, int line_number)\n";
c_expr.expr &:= "{\n";
if compilerLibraryUsed then
c_expr.expr &:= " if (interpreter_exception) {\n";
if trace_exception then
c_expr.expr &:= " int ch;\n";
c_expr.expr &:= " if (fail_value >= 0 && fail_value < sizeof(exception_name) / sizeof(char *)) {\n";
c_expr.expr &:= " printf(\"*** Exception %s\", exception_name[fail_value]);\n";
c_expr.expr &:= " } else {\n";
c_expr.expr &:= " printf(\"*** Exception %d\", fail_value);\n";
c_expr.expr &:= " }\n";
c_expr.expr &:= " printf(\" raised at %s(%d)\\n\", file_name, line_number);\n";
c_expr.expr &:= " printf(\"\\n*** The following commands are possible:\\n\"\n";
c_expr.expr &:= " \" RETURN Continue\\n\"\n";
c_expr.expr &:= " \" * Terminate\\n\"\n";
c_expr.expr &:= " \" / Trigger SIGFPE\\n\");\n";
c_expr.expr &:= " ch = fgetc(stdin);\n";
c_expr.expr &:= " if (ch == (int) '*') {\n";
c_expr.expr &:= " doExit(1);\n";
c_expr.expr &:= " } else if (ch == (int) '/') {\n";
c_expr.expr &:= " triggerSigfpe();\n";
c_expr.expr &:= " }\n";
end if;
c_expr.expr &:= " interprRaiseError(fail_value, file_name, line_number);\n";
c_expr.expr &:= " } else {\n";
c_expr.expr &:= " rtlRaiseError(fail_value, file_name, line_number);\n";
c_expr.expr &:= " }\n";
else
c_expr.expr &:= " rtlRaiseError(fail_value, file_name, line_number);\n";
end if;
c_expr.expr &:= "}\n";
c_expr.expr &:= "\n";
end func;
const proc: init_globals (inout expr_type: c_expr) is func
begin
c_expr.expr &:= "static void init_globals (void)\n";
c_expr.expr &:= "{\n";
c_expr.expr &:= global_init.temp_decls;
c_expr.expr &:= global_init.temp_assigns;
c_expr.expr &:= global_init.expr;
c_expr.expr &:= "}\n\n";
end func;
const proc: process_global_declarations (in program: prog) is func
local
var expr_type: c_expr is expr_type.value;
var type: int_type is void;
var integer: numObjects is 0;
var integer: index is 0;
begin
if not compDataLibraryUsed then
declareExtern("intType heapsize (void) {return 0;}");
declareExtern("typeType refType (objRefType a) {printf(\"refType\\n\"); return NULL;}");
declareExtern("typeType typValue (objRefType a) {printf(\"typValue\\n\"); return NULL;}");
writeln(c_prog);
end if;
if compDataLibraryUsed and not compilerLibraryUsed then
declareExtern("striType get_file_name (unsigned int a) {return " <& stringLiteral("") <& ";}");
declareExtern("const unsigned char *get_file_name_ustri (unsigned int a) {return (unsigned char *) \"?\";}");
declareExtern("void *get_param_list (const_listType a, int *b) {printf(\"get_param_list\\n\"); return NULL;}");
writeln(c_prog);
end if;
declare_rtlRaiseError(c_expr);
declare_raise_error2(c_expr);
process_dynamic_decisions(c_expr);
declare_literal_function_of_enums(c_expr);
declare_missing_create_declarations(c_expr);
declare_missing_destr_declarations(c_expr);
initCaseLabels(c_expr);
init_values(c_expr);
init_globals(c_expr);
if profile_function then
int_type := getValue(sysVar(prog, "integer"), type);
numObjects := objNumber(alloc(TRUE, int_type, 0));
writeln(c_prog, "static unsigned int profile_size = " <& numObjects <& ";");
writeln(c_prog);
writeln(c_prog, "static void initProfile (void)");
writeln(c_prog, "{");
writeln(c_prog, " memSizeType index;");
writeln(c_prog, " profile = (struct profileElement *) malloc(" <&
numObjects <& " * sizeof(struct profileElement));");
writeln(c_prog, " if (profile != NULL) {");
writeln(c_prog, " memset(profile, 0, " <& numObjects <& " * sizeof(struct profileElement));");
writeln(c_prog, " for (index = 0; index < " <& numObjects <& "; index++) {");
writeln(c_prog, " profile[index].file = \"\";");
writeln(c_prog, " profile[index].name = \"\";");
writeln(c_prog, " }");
for index range 1 to pred(numObjects) do
if index in profiledFunctions then
write(c_prog, " profile[" <& index <& "].file = " <&
c_literal(toUtf8(file(profiledFunctions[index]))) <& ";");
write(c_prog, " profile[" <& index <& "].line = " <&
line(profiledFunctions[index]) <& ";");
writeln(c_prog, " profile[" <& index <& "].name = " <&
c_literal(toUtf8(str(profiledFunctions[index]))) <& ";");
end if;
end for;
writeln(c_prog, " }");
writeln(c_prog, "}");
writeln(c_prog);
end if;
write(c_prog, global_c_expr.expr);
write(c_prog, c_expr.expr);
count_declarations(c_expr);
end func;
const proc: init_systypes (in program: prog) is func
local
var reference: type_ref is NIL;
var reference: ref_to_empty is NIL;
var type: type_type is void;
var type: int_type is void;
var type: float_type is void;
var type: bigint_type is void;
var type: char_type is void;
var type: stri_type is void;
begin
type_ref := sysVar(prog, "type");
if type_ref <> NIL then
type_type := getValue(type_ref, type);
typeCategory @:= [type_type] TYPEOBJECT;
end if;
type_ref := sysVar(prog, "proc");
if type_ref <> NIL then
proctype := getValue(type_ref, type);
end if;
type_ref := sysVar(prog, "integer");
if type_ref <> NIL then
int_type := getValue(type_ref, type);
typeCategory @:= [int_type] INTOBJECT;
end if;
type_ref := sysVar(prog, "bigInteger");
if type_ref <> NIL then
bigint_type := getValue(type_ref, type);
typeCategory @:= [bigint_type] BIGINTOBJECT;
end if;
type_ref := sysVar(prog, "float");
if type_ref <> NIL then
float_type := getValue(type_ref, type);
typeCategory @:= [float_type] FLOATOBJECT;
end if;
type_ref := sysVar(prog, "char");
if type_ref <> NIL then
char_type := getValue(type_ref, type);
typeCategory @:= [char_type] CHAROBJECT;
end if;
type_ref := sysVar(prog, "string");
if type_ref <> NIL then
stri_type := getValue(type_ref, type);
typeCategory @:= [stri_type] STRIOBJECT;
end if;
ref_to_empty := sysVar(prog, "empty");
if ref_to_empty <> NIL then
voidtype := getType(ref_to_empty);
typeCategory @:= [voidtype] VOIDOBJECT;
end if;
end func;
const func string: temp_name (in string: source) is func
result
var string: tempName is "";
begin
if rpos(source, "/") = 0 then
tempName := "tmp_" & source;
else
tempName := source[.. rpos(source, "/")] &
"tmp_" & source[succ(rpos(source, "/")) ..];
end if;
end func;
const proc: pass_1 (in string: source, inout program: prog,
in optionHash: compilerOptions, inout boolean: okay) is func
local
var char: optionChar is ' ';
var string: configFileName is "";
begin
if source = "" then
writeln("*** Sourcefile missing");
okay := FALSE;
end if;
if "-w" in compilerOptions then
if compilerOptions["-w"] in {"0", "1", "2"} then
warning_level := integer(compilerOptions["-w"]);
else
writeln("*** Unsupported option: -w" <& compilerOptions["-w"]);
okay := FALSE;
end if;
end if;
if "-g" in compilerOptions then
if compilerOptions["-g"] in {"", "-debug_c"} then
source_debug_info := compilerOptions["-g"] <> "-debug_c";
else
writeln("*** Unsupported option: -g" <& compilerOptions["-g"]);
okay := FALSE;
end if;
end if;
if "-t" in compilerOptions then
for optionChar range compilerOptions["-t"] do
case optionChar of
when {'d'}: trace_dynamic_calls := TRUE;
when {'e'}: trace_exception := TRUE;
when {'f'}: trace_function := TRUE;
when {'s'}: trace_signal := TRUE;
otherwise:
writeln("*** Unsupported option: -t" <& optionChar);
okay := FALSE;
end case;
end for;
end if;
if "-p" in compilerOptions then
profile_function := TRUE;
end if;
if "-e" in compilerOptions then
signal_exception := TRUE;
end if;
if "-o" in compilerOptions then
if compilerOptions["-o"] in {"c0", "c1", "c2", "c3"} then
evaluate_const_expr := integer(compilerOptions["-o"][2 ..]);
else
writeln("*** Unsupported option: -o" <& compilerOptions["-o"]);
okay := FALSE;
end if;
end if;
setOptimizationSettings(evaluate_const_expr);
if "-s" in compilerOptions then
for optionChar range compilerOptions["-s"] do
case optionChar of
when {'d'}: integer_division_check := FALSE;
when {'i'}: string_index_check := FALSE;
bstring_index_check := FALSE;
array_index_check := FALSE;
ref_list_index_check := FALSE;
when {'o'}: integer_overflow_check := FALSE;
when {'r'}: function_range_check := FALSE;
conversion_range_check := FALSE;
otherwise:
writeln("*** Unsupported option: -s" <& optionChar);
okay := FALSE;
end case;
end for;
end if;
setIntegerDivisionCheck(integer_division_check);
setIntegerOverflowCheck(integer_overflow_check);
if "-c" in compilerOptions then
if compilerOptions["-c"] = "++" then
generate_c_plus_plus := TRUE;
declare_with_extern_c := generate_c_plus_plus;
else
configFileName := ccConf.S7_LIB_DIR & "/cc_conf_" & compilerOptions["-c"] & ".prop";
if fileType(configFileName) = FILE_REGULAR then
ccConf := readConfig(configFileName);
else
writeln("*** Cannot find config file " <& configFileName);
okay := FALSE;
end if;
end if;
end if;
if "-f" in compilerOptions then
case compilerOptions["-f"] of
when {"lto"}:
if ccConf.CC_OPT_LINK_TIME_OPTIMIZATION <> "" then
enable_link_time_optimization := TRUE;
end if;
otherwise:
writeln("*** Unsupported option: -f" <& compilerOptions["-f"]);
okay := FALSE;
end case;
end if;
if "-S" in compilerOptions then
block
stack_size := integer(compilerOptions["-S"]);
exception
otherwise:
writeln("*** Ignore unsupported option: -S" <& compilerOptions["-S"]);
okay := FALSE;
end block;
else
stack_size := ccConf.DEFAULT_STACK_SIZE;
end if;
if okay then
writeln("Source: " <& source);
writeln("Compiling the program ...");
block
prog := parseFile(source, parseOptions.value, libraryDirs);
if prog = program.EMPTY then
writeln("*** File " <& literal(source) <& " not found.");
okay := FALSE;
end if;
exception
otherwise:
writeln("*** An error occurred.");
okay := FALSE;
end block;
if okay and errorCount(prog) <> 0 then
write(errorCount(prog) <& " error");
if errorCount(prog) > 1 then
write("s");
end if;
writeln(" found");
okay := FALSE;
end if;
end if;
end func;
const proc: pass_2 (in string: source, in program: prog,
inout boolean: okay) is func
local
var string: temporaryFileName is "";
var ref_list: globalObjects is ref_list.EMPTY;
var reference: obj is NIL;
begin
if okay then
main_object := sysVar(prog, "main");
if main_object <> NIL then
compileLibrary := category(main_object) = FORWARDOBJECT;
temporaryFileName := temp_name(source);
if generate_c_plus_plus then
temporaryFileName &:= ".cpp";
else
temporaryFileName &:= ".c";
end if;
c_prog := open(temporaryFileName, "r");
if c_prog <> STD_NULL then
if getln(c_prog) <> temp_marker and length(c_prog) <> 0 then
write("*** The file ");
write(literal(temporaryFileName));
writeln(" was not created by the compiler.");
write("*** Remove the file ");
write(literal(temporaryFileName));
writeln(" manually and restart the compiler.");
okay := FALSE;
end if;
close(c_prog);
end if;
if okay then
c_prog := open(temporaryFileName, "w");
if c_prog <> STD_NULL then
writeln("Generating code ...");
init_systypes(prog);
write_file_head;
write_prototypes;
write_resize_catch_stack;
globalObjects := globalObjects(prog);
if compileLibrary then
writeln("Compile library");
for obj range globalObjects do
if endsWith(path(prog), file(obj)) then
process_object(obj);
else
process_library_import_object(obj);
end if;
end for;
else
for obj range globalObjects do
process_object(obj);
end for;
end if;
process_global_declarations(prog);
close(c_prog);
writeln(countDeclarations <& " declarations processed");
writeln(countOptimizations <& " optimizations done");
if countInlinedFunctions <> 0 then
writeln(countInlinedFunctions <& " functions inlined");
end if;
if countEvaluations <> 0 then
writeln(countEvaluations <& " evaluations done");
end if;
if countDivisionChecks <> 0 then
writeln(countDivisionChecks <& " division checks inserted");
end if;
if countOptimizedDivisionChecks <> 0 then
writeln(countOptimizedDivisionChecks <& " division checks optimized away");
end if;
if countRangeChecks <> 0 then
writeln(countRangeChecks <& " range checks inserted");
end if;
if countOptimizedRangeChecks <> 0 then
writeln(countOptimizedRangeChecks <& " range checks optimized away");
end if;
if countNoRangeChecks <> 0 then
writeln(countNoRangeChecks <& " range checks suppressed");
end if;
if countIndexChecks <> 0 then
writeln(countIndexChecks <& " index checks inserted");
end if;
if countOptimizedIndexChecks <> 0 then
writeln(countOptimizedIndexChecks <& " index checks optimized away");
end if;
if countSuppressedIndexChecks <> 0 then
writeln(countSuppressedIndexChecks <& " index checks suppressed");
end if;
if countOverflowChecks <> 0 then
writeln(countOverflowChecks <& " overflow checks inserted");
end if;
if countOptimizedOverflowChecks <> 0 then
writeln(countOptimizedOverflowChecks <& " overflow checks optimized away");
end if;
if countSuppressedOverflowChecks <> 0 then
writeln(countSuppressedOverflowChecks <& " overflow checks suppressed");
end if;
else
write("*** Cannot open temp file ");
write(literal(temporaryFileName));
writeln(".");
okay := FALSE;
end if;
end if;
else
writeln("*** main not found.");
okay := FALSE;
end if;
end if;
end func;
const proc: importEnvironment (in string: fileName) is func
local
var iniDataType: iniData is iniDataType.value;
var string: aKey is "";
var string: aValue is "";
begin
iniData := readIniFile(fileName);
if "" in iniData then
for aValue key aKey range iniData[""] do
setenv(aKey, aValue);
end for;
else
writeln("*** C compiler environment file " <& literal(fileName) <& " not found.");
end if;
end func;
const proc: appendLibrary (inout array string: options, in string: libraryToAppend) is func
local
var string: existingOption is "";
var boolean: found is FALSE;
begin
if libraryToAppend <> "" then
for existingOption range options until found do
found := existingOption = libraryToAppend;
end for;
if not found then
options &:= libraryToAppend;
end if;
end if;
end func;
const proc: appendLibrary (inout array string: options, in array string: librariesToAppend) is func
local
var string: libraryToAppend is "";
begin
for libraryToAppend range librariesToAppend do
appendLibrary(options, libraryToAppend);
end for;
end func;
const proc: logProgram (in string: command, in array string: parameters,
in string: errorFile) is func
begin
write(toShellPath(command) <& " " <& shellParameters(parameters));
case ccConf.CC_ERROR_FILEDES of
when {1}:
write(" " <& ccConf.REDIRECT_FILEDES_1 <& toShellPath(errorFile));
write(" " <& ccConf.REDIRECT_FILEDES_2 <& ccConf.NULL_DEVICE);
when {2}:
write(" " <& ccConf.REDIRECT_FILEDES_2 <& toShellPath(errorFile));
write(" " <& ccConf.REDIRECT_FILEDES_1 <& ccConf.NULL_DEVICE);
end case;
writeln;
flush(OUT);
end func;
const proc: execProgramScript (in string: command, in array string: parameters,
in string: errorFile) is func
local
var array string: redirection is 0 times "";
var integer: shellResult is 0;
begin
logProgram(command, parameters, errorFile);
case ccConf.CC_ERROR_FILEDES of
when {1}:
redirection &:= ccConf.REDIRECT_FILEDES_1 & toShellPath(errorFile);
redirection &:= ccConf.REDIRECT_FILEDES_2 & ccConf.NULL_DEVICE;
when {2}:
redirection &:= ccConf.REDIRECT_FILEDES_2 & toShellPath(errorFile);
redirection &:= ccConf.REDIRECT_FILEDES_1 & ccConf.NULL_DEVICE;
end case;
if length(redirection) = 0 then
shellResult := shell(command, shellParameters(parameters));
else
shellResult := shell(command, shellParameters(parameters) <& " " <&
join(redirection, " "));
end if;
if shellResult <> 0 then
writeln("*** The shell command returned " <& shellResult);
end if;
end func;
const proc: execProgram (in string: command, in array string: parameters,
in string: errorFile) is func
local
var file: childStdout is STD_NULL;
var file: childStderr is STD_NULL;
var process: aProcess is process.value;
begin
logProgram(command, parameters, errorFile);
case ccConf.CC_ERROR_FILEDES of
when {1}:
childStdout := open(errorFile, "w");
if childStdout = STD_NULL then
writeln("*** Could not open " <& errorFile);
end if;
when {2}:
childStderr := open(errorFile, "w");
if childStderr = STD_NULL then
writeln("*** Could not open " <& errorFile);
end if;
end case;
aProcess := startProcess(commandPath(command), parameters, STD_IN, childStdout, childStderr);
waitFor(aProcess);
case ccConf.CC_ERROR_FILEDES of
when {1}: close(childStdout);
when {2}: close(childStderr);
end case;
end func;
const proc: pass_3 (in string: sourcePath, in string: sourceExtension, in program: prog,
in optionHash: compilerOptions, inout boolean: okay) is func
local
var string: s7_lib_dir is "";
var string: seed7_lib is "";
var string: draw_lib is "";
var string: console_lib is "";
var string: database_lib is "";
var string: comp_data_lib is "";
var string: compiler_lib is "";
var string: special_lib is "";
var string: cwd is "";
var string: workDir is "";
var string: sourceFile is "";
var string: cSourceFile is "";
var string: cErrorFile is "";
var string: objectFile is "";
var string: linkErrFile is "";
var string: tempExeFile is "";
var string: linkedProgram is "";
var string: compile_cmd is "";
var array string: compileParams is 0 times "";
var string: link_cmd is "";
var array string: linkParams is 0 times "";
begin
if okay then
writeln("Calling the C compiler ...");
if ccConf.CC_ENVIRONMENT_INI <> "" then
importEnvironment(ccConf.CC_ENVIRONMENT_INI);
end if;
if "-b" in compilerOptions then
s7_lib_dir := convDosPath(compilerOptions["-b"]);
else
s7_lib_dir := ccConf.S7_LIB_DIR;
end if;
seed7_lib := s7_lib_dir & "/" & ccConf.SEED7_LIB;
draw_lib := s7_lib_dir & "/" & ccConf.DRAW_LIB;
console_lib := s7_lib_dir & "/" & ccConf.CONSOLE_LIB;
database_lib := s7_lib_dir & "/" & ccConf.DATABASE_LIB;
comp_data_lib := s7_lib_dir & "/" & ccConf.COMP_DATA_LIB;
compiler_lib := s7_lib_dir & "/" & ccConf.COMPILER_LIB;
special_lib := s7_lib_dir & "/" & ccConf.SPECIAL_LIB;
cwd := getcwd();
if rpos(sourcePath, "/") = 0 then
sourceFile := sourcePath;
else
if rpos(sourcePath, "/") = 1 then
chdir("/");
else
chdir(sourcePath[.. pred(rpos(sourcePath, "/"))]);
end if;
workDir := sourcePath[.. rpos(sourcePath, "/")];
sourceFile := sourcePath[succ(rpos(sourcePath, "/")) ..];
end if;
cSourceFile := "tmp_" & sourceFile;
if generate_c_plus_plus then
cSourceFile &:= ".cpp";
else
cSourceFile &:= ".c";
end if;
cErrorFile := "tmp_" & sourceFile & ".cerrs";
objectFile := "tmp_" & sourceFile & ccConf.OBJECT_FILE_EXTENSION;
linkErrFile := "tmp_" & sourceFile & ".lerrs";
tempExeFile := "tmp_" & sourceFile & ccConf.LINKED_PROGRAM_EXTENSION;
if sourceExtension = "" and ccConf.LINKED_PROGRAM_EXTENSION = "" then
linkedProgram := sourceFile & "_exe";
else
linkedProgram := sourceFile & ccConf.LINKED_PROGRAM_EXTENSION;
end if;
if fileType(objectFile) = FILE_REGULAR then
removeFile(objectFile);
end if;
if generate_c_plus_plus then
compile_cmd := ccConf.CPLUSPLUS_COMPILER;
else
compile_cmd := ccConf.C_COMPILER;
end if;
compileParams &:= ccConf.CC_OPT_NO_WARNINGS;
if enable_link_time_optimization then
compileParams &:= ccConf.CC_OPT_LINK_TIME_OPTIMIZATION;
end if;
if "-O" in compilerOptions then
case compilerOptions["-O"] of
when {"", "1"}:
compileParams &:= ccConf.CC_OPT_OPTIMIZE_1;
when {"2"}:
compileParams &:= ccConf.CC_OPT_OPTIMIZE_2;
when {"3"}:
compileParams &:= ccConf.CC_OPT_OPTIMIZE_3;
otherwise:
writeln("*** Ignore unsupported option: -O" <& compilerOptions["-O"]);
end case;
end if;
if integer_overflow_check and ccConf.CC_OPT_TRAP_OVERFLOW <> "" then
compileParams &:= ccConf.CC_OPT_TRAP_OVERFLOW;
end if;
if "-g" in compilerOptions then
compileParams &:= ccConf.CC_OPT_DEBUG_INFO;
if compilerOptions["-g"] <> "" and compilerOptions["-g"] <> "-debug_c" then
compileParams &:= compilerOptions["-g"];
end if;
end if;
if length(ccConf.CC_FLAGS) <> 0 then
compileParams &:= ccConf.CC_FLAGS;
end if;
compileParams &:= "-c";
compileParams &:= toOsPath(cSourceFile);
if ccConf.CALL_C_COMPILER_FROM_SHELL then
execProgramScript(compile_cmd, compileParams, cErrorFile);
else
execProgram(compile_cmd, compileParams, cErrorFile);
end if;
if fileType(cErrorFile) = FILE_REGULAR and
fileSize(cErrorFile) = 0 then
removeFile(cErrorFile);
end if;
if fileType(objectFile) <> FILE_REGULAR then
if fileType(cErrorFile) = FILE_REGULAR then
writeln("*** Errors in " <& literal(workDir & cSourceFile) <&
" - see " <& literal(workDir & cErrorFile));
elsif ccConf.CC_ERROR_FILEDES not in {1, 2} then
writeln("*** Compilation terminated");
else
writeln("*** Compilation terminated without error messages");
end if;
okay := FALSE;
elsif fileType(cErrorFile) = FILE_REGULAR then
removeFile(cErrorFile);
end if;
if okay then
if "-g" not in compilerOptions then
removeFile(cSourceFile);
end if;
if compilerLibraryUsed then
drawLibraryUsed := TRUE;
mathLibraryUsed := TRUE;
consoleLibraryUsed := TRUE;
databaseLibraryUsed := TRUE;
end if;
if fileType(seed7_lib) <> FILE_REGULAR then
writeln("*** Seed7 library " <& literal(seed7_lib) <& " missing");
okay := FALSE;
end if;
if drawLibraryUsed and fileType(draw_lib) <> FILE_REGULAR then
writeln("*** Draw library " <& literal(draw_lib) <& " missing");
okay := FALSE;
end if;
if consoleLibraryUsed and fileType(console_lib) <> FILE_REGULAR then
writeln("*** Console library " <& literal(console_lib) <& " missing");
okay := FALSE;
end if;
if databaseLibraryUsed and fileType(database_lib) <> FILE_REGULAR then
writeln("*** Database library " <& literal(database_lib) <& " missing");
okay := FALSE;
end if;
if compilerLibraryUsed and fileType(compiler_lib) <> FILE_REGULAR then
writeln("*** Compiler library " <& literal(compiler_lib) <& " missing");
okay := FALSE;
end if;
if compDataLibraryUsed and fileType(comp_data_lib) <> FILE_REGULAR then
writeln("*** Compiler data library " <& literal(comp_data_lib) <& " missing");
okay := FALSE;
end if;
if ccConf.LINKER_OPT_SPECIAL_LIB <> "" and fileType(special_lib) <> FILE_REGULAR then
writeln("*** Special library " <& literal(compiler_lib) <& " missing");
okay := FALSE;
end if;
if okay and not compileLibrary then
if fileType(linkedProgram) = FILE_REGULAR then
block
removeFile(linkedProgram);
exception
catch FILE_ERROR:
writeln("*** Cannot remove old executable: " <&
literal(linkedProgram));
end block;
end if;
if fileType(linkedProgram) = FILE_ABSENT then
writeln("Calling the linker ...");
if generate_c_plus_plus then
link_cmd := ccConf.CPLUSPLUS_COMPILER;
else
link_cmd := ccConf.C_COMPILER;
end if;
if enable_link_time_optimization or ccConf.LINKER_OPT_LTO_MANDATORY then
linkParams &:= ccConf.CC_OPT_LINK_TIME_OPTIMIZATION;
end if;
if "-g" in compilerOptions then
if ccConf.LINKER_OPT_DEBUG_INFO <> "" then
linkParams &:= ccConf.LINKER_OPT_DEBUG_INFO;
end if;
else
if ccConf.LINKER_OPT_NO_DEBUG_INFO <> "" then
linkParams &:= ccConf.LINKER_OPT_NO_DEBUG_INFO;
end if;
end if;
if ccConf.LINKER_OPT_STACK_SIZE <> "" then
linkParams &:= ccConf.LINKER_OPT_STACK_SIZE <& stack_size;
end if;
linkParams &:= ccConf.LINKER_FLAGS;
if ccConf.LINKER_OPT_OUTPUT_FILE <> "" then
if endsWith(ccConf.LINKER_OPT_OUTPUT_FILE, " ") then
linkParams &:= rtrim(ccConf.LINKER_OPT_OUTPUT_FILE);
linkParams &:= toOsPath(linkedProgram);
else
linkParams &:= ccConf.LINKER_OPT_OUTPUT_FILE &
toOsPath(linkedProgram);
end if;
end if;
linkParams &:= toOsPath(objectFile);
if compilerLibraryUsed then
appendLibrary(linkParams, toOsPath(compiler_lib));
end if;
if compDataLibraryUsed then
appendLibrary(linkParams, toOsPath(comp_data_lib));
end if;
if drawLibraryUsed then
appendLibrary(linkParams, toOsPath(draw_lib));
end if;
if consoleLibraryUsed then
appendLibrary(linkParams, toOsPath(console_lib));
end if;
if databaseLibraryUsed then
appendLibrary(linkParams, toOsPath(database_lib));
end if;
appendLibrary(linkParams, toOsPath(seed7_lib));
if ccConf.LINKER_OPT_SPECIAL_LIB <> "" then
appendLibrary(linkParams, ccConf.LINKER_OPT_SPECIAL_LIB);
appendLibrary(linkParams, toOsPath(special_lib));
end if;
appendLibrary(linkParams, ccConf.SYSTEM_LIBS);
if bigintLibraryUsed then
appendLibrary(linkParams, ccConf.SYSTEM_BIGINT_LIBS);
end if;
if consoleLibraryUsed then
appendLibrary(linkParams, ccConf.SYSTEM_CONSOLE_LIBS);
end if;
if databaseLibraryUsed then
appendLibrary(linkParams, ccConf.SYSTEM_DATABASE_LIBS);
end if;
if drawLibraryUsed then
appendLibrary(linkParams, ccConf.SYSTEM_DRAW_LIBS);
end if;
if mathLibraryUsed then
appendLibrary(linkParams, ccConf.SYSTEM_MATH_LIBS);
end if;
if ccConf.CALL_C_COMPILER_FROM_SHELL then
execProgramScript(link_cmd, linkParams, linkErrFile);
else
execProgram(link_cmd, linkParams, linkErrFile);
end if;
if ccConf.LINKER_OPT_OUTPUT_FILE = "" and
fileType(tempExeFile) = FILE_REGULAR then
moveFile(tempExeFile, linkedProgram);
end if;
if fileType(linkedProgram) <> FILE_REGULAR then
if fileType(linkErrFile) = FILE_REGULAR and
fileSize(linkErrFile) = 0 then
removeFile(linkErrFile);
end if;
if fileType(linkErrFile) = FILE_REGULAR then
writeln("*** Linker errors with " <& literal(workDir & objectFile) <&
" - see " <& literal(workDir & linkErrFile));
elsif ccConf.CC_ERROR_FILEDES not in {1, 2} then
writeln("*** Linking terminated");
else
writeln("*** Linking terminated without error messages");
end if;
elsif fileType(linkErrFile) = FILE_REGULAR then
removeFile(linkErrFile);
end if;
if "-g" not in compilerOptions then
removeFile(objectFile);
end if;
end if;
end if;
end if;
chdir(cwd);
end if;
end func;
const proc: writeHelp is func
begin
writeln("usage: s7c [options] source");
writeln;
writeln("Options:");
writeln(" -? Write Seed7 compiler usage.");
writeln(" -On Tell the C compiler to optimize with level n (n is between 1 and 3).");
writeln(" -O Equivalent to -O1");
writeln(" -S Specify the stack size of the executable (e.g.: -S 16777216).");
writeln(" -b Specify the directory of the Seed7 runtime libraries (e.g.: -b ../bin).");
writeln(" -c Specify configuration (C compiler, etc.) to be used (e.g.: -c emcc).");
writeln(" -e Generate code which sends a signal, if an uncaught exception occurs.");
writeln(" This option allows debuggers to handle uncaught Seed7 exceptions.");
writeln(" -flto Enable link time optimization.");
writeln(" -g Tell the C compiler to generate an executable with debug information.");
writeln(" This way the debugger will refer to Seed7 source files and line numbers.");
writeln(" To generate debug information which refers to the temporary C program");
writeln(" the option -g-debug_c can be used.");
writeln(" -l Add a directory to the include library search path (e.g.: -l ../lib).");
writeln(" -ocn Optimize generated C code with level n. E.g.: -oc3");
writeln(" The level n is a digit between 0 and 3:");
writeln(" 0 Do no optimizations with constants.");
writeln(" 1 Use literals and named constants to simplify expressions (default).");
writeln(" 2 Evaluate constant parameter expressions to simplify expressions.");
writeln(" 3 Like -oc2 and additionally evaluate all constant expressions.");
writeln(" -p Activate simple function profiling.");
writeln(" -sx Suppress checks specified with x. E.g.: -sr or -sro");
writeln(" The checks x are specified with letters from the following list:");
writeln(" d Suppress the generation of checks for integer division by zero.");
writeln(" i Suppress the generation of index checks (e.g. string, array).");
writeln(" o Suppress the generation of integer overflow checks.");
writeln(" r Suppress the generation of range checks.");
writeln(" -tx Set runtime trace level to x. Where x is a string consisting of:");
writeln(" d Trace dynamic calls");
writeln(" e Trace exceptions and handlers");
writeln(" f Trace functions");
writeln(" s Trace signals");
writeln(" -wn Specify warning level n. E.g.: -w2");
writeln(" The level n is a digit between 0 and 2:");
writeln(" 0 Omit warnings.");
writeln(" 1 Write normal warnings (default).");
writeln(" 2 Write warnings for raised exceptions.");
writeln;
end func;
const proc: main is func
local
var integer: index is 0;
var string: currArg is "";
var optionHash: compilerOptions is optionHash.value;
var string: source is "";
var string: sourcePath is "";
var string: sourceExtension is "";
var boolean: okay is TRUE;
begin
OUT := STD_UTF8_OUT;
writeln("SEED7 COMPILER Version 3.2." <& ccConf.VERSION_REVISION_LEVEL <&
" Copyright (c) 1990-2024 Thomas Mertes");
if length(argv(PROGRAM)) = 0 then
writeln("This is free software; see the source for copying conditions. There is NO");
writeln("warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.");
writeln("S7c is written in the Seed7 programming language");
writeln("Homepage: http://seed7.sourceforge.net");
writeln;
writeln("usage: s7c [options] source");
writeln;
writeln("Use s7c -? to get more information about s7c.");
writeln;
else
for index range 1 to length(argv(PROGRAM)) do
currArg := argv(PROGRAM)[index];
if length(currArg) >= 2 and currArg[1] = '-' then
if currArg in {"-b", "-c", "-S"} and index < length(argv(PROGRAM)) then
incr(index);
compilerOptions @:= [currArg] argv(PROGRAM)[index];
elsif currArg in {"-l"} and index < length(argv(PROGRAM)) then
incr(index);
libraryDirs &:= convDosPath(argv(PROGRAM)[index]);
elsif currArg[.. 2] in {"-?", "-b", "-c", "-e", "-f", "-g", "-o", "-p", "-s", "-t", "-w", "-O", "-S"} then
if currArg[.. 2] in compilerOptions then
if currArg[3 ..] = compilerOptions[currArg[.. 2]] then
writeln("*** Option " <& currArg <& " specified twice.");
else
writeln("*** Option " <& currArg[.. 2] <& " specified twice.");
end if;
okay := FALSE;
elsif currArg[.. 2] in {"-?", "-e", "-p"} and currArg[3 ..] <> "" then
writeln("*** Unsupported option: " <& currArg);
okay := FALSE;
else
compilerOptions @:= [currArg[.. 2]] currArg[3 ..];
end if;
else
writeln("*** Unsupported option: " <& currArg);
okay := FALSE;
end if;
elsif source = "" then
source := convDosPath(currArg);
else
writeln("*** Superfluous parameter: " <& currArg);
okay := FALSE;
end if;
end for;
if "-?" in compilerOptions then
writeHelp;
else
pass_1(source, prog, compilerOptions, okay);
if okay then
sourcePath := path(prog);
if endsWith(sourcePath, ".sd7") or
endsWith(sourcePath, ".s7i") then
sourceExtension := sourcePath[length(sourcePath) - 3 ..];
sourcePath := sourcePath[.. length(sourcePath) - 4];
end if;
end if;
pass_2(sourcePath, prog, okay);
pass_3(sourcePath, sourceExtension, prog, compilerOptions, okay);
end if;
end if;
end func;