int rdbc_query(rdb_handle handle, rdb_collection * collection, const char * rsql, IObject * obj)
{
rdbc_connection * cl = (rdbc_connection *)handle;
rdbc::pk_query pk;
pk.nodata = collection == NULL;
pk.rsql = rsql;
pk.obj = obj;
cl->Send(&pk);
int ret = -1;
do
{
cl->Select(0, 5);
rdbc::packet * i_pk = cl->GetResult();
if (TYPE_OF(rdbc::pk_object, i_pk))
{
rdbc::pk_object * pk = (rdbc::pk_object *)i_pk;
if (collection != NULL)
{
collection->PushBack(pk->obj);
}
}
else if (TYPE_OF(rdbc::pk_result, i_pk))
{
rdbc::pk_result * pk = (rdbc::pk_result *)i_pk;
ret = pk->ret;
if (ret == -1)
{
strcpy(cl->err, pk->error.c_str());
}
safe_delete (i_pk);
break;
}
safe_delete (i_pk);
} while (cl->Valid());
return ret;
}
TypeEd_ImageBox::TypeEd_ImageBox(MGUI::Widget * widget, MGUI::Widget * panel)
{
d_assert (TYPE_OF(MGUI::ImageBox, widget));
mImageBox = (MGUI::ImageBox *)widget;
float top = 0;
const float K_Space = 8;
mLabel_Image = new MGUI::Label(NULL, panel);
mLabel_Image->SetCaption(L"Image:");
mLabel_Image->SetRect(0, top, 64, 24);
mEditBox_Image = new MGUI::EditBox(AllLookFeel::Instance()->GetEditBox(), panel);
mEditBox_Image->SetRect(80, top, 162, 24);
top += 24 + K_Space;
mLabel_UVRect = new MGUI::Label(NULL, panel);
mLabel_UVRect->SetCaption(L"UVRect");
mLabel_UVRect->SetRect(0, top, 162, 24);
mEditBox_UVRect = new MGUI::EditBox(AllLookFeel::Instance()->GetEditBox(), panel);
mEditBox_UVRect->SetRect(80, top, 162, 24);
top += 24 + K_Space;
// Init
mEditBox_Image->SetCaption(mImageBox->GetSkin() != NULL ? mImageBox->GetSkin()->GetName().c_wstr() : L"");
mEditBox_UVRect->SetCaption(mImageBox->GetUVRect().ToString().c_wstr());
mEditBox_Image->E_KeyLostFocus += new cListener1<TypeEd_ImageBox, const MGUI::FocusEvent *>(this, &TypeEd_ImageBox::OnImageChanged);
mEditBox_UVRect->E_KeyLostFocus += new cListener1<TypeEd_ImageBox, const MGUI::FocusEvent *>(this, &TypeEd_ImageBox::OnUVRectChanged);
}
int _rdbc_waitresult(rdbc_connection * cl)
{
int ret = -1;
do
{
cl->Select(0, 5);
rdbc::packet * i_pk = cl->GetResult();
if (TYPE_OF(rdbc::pk_result, i_pk))
{
rdbc::pk_result * pk = (rdbc::pk_result *)i_pk;
ret = pk->ret;
if (ret == -1)
{
strcpy(cl->err, pk->error.c_str());
}
safe_delete (i_pk);
break;
}
safe_delete (i_pk);
} while (cl->Valid());
return ret;
}
static void sym_inits(Symbol sym, Symbol typ, Tuple sig, Symbol ali)
/*;sym_inits*/
{
/* initialize standard part of symbol. These are the fields used
* by both adasem and adagen.
*/
TYPE_OF(sym) = typ;
SIGNATURE(sym) = sig;
ALIAS(sym) = ali;
}
void FRendererSystem::OnAdded()
{
PointLightEntities = GetEntitySet({ TYPE_OF(FPointLightComponent) });
SpotLightEntities = GetEntitySet({ TYPE_OF(FSpotLightComponent) });
DirectionalLightEntities = GetEntitySet({ TYPE_OF(FDirectionalLightComponent) });
CameraEntities = GetEntitySet({ TYPE_OF(FCameraComponent) });
ModelEntities = GetEntitySet({ TYPE_OF(FMeshComponent), TYPE_OF(FTransformComponent) });
}
static Const eval_lit_map(Symbol obj) /*;eval_lit_map*/
{
Symbol typ;
Tuple tup;
int i;
typ = TYPE_OF(obj);
tup = (Tuple) literal_map(typ);
for (i = 1; i <= tup_size(tup); i += 2) {
if (ORIG_NAME(obj) == (char *)0) continue;
if (streq(tup[i], ORIG_NAME(obj)))
return int_const((int)tup[i+1]);
}
return const_new(CONST_OM);
/*(return literal_map(TYPE_OF(obj))(original_name(obj));*/
}
void ShaderProviderStandard::ApplyShaderFX(RenderObject * able, int flag)
{
if (able->GetShaderFX())
{
able->SetCurrentShaderFX(able->GetShaderFX());
}
else if (able->IsSkined())
{
able->SetCurrentShaderFX(mBaseFXSkined);
}
else
{
Node * node = able->_getNode();
if (TYPE_OF(Mesh, node))
{
Mesh * mesh = (Mesh *)node;
if (able->GetShaderProvider() == NULL)
{
if (mesh->GetSLMode() == eStaticLightingMode::LIGHTING_COLOR &&
able->GetRenderOp()->vertexBuffers[LIGHTING_COLOR_STREAM] != NULL)
{
able->SetCurrentShaderFX(mLightingColorFX);
}
else if (mesh->GetSLMode() == eStaticLightingMode::LIGHTING_MAP &&
able->GetMaterial()->maps[eMapType::LIGHTING_MAP] != NULL)
{
able->SetCurrentShaderFX(mLightingMapFX);
}
else
{
able->SetCurrentShaderFX(mBaseFX);
}
}
else
{
able->GetShaderProvider()->ApplyShaderFX(able, flag);
}
}
else
{
able->SetCurrentShaderFX(mBaseFX);
}
}
}
TypeEd_ComboBox::TypeEd_ComboBox(MGUI::Widget * editbox, MGUI::Widget * panel)
{
d_assert (TYPE_OF(MGUI::ComboBox, editbox));
mComboBox = (MGUI::ComboBox *)editbox;
float top = 0;
const float K_Space = 8;
mLabel_ItemHeight = new MGUI::Label(NULL, panel);
mLabel_ItemHeight->SetCaption(L"ItemHeight:");
mLabel_ItemHeight->SetRect(0, top, 64, 24);
mEditBox_ItemHeight = new MGUI::EditBox(AllLookFeel::Instance()->GetEditBox(), panel);
mEditBox_ItemHeight->SetRect(80, top, 162, 24);
top += 24 + K_Space;
mLabel_Font = new MGUI::Label(NULL, panel);
mLabel_Font->SetCaption(L"Font:");
mLabel_Font->SetRect(0, top, 64, 24);
mCombo_Font = new MGUI::ComboBox(AllLookFeel::Instance()->GetComboBox(), panel);
mCombo_Font->SetRect(80, top, 162, 24);
// Init
String caption;
caption.Format("%d", (int)mComboBox->GetItemHeight());
mEditBox_ItemHeight->SetCaption(caption.c_wstr());
for (int i = 0; i < MGUI::FontManager::Instance()->GetFontCount(); ++i)
{
MGUI::Font * pFont = MGUI::FontManager::Instance()->GetFont(i);
mCombo_Font->Append(pFont->GetName().c_wstr(), pFont);
if (mComboBox->_getFont() == pFont)
mCombo_Font->SetSelectIndex(i);
}
mEditBox_ItemHeight->E_KeyLostFocus += new cListener1<TypeEd_ComboBox, const MGUI::FocusEvent *>(this, &TypeEd_ComboBox::OnItemHeightChanged);
mCombo_Font->E_SelectChanged += new cListener2<TypeEd_ComboBox, const MGUI::Event *, int>(this, &TypeEd_ComboBox::OnFontChanged);
}
int needs_body(Symbol name) /*;needs_body*/
{
/* Procedures and function specs need bodies of course. So do package
* specs that contain objects which need bodies.
*/
Symbol obj;
char *id;
Fordeclared fd1;
int nat;
if (cdebug2 > 3) TO_ERRFILE("AT PROC : needs_body");
nat = NATURE(name);
if (nat == na_package_spec || nat == na_generic_package_spec) {
FORDECLARED(id, obj, DECLARED(name), fd1);
if (IS_VISIBLE(fd1) && obj->scope_of == name
&& needs_body(obj)) return TRUE;
ENDFORDECLARED(fd1);
FORDECLARED(id, obj, DECLARED(name), fd1)
if (TYPE_OF(obj) == symbol_incomplete) return TRUE;
ENDFORDECLARED(fd1);
return FALSE;
}
static Const const_val(Symbol obj) /*;const_val*/
{
/* Return the constant value of the object if it has one;
* else return om.
* The constant value of a user-defined constant is derived from
* its SIGNATURE, when this is a constant value.
* The constant value of a literal is obtained from the literal map
* of its type.
*/
Tuple sig;
if (cdebug2 > 3) TO_ERRFILE("const_val");
if (is_literal(obj)) return eval_lit_map(obj);
sig = SIGNATURE(obj);
if( is_constant(obj) && is_scalar_type(TYPE_OF(obj))
&& N_KIND((Node)sig) == as_ivalue) {
return (Const) N_VAL((Node)sig);
/* TBSL: could be static but not constant folded yet. */
}
else return const_new(CONST_OM);
}
BOOL HookCallCreateProcessFast(PVOID InvokeReturnAddress)
{
PBYTE InvokeBuffer;
PVOID *JumpAddressBegin, *JumpAddressEnd, HookRoutine;
PIMAGE_NT_HEADERS NtHeaders;
PLDR_MODULE Shell32;
InvokeBuffer = (PBYTE)InvokeReturnAddress;
LOOP_ONCE
{
if (*(PUSHORT)&InvokeBuffer[-6] != 0x15FF)
continue;
#if ML_X86
if (*(PULONG)&InvokeBuffer[-4] != (ULONG)Shell32CreateProcessWIAT)
break;
#elif ML_AMD64
if ((PVOID)PtrAdd(InvokeBuffer, *(PULONG)&InvokeBuffer[-4]) != Shell32CreateProcessWIAT)
break;
#endif // arch
Shell32 = FindLdrModuleByName(&WCS2US(L"SHELL32.dll"));
NtHeaders = RtlImageNtHeader(Shell32->DllBase);
if (NtHeaders == nullptr)
break;
JumpAddressEnd = (PVOID *)PtrAdd(Shell32->DllBase, ROUND_UP(NtHeaders->OptionalHeader.SizeOfHeaders, NtHeaders->OptionalHeader.SectionAlignment));
JumpAddressBegin = (PVOID *)(IMAGE_FIRST_SECTION(NtHeaders) + NtHeaders->FileHeader.NumberOfSections);
JumpAddressBegin = (PVOID *)ROUND_UP((ULONG_PTR)JumpAddressBegin, 16);
while (JumpAddressBegin < JumpAddressEnd)
{
#if ML_X86
if (
JumpAddressBegin[0] == nullptr &&
JumpAddressBegin[1] == nullptr &&
JumpAddressBegin[2] == nullptr &&
JumpAddressBegin[3] == nullptr
)
{
break;
}
JumpAddressBegin += 4;
#else
if (
JumpAddressBegin[0] == nullptr &&
JumpAddressBegin[1] == nullptr
)
{
break;
}
JumpAddressBegin += 2;
#endif
}
if (JumpAddressBegin >= JumpAddressEnd)
break;
HookRoutine = SpeedUpCreateProcessW;
WriteProtectMemory(CurrentProcess, JumpAddressBegin, &HookRoutine, sizeof(HookRoutine));
#if ML_X86
WriteProtectMemory(CurrentProcess, &InvokeBuffer[-4], &JumpAddressBegin, sizeof(JumpAddressBegin));
#elif ML_AMD64
LONG64 RelateOffset;
RelateOffset = (TYPE_OF(RelateOffset))PtrSub(JumpAddressBegin, InvokeBuffer);
WriteProtectMemory(CurrentProcess, &InvokeBuffer[-4], &RelateOffset, sizeof(LONG));
#endif
return TRUE;
}
return FALSE;
}
TypeEd_EditBox::TypeEd_EditBox(MGUI::Widget * editbox, MGUI::Widget * panel)
{
d_assert (TYPE_OF(MGUI::EditBox, editbox));
mEditBox = (MGUI::EditBox *)editbox;
float top = 0;
const float K_Space = 8;
mLabel_Caption = new MGUI::Label(NULL, panel);
mLabel_Caption->SetCaption(L"Caption:");
mLabel_Caption->SetRect(0, top, 64, 24);
mEditBox_Caption = new MGUI::EditBox(AllLookFeel::Instance()->GetEditBox(), panel);
mEditBox_Caption->SetRect(80, top, 162, 24);
top += 24 + K_Space;
mLabel_Font = new MGUI::Label(NULL, panel);
mLabel_Font->SetCaption(L"Font:");
mLabel_Font->SetRect(0, top, 64, 24);
mCombo_Font = new MGUI::ComboBox(AllLookFeel::Instance()->GetComboBox(), panel);
mCombo_Font->SetRect(80, top, 162, 24);
top += 24 + K_Space;
mLabel_TextAlign = new MGUI::Label(NULL, panel);
mLabel_TextAlign->SetCaption(L"TAlign:");
mLabel_TextAlign->SetRect(0, top, 64, 24);
mCombo_TextAlign = new MGUI::ComboBox(AllLookFeel::Instance()->GetComboBox(), panel);
mCombo_TextAlign->SetRect(80, top, 162, 24);
top += 24 + K_Space;
mLabel_TextColor = new MGUI::Label(NULL, panel);
mLabel_TextColor->SetCaption(L"TColor:");
mLabel_TextColor->SetRect(0, top, 64, 24);
mWidget_TextColor = new MGUI::Widget(AllLookFeel::Instance()->GetWhite(), panel);
mWidget_TextColor->SetRect(80, top, 162, 24);
// Init
mEditBox_Caption->SetCaption(mEditBox->GetCaption());
for (int i = 0; i < MGUI::FontManager::Instance()->GetFontCount(); ++i)
{
MGUI::Font * pFont = MGUI::FontManager::Instance()->GetFont(i);
mCombo_Font->Append(pFont->GetName().c_wstr(), pFont);
if (mEditBox->_getFont() == pFont)
mCombo_Font->SetSelectIndex(i);
}
mCombo_TextAlign->Append(L"Left");
mCombo_TextAlign->Append(L"Center");
mCombo_TextAlign->Append(L"Right");
mCombo_TextAlign->SetSelectIndex(0);
MGUI::eAlign align = mEditBox->GetTextAlign();
if (align == MGUI::eAlign::LEFT)
mCombo_TextAlign->SetSelectIndex(0);
else if (align == MGUI::eAlign::H_CENTER)
mCombo_TextAlign->SetSelectIndex(1);
else if (align == MGUI::eAlign::RIGHT)
mCombo_TextAlign->SetSelectIndex(2);
mWidget_TextColor->SetColor(mEditBox->GetTextColor());
mEditBox_Caption->E_KeyLostFocus += new cListener1<TypeEd_EditBox, const MGUI::FocusEvent *>(this, &TypeEd_EditBox::OnCaptionChanged);
mCombo_Font->E_SelectChanged += new cListener2<TypeEd_EditBox, const MGUI::Event *, int>(this, &TypeEd_EditBox::OnFontChanged);
mCombo_TextAlign->E_SelectChanged += new cListener2<TypeEd_EditBox, const MGUI::Event *, int>(this, &TypeEd_EditBox::OnTextAlignChanged);
mWidget_TextColor->E_MouseClick += new cListener1<TypeEd_EditBox, const MGUI::MouseEvent *>(this, &TypeEd_EditBox::OnTextColorChanged);
}
/* Object evaluation */
void gen_address(Node node) /*;gen_address*/
{
/*
* This procedure generates code for the o_expressions
* or, in other words, the left-handsides.
*/
Node pre_node, array_node, range_node, lbd_node, ubd_node, record_node,
field_node, id_node;
Symbol node_name, type_name, record_name, record_type,
field_name, comp_type, proc_name, return_type;
int f_off, bse, off, nk;
Fortup ft1;
#ifdef TRACE
if (debug_flag)
gen_trace_node("GEN_ADDRESS", node);
#endif
while (N_KIND(node) == as_insert) {
FORTUP(pre_node=(Node), N_LIST(node), ft1);
compile(pre_node);
ENDFORTUP(ft1);
node = N_AST1(node);
}
node_name = N_UNQ(node);
if (is_simple_name(node)) {
type_name = get_type(node);
if (is_renaming(node_name))
gen_ks(I_PUSH, mu_addr, node_name);
else
gen_s(I_PUSH_EFFECTIVE_ADDRESS, node_name);
/* Arrays are treated in a different manner, depending on their */
/* nature: parameters, constants, variables... */
if (is_array_type(type_name)) {
if (is_formal_parameter(node_name)) {
type_name = assoc_symbol_get(node_name, FORMAL_TEMPLATE);
}
gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name);
}
}
else {
switch (nk = N_KIND(node)) {
case as_raise:
compile(node);
break;
case as_index:
gen_subscript(node);
break;
case as_slice:
array_node = N_AST1(node);
range_node = N_AST2(node);
/*range_name = N_UNQ(range_node); -- never used ds 7-8-85 */
/* Note: case of type simple name changed into range attribute */
/* by expander */
if (N_KIND(range_node) == as_attribute) {
gen_attribute(range_node);
}
else { /* range */
lbd_node = N_AST1(range_node);
ubd_node = N_AST2(range_node);
gen_value(lbd_node);
gen_value(ubd_node);
}
if (N_KIND(array_node) == as_attribute) {
gen_attribute(array_node);
}
else {
gen_address(array_node);
}
gen(I_ARRAY_SLICE);
break;
case as_selector:
record_node = N_AST1(node);
field_node = N_AST2(node);
record_name = N_UNQ(record_node);
record_type = get_type(record_node);
field_name = N_UNQ(field_node);
f_off = FIELD_OFFSET(field_name);
if (f_off >= 0 &&
((! has_discriminant(record_type))
|| NATURE(field_name) == na_discriminant)){
if (is_simple_name(record_node)
&& !(is_renaming(record_name)) && is_global(record_name)) {
reference_of(record_name);
bse = REFERENCE_SEGMENT;
off = REFERENCE_OFFSET;
/* The SETL version has generate(I_PUSH_IMMEDIATE, mu_addr,
* ref, field_name);
* which we translate as (I_PUSH_EFFECTIVE_ADDRESS ...
* ref = [bse, off+f_off];
* Replace use of explicit ref by PUSH_IMMEDIATE
*/
/* gen_rc(I_PUSH_IMMEDIATE, explicit_ref_new(bse,
* off+f_off), "");
*/
gen_kv(I_PUSH_IMMEDIATE, mu_word, int_const(bse));
gen_kv(I_PUSH_IMMEDIATE, mu_word, int_const(off+f_off));
}
else {
gen_address(record_node);
if (f_off != 0 ) {
gen_ki(I_ADD_IMMEDIATE, mu_word, f_off);
}
}
if (is_array_type(comp_type=TYPE_OF(field_name))) {
gen_s(I_PUSH_EFFECTIVE_ADDRESS, comp_type);
}
}
else {
gen_address(record_node);
gen_s(I_PUSH_EFFECTIVE_ADDRESS, record_type);
/* translating following assuming field_name is comment part of
*-- instruction ds 7-5-86
* gen_i(I_SELECT, FIELD_NUMBER(field_name), field_name);
*/
gen_i(I_SELECT, (int) FIELD_NUMBER(field_name));
}
break;
case as_all:
id_node = N_AST1(node);
gen_value(id_node);
if (is_array_type(N_TYPE(node)))
gen_k(I_DEREF, mu_dble);
break;
case as_call:
id_node = N_AST1(node);
proc_name = N_UNQ(id_node);
return_type = TYPE_OF(proc_name);
gen_kc(I_DUPLICATE, kind_of(return_type), "place holder");
compile(node); /* processed from now as a procedure call */
break;
case as_un_op:
gen_unary(node);
break;
case as_op:
gen_binary(node);
break;
case as_string_ivalue:
gen_value(node);
break;
default:
compiler_error_k("GEN_ADDRESS called with kind ", node);
}
}
}
void gen_loop(Node node) /*;gen_loop*/
{
/* Generate loop stratements */
Node id_node, iter_node, stmt_node, while_cond_node, var_node,
exp1_node, exp2_node;
Symbol label_name, start_loop, start_while, end_while, var_name,
end_for, for_body, for_start, void_loop;
int end_inst;
int kind_var;
int needs_check;
Const val1, val2;
#ifdef TRACE
if (debug_flag)
gen_trace_node("GEN_LOOP", node);
#endif
id_node = N_AST1(node);
iter_node = N_AST2(node);
stmt_node = N_AST3(node);
if (id_node != OPT_NODE) {
label_name = N_UNQ(id_node);
labelmap_put(label_name, LABEL_STATIC_DEPTH, (char *) CURRENT_LEVEL);
next_local_reference(label_name);
gen_s(I_SAVE_STACK_POINTER, label_name);
}
if (iter_node == OPT_NODE) { /* simple loop */
start_loop = new_unique_name("loop");
gen_s(I_LABEL, start_loop);
compile(stmt_node);
gen_s(I_JUMP, start_loop );
if (id_node != OPT_NODE)
gen_s(I_LABEL, label_name);
}
else if (N_KIND(iter_node) == as_while) { /* while loop */
while_cond_node = N_AST1(iter_node);
start_while = new_unique_name("start_while");
end_while = new_unique_name("end_while");
gen_sc(I_JUMP, end_while, "Test better at end of loop");
gen_s(I_LABEL, start_while);
compile(stmt_node);
gen_s(I_LABEL, end_while);
gen_condition(while_cond_node, start_while, TRUE);
if (id_node != OPT_NODE)
gen_s(I_LABEL, label_name);
}
else { /* for loop */
var_node = N_AST1(iter_node);
exp1_node = N_AST2(iter_node);
exp2_node = N_AST3(iter_node);
var_name = N_UNQ(var_node);
next_local_reference(var_name);
kind_var = kind_of(TYPE_OF(var_name));
val1 = get_ivalue(exp1_node);
val2 = get_ivalue(exp2_node);
end_inst = ((N_KIND(iter_node) == as_for)) ?
I_END_FOR_LOOP : I_END_FORREV_LOOP;
/* Static null range already checked by expander */
if (val1->const_kind != CONST_OM && val2->const_kind != CONST_OM
&& get_ivalue_int(exp1_node) == get_ivalue_int(exp2_node)) {
/* Loop executed only once, remove loop */
gen_value(exp1_node);
gen_k(I_CREATE_COPY, kind_var);
gen_s(I_UPDATE_AND_DISCARD, var_name);
compile(stmt_node);
if (id_node != OPT_NODE)
gen_s(I_LABEL, label_name);
gen_s(I_PUSH_EFFECTIVE_ADDRESS, var_name);
gen(I_UNCREATE);
}
else {
needs_check = (val1->const_kind == CONST_OM
|| val2->const_kind == CONST_OM );
if (N_KIND(iter_node) == as_for) {
gen_value(exp2_node);
if (needs_check) {
gen_k(I_DUPLICATE, kind_var);
}
gen_value(exp1_node);
if (needs_check) {
gen_k(I_DUPLICATE, kind_var);
}
}
else {
gen_value(exp1_node);
if (needs_check) {
gen_k(I_DUPLICATE, kind_var);
}
gen_value(exp2_node);
if (needs_check) {
gen_k(I_DUPLICATE, kind_var);
}
}
for_start = new_unique_name("for_start");
for_body = new_unique_name("for_body");
end_for = new_unique_name("end_for");
if (needs_check) {
void_loop = new_unique_name("void");
gen_k(I_CREATE_COPY, kind_var);
gen_s(I_UPDATE_AND_DISCARD, var_name);
gen_k(I_COMPARE, kind_var);
if (N_KIND(iter_node) == as_for) {
gen_s(I_JUMP_IF_GREATER_OR_EQUAL, for_start);
}
else {
gen_s(I_JUMP_IF_LESS_OR_EQUAL, for_start);
}
gen_ks(I_POP, kind_var, var_name);
gen_s(I_JUMP, void_loop);
gen_s(I_LABEL, for_start);
gen_s(I_PUSH_EFFECTIVE_ADDRESS, var_name);
}
else
{ /* loop executed at least once, no need for check */
gen_k(I_CREATE_COPY, kind_var);
gen_s(I_UPDATE, var_name);
}
gen_s(I_LABEL, for_body);
compile(stmt_node);
gen_s(I_LABEL, end_for);
gen_ks(end_inst, kind_var, for_body );
if (id_node != OPT_NODE) {
gen_s(I_LABEL, label_name);
}
if (needs_check) {
gen_s(I_LABEL, void_loop);
}
gen_s(I_PUSH_EFFECTIVE_ADDRESS, var_name);
gen(I_UNCREATE);
} /* static null loop */
}
}
Node build_proc_init_rec(Symbol type_name) /*;build_proc_init_rec*/
{
/*
* This is the main procedure for building default initialization
* procedures for record types. Those initialization procedures are
* built if the type given contains some subcomponent for which a
* default initialization exists (at any level of nesting), or if it
* has determinants.
* Note that scalar objects are not initialized at all, which implies
* that they get whatever initial value is in that location in memory
* This saves some time in object creation.
*
* All init. procedures have an 'out' parameter that designates the
* object begin initialized (the space has already been allocated).
*
*/
int side_effect;
Node invar_node; /* TBSL: is invar_node local??*/
Tuple stmts, tup, nstmts, formals, invariant_fields;
Tuple discr_list; /* is this local ?? TBSL */
Fortup ft1;
Symbol d, proc_name;
Node param, var_node, out_param;
Node node, node1, node2, discr_value_node;
#ifdef TRACE
if (debug_flag)
gen_trace_symbol("BUILD_PROC_INIT_REC", type_name);
#endif
side_effect = FALSE; /* Let's hope... TBSL */
/*
* The initialization procedure for records has the usual out param.,
* and one in parameter per discriminant. The CONSTRAINED flag is the
* first of the discriminants
*/
proc_name = new_unique_name("Init_ type_name");
out_param = new_param_node("param_type_name", proc_name, type_name, na_out);
generate_object(proc_name);
generate_object(N_UNQ(out_param));
tup = SIGNATURE(type_name);
invar_node = (Node) tup[1];
var_node = (Node) tup[2];
discr_list = (Tuple) tup[3];
invariant_fields = build_comp_names(invar_node);
stmts = tup_new(0);
if (tup_size(discr_list)) {
/* Generate formal parameters for each. The body of the procedure */
/* assigns them to the field of the object. */
/* Note: the 'constrained' field is part of the discriminants. */
formals = tup_new(0);
FORTUP(d=(Symbol), discr_list, ft1);
param = new_param_node("param_type_name", proc_name, TYPE_OF(d),
na_in);
generate_object(N_UNQ(param));
formals = tup_with(formals, (char *) param );
stmts = tup_with(stmts,
(char *) new_assign_node(new_selector_node(out_param, d), param));
discr_value_node = new_selector_node (out_param, d);
/* generate code in order to test if the value of discriminant is
* compatible with its subtype
*/
node1 = new_attribute_node(ATTR_T_FIRST, new_name_node(TYPE_OF(d)),
OPT_NODE, TYPE_OF(d));
node2 = new_attribute_node(ATTR_T_LAST, new_name_node(TYPE_OF(d)),
OPT_NODE, TYPE_OF(d));
node = node_new (as_list);
make_if_node(node,
tup_new1((char *) new_cond_stmts_node( new_binop_node(symbol_or,
new_binop_node(symbol_lt, discr_value_node, node1,
symbol_boolean),
new_binop_node(symbol_gt, discr_value_node, node2,
symbol_boolean),
symbol_boolean),
new_raise_node(symbol_constraint_error))), OPT_NODE);
stmts = tup_with(stmts, (char *) node);
ENDFORTUP(ft1);
formals = tup_with(formals, (char *) out_param );
/* if there are default expressions for any other components, */
/* further initialization steps are needed. */
tup = proc_init_rec(type_name, invariant_fields, var_node, out_param);
/*stmts += proc_init_rec(invariant_fields, var_node, out_param);*/
nstmts = tup_add(stmts, tup);
tup_free(stmts);
tup_free(tup);
stmts = nstmts;
}
else {
/* record without discriminants. There may still be default values */
/* for some components. */
formals = tup_new1((char *) out_param);
stmts = proc_init_rec(type_name,invariant_fields,var_node, out_param);
}
if (tup_size(stmts)) {
INIT_PROC(type_name) = proc_name;
return initialization_proc(proc_name, type_name, formals, stmts);
}
else {
return OPT_NODE;
}
}
rdb_handle rdbc_open(const char * host, int port, const char * user, const char * passworld, int timeout)
{
rdbc_connection * cl = new rdbc_connection;
cl->Open(host, port);
cl->SetNonBlocking();
cl->SetLinger(0);
if (!cl->Connect(timeout))
{
cl->Close(0);
delete cl;
return NULL;
}
rdbc::pk_logon pk;
pk.username = user;
pk.password = passworld;
cl->Send(&pk);
bool hr = false;
do
{
cl->Select(0, 5);
rdbc::packet * i_pk = cl->GetResult();
if (TYPE_OF(rdbc::pk_auth, i_pk))
{
rdbc::pk_auth * pk = (rdbc::pk_auth *)i_pk;
if(cl->M == 0)
{
cl->M = pk->M;
memcpy(cl->K, pk->K, 16);
}
else
{
cl->Close(0);
}
}
else if (TYPE_OF(rdbc::pk_result, i_pk))
{
rdbc::pk_result * pk = (rdbc::pk_result *)i_pk;
hr = pk->ret >= 0;
safe_delete (i_pk);
break;
}
safe_delete (i_pk);
} while (cl->Valid());
if (!hr)
{
cl->Close(0);
delete cl;
cl = NULL;
}
return (rdb_handle)cl;
}
Node build_proc_init_ara(Symbol type_name) /*;build_proc_init_ara*/
{
/*
* This is the main procedure for building default initialization
* procedures for array types. Those initialization procedures are
* built if the type given contains some subcomponent for which a
* default initialization exists (at any level of nesting), or if it
* has determinants.
* Note that scalar objects are not initialized at all, which implies
* that they get whatever initial value is in that location in memory
* This saves some time in object creation.
*
* All init. procedures have an 'out' parameter that designates the
* object being initialized (the space has already been allocated).
*
*/
int side_effect;
Tuple tup, formals, subscripts;
Symbol c_type, ip, index_t, proc_name, index_sym;
Node one_component, init_stmt, out_param, i_nodes, d_node, iter_node;
Fortup ft1;
Node iterator, index_node;
#ifdef TRACE
if (debug_flag) {
gen_trace_symbol("BUILD_PROC_INIT_ARR", type_name);
}
#endif
side_effect = FALSE; /* Let's hope... TBSL */
tup = SIGNATURE(type_name);
c_type = (Symbol) tup[2];
one_component = new_node(as_index);
ip = INIT_PROC(base_type(c_type));
if (ip != (Symbol)0 ){
/* Use the initialization procedure for the component type */
init_stmt = (Node) build_init_call(one_component, ip, c_type, OPT_NODE);
}
else if (is_task_type(c_type)) {
/* initialization is task creation. */
init_stmt =
new_assign_node(one_component, new_create_task_node(c_type));
}
else if (is_access_type(c_type)) {
/* default value is the null pointer. */
init_stmt = new_assign_node(one_component, new_null_node(c_type));
}
else {
init_stmt = (Node) 0;
}
if (init_stmt != (Node)0) {
/* body of initialization procedure is a loop over the indices */
/* allocating each component. Generate loop variables and code */
/* for iteration, using the attributes of the type. */
proc_name = new_unique_name("type_name+INIT");
out_param = new_param_node("param_type_name", proc_name,
type_name, na_out);
generate_object(N_UNQ(out_param));
formals = tup_new1((char *) out_param);
subscripts = tup_new(0);
FORTUP(index_t=(Symbol), index_types(type_name), ft1);
/*index = index_t + 'INDEX';*/
index_sym = new_unique_name("index_t+INDEX");
NATURE (index_sym) = na_obj;
TYPE_OF(index_sym) = index_t;
subscripts = tup_with(subscripts, (char *)new_name_node(index_sym));
ENDFORTUP(ft1);
i_nodes = new_node(as_list);
/* need tup_copy since subscripts used destructively below */
N_LIST(i_nodes) = tup_copy(subscripts);
/* Build the tree for the one_component of the array. */
N_AST1(one_component) = out_param;
N_AST2(one_component) = i_nodes;
N_TYPE(one_component) = c_type;
while (tup_size(subscripts)) {
/* Build loop from innermost index outwards. The iterations */
/* span the ranges of the array being initialized. */
/* dimension spanned by this loop: */
d_node = new_ivalue_node(int_const(tup_size(subscripts)),
symbol_integer);
iterator = new_attribute_node(ATTR_O_RANGE,
new_name_node(N_UNQ(out_param)), d_node, type_name);
index_node = (Node) tup_frome(subscripts);
iter_node = new_node(as_for);
N_AST1(iter_node) = index_node;
N_AST2(iter_node) = iterator;
init_stmt = new_loop_node(OPT_NODE, iter_node,
tup_new1((char *)init_stmt));
}
INIT_PROC(type_name) = proc_name;
return initialization_proc(proc_name, type_name,
formals, tup_new1((char *) init_stmt));
}
else {
return OPT_NODE;
}
}
static Tuple proc_init_rec(Symbol type_name, Tuple field_names,
Node variant_node, Node out_param) /*;proc_init_rec*/
{
/*
* This is a subsidiary procedure to BUILD_PROC_INIT, which performs
* the recursive part of construction of an initialization procedure
* for a record type.
*
* Input: field_names is a list of component unique names (excluding
* discriminants. Variant node is the AST for the variant part
* of a component list.
* variant_node is the variant part of the record declaration
* and has the same structure as a case statement.
*
* out_param designates the object being initialized
*
* Output: the statement list required to initialize this fragment of
* the record, or [] if not default initialization is needed.
*/
Tuple init_stmt, stmts;
Node one_component, f_init, c_node, variant_list;
Symbol f_type, f_name, ip;
Fortup ft1;
int empty_case;
Tuple case_list, comp_case_list;
Node choice_list, comp_list, disc_node;
Node invariant_node, new_case, list_node, case_node;
Tuple tup, index_list;
int nb_dim, i;
Node d_node, node, node1, node2, node3, node4, node5;
Symbol one_index_type;
/* process fixed part first. */
init_stmt = tup_new(0);
FORTUP(f_name=(Symbol), field_names, ft1);
one_component = new_selector_node(out_param, f_name);
f_type = TYPE_OF(f_name);
CONTAINS_TASK(type_name) = (char *)
((int)CONTAINS_TASK(type_name) | (int) CONTAINS_TASK(f_type));
f_init = (Node) default_expr(f_name);
if (f_init != OPT_NODE) {
init_stmt = tup_with(init_stmt,
(char *) new_assign_node(one_component,
remove_discr_ref(f_init, out_param)));
}
else if ((ip = INIT_PROC(base_type(f_type)))!=(Symbol)0) {
init_stmt = tup_with(init_stmt,
(char *) build_init_call(one_component, ip, f_type, out_param));
}
else if (is_task_type(f_type)) {
init_stmt = tup_with(init_stmt, (char *)
new_assign_node(one_component, new_create_task_node(f_type)));
}
else if (is_access_type(f_type)) {
init_stmt = tup_with(init_stmt, (char *)
new_assign_node(one_component, new_null_node(f_type)));
}
/* if we have an aray then we have to check if its bounds are
* compatible with the index subtypes (of the unconstrained array)
* (This code was generated beforehand in type.c ("need_qual_r") but
* it was wrong : we have to test the bounds only if the field is
* present (case of variant record).
* The generation of the tests is easier here
*/
if (is_array_type (f_type)) {
tup = (Tuple) SIGNATURE(TYPE_OF(f_type));
index_list = tup_copy((Tuple) tup[1]);
nb_dim = tup_size(index_list);
for (i = 1; i <= nb_dim; i++) {
one_index_type = (Symbol) (tup_fromb (index_list));
d_node = new_ivalue_node(int_const(i), symbol_integer);
node1 = new_attribute_node(ATTR_O_FIRST,
one_component, d_node, one_index_type);
node2 = new_attribute_node(ATTR_O_LAST,
one_component, d_node, one_index_type);
node3 = new_attribute_node(ATTR_T_FIRST,
new_name_node(one_index_type), OPT_NODE, one_index_type);
node4 = new_attribute_node(ATTR_T_LAST,
new_name_node(one_index_type), OPT_NODE, one_index_type);
node5 = new_binop_node(symbol_or,
new_binop_node(symbol_lt, node1, node3, symbol_boolean),
new_binop_node(symbol_gt, node2, node4, symbol_boolean),
symbol_boolean);
node = node_new (as_list);
make_if_node(node,
tup_new1((char *) new_cond_stmts_node(
new_binop_node(symbol_and,
new_binop_node(symbol_le, node1, node2, symbol_boolean),
node5, symbol_boolean),
new_raise_node(symbol_constraint_error))), OPT_NODE);
init_stmt = tup_with(init_stmt, (char *) (node));
}
}
ENDFORTUP(ft1);
/* then build case statement to parallel structure of variant part. */
empty_case = TRUE; /* assumption */
if (variant_node != OPT_NODE) {
disc_node= N_AST1(variant_node);
variant_list = N_AST2(variant_node);
case_list = tup_new(0);
comp_case_list = N_LIST(variant_list);
FORTUP(c_node=(Node), comp_case_list, ft1);
choice_list = N_AST1(c_node);
comp_list = N_AST2(c_node);
invariant_node = N_AST1(comp_list);
variant_node = N_AST2(comp_list);
field_names = build_comp_names(invariant_node);
stmts = proc_init_rec(type_name,field_names,variant_node, out_param);
/*empty_case and= stmts = [];*/
empty_case = empty_case ? (tup_size(stmts)==0) : FALSE;
new_case = (N_KIND(c_node) == as_others_choice) ?
new_node(as_others_choice) : new_node(as_variant_choices);
N_AST1(new_case) = copy_tree(choice_list);
N_AST2(new_case) = new_statements_node(stmts);
case_list = tup_with(case_list, (char *) new_case );
ENDFORTUP(ft1);
if (! empty_case) {
/* Build a case statement ruled by the value of the discriminant */
/* for this variant part. */
list_node = new_node(as_list);
N_LIST(list_node) = case_list;
case_node = new_node(as_case);
N_AST1(case_node) = new_selector_node(out_param, N_UNQ(disc_node));
N_AST2(case_node) = list_node;
init_stmt = tup_with(init_stmt, (char *) case_node );
}
}
return init_stmt;
}
void init_sem() /*; init_sem */
{
Tuple constr_new, tup, boolean_constraint, constr_character, lmap;
Symbol s;
int i;
char *p, *p1;
Symbol sym;
char name[20];
static char *char_names[] = {
"NUL 0",
"SOH 1",
"STX 2",
"ETX 3",
"EOT 4",
"ENQ 5",
"ACK 6",
"BEL 7",
"BS 8",
"HT 9",
"LF 10",
"VT 11",
"FF 12",
"CR 13",
"SO 14",
"SI 15",
"DLE 16",
"DC1 17",
"DC2 18",
"DC3 19",
"DC4 20",
"NAK 21",
"SYN 22",
"ETB 23",
"CAN 24",
"EM 25",
"SUB 26",
"ESC 27",
"FS 28",
"GS 29",
"RS 30",
"US 31",
"EXCLAM 33",
"QUOTATION 34",
"SHARP 35",
"DOLLAR 36",
"PERCENT 37",
"AMPERSAND 38",
"COLON 58",
"SEMICOLON 59",
"QUERY 63",
"AT_SIGN 64",
"L_BRACKET 91",
"BACK_SLASH 92",
"R_BRACKET 93",
"CIRCUMFLEX 94",
"UNDERLINE 95",
"GRAVE 96",
"LC_A 97",
"LC_B 98",
"LC_C 99",
"LC_D 100",
"LC_E 101",
"LC_F 102",
"LC_G 103",
"LC_H 104",
"LC_I 105",
"LC_J 106",
"LC_K 107",
"LC_L 108",
"LC_M 109",
"LC_N 110",
"LC_O 111",
"LC_P 112",
"LC_Q 113",
"LC_R 114",
"LC_S 115",
"LC_T 116",
"LC_U 117",
"LC_V 118",
"LC_W 119",
"LC_X 120",
"LC_Y 121",
"LC_Z 122",
"L_BRACE 123",
"BAR 124",
"R_BRACE 125",
"TILDE 126",
"DEL 127",
" "
};
current_instances = tup_new(0);
lib_stub = tup_new(0);
seq_node = tup_new(400);
seq_node_n = 0;
seq_symbol = tup_new(100);
seq_symbol_n = 0;
unit_nodes = tup_new(0);
#ifdef TBSL
unit_nodes_n = 0;
#endif
stub_info = tup_new(0);
unit_number_now = 0;
init_nodes = tup_new(30);
init_symbols = tup_new(0);
interfaced_procedures = tup_new(0);
OPT_NODE = node_new(as_opt);
N_LIST(OPT_NODE) = tup_new(0);
init_node_save(OPT_NODE);
#ifdef IBM_PC
/* avoid copy of literal for PC */
#define setname(sym, str) ORIG_NAME(sym) = strjoin(str, "")
#else
#define setname(sym, str) ORIG_NAME(sym) = str
#endif
OPT_NAME = sym_new(na_obj);
setname(OPT_NAME, "opt_name");
#ifdef IBM_PC
#define sym_op_enter(sym, name) sym = sym_new(na_op); \
ORIG_NAME(sym) = strjoin(name, "");
#else
#define sym_op_enter(sym, name) sym = sym_new(na_op); ORIG_NAME(sym) = name;
#endif
symbol_integer = sym_new(na_type);
/* note that val_node1 sets N_TYPE field to symbol_integer, so must
* define symbol_integer before calling val_node1
*/
constr_new = constraint_new(CONSTRAINT_RANGE);
numeric_constraint_low(constr_new) = (char *) val_node1(ADA_MIN_INTEGER);
numeric_constraint_high(constr_new) = (char *)val_node1(ADA_MAX_INTEGER);
sym_inits(symbol_integer, symbol_integer, constr_new, symbol_integer);
sym_initg(symbol_integer, TK_WORD, 1, 3);
setname(symbol_integer, "INTEGER");
constr_new = constraint_new(CONSTRAINT_RANGE);
numeric_constraint_low(constr_new) = (char *) val_node1(-32768);
numeric_constraint_high(constr_new) = (char *) val_node1(32767);
symbol_short_integer_base = sym_new(na_type);
sym_inits(symbol_short_integer_base, symbol_integer,
constr_new, symbol_short_integer);
sym_initg(symbol_short_integer_base, TK_WORD, 1, 77);
setname(symbol_short_integer_base, "SHORT_INTEGER\'base");
symbol_short_integer = sym_new(na_type);
sym_inits(symbol_short_integer, symbol_short_integer_base,
SIGNATURE(symbol_short_integer_base), symbol_short_integer);
sym_initg(symbol_short_integer, TK_WORD, 1, 77);
setname(symbol_short_integer, "SHORT_INTEGER");
ALIAS(symbol_short_integer_base) = symbol_short_integer;
symbol_universal_integer = sym_new(na_type);
sym_inits(symbol_universal_integer , symbol_integer,
SIGNATURE(symbol_integer), symbol_integer);
sym_initg(symbol_universal_integer, TK_WORD, 1, 3);
setname(symbol_universal_integer, "universal_integer");
constr_new = constraint_new(CONSTRAINT_DIGITS);
numeric_constraint_low(constr_new) = (char *) val_node2(ADA_MIN_REAL);
numeric_constraint_high(constr_new) = (char *) val_node2(ADA_MAX_REAL);
numeric_constraint_digits(constr_new) = (char *) val_node1(ADA_REAL_DIGITS);
symbol_float = sym_new(na_type);
sym_inits(symbol_float, symbol_float, constr_new, symbol_float);
/* TBSL: there should be TK_REAL for floating point */
sym_initg(symbol_float, TK_LONG, 1, 73);
setname(symbol_float, "FLOAT");
symbol_universal_real = sym_new(na_type);
sym_inits(symbol_universal_real, symbol_float,
SIGNATURE(symbol_float), symbol_universal_real);
sym_initg(symbol_universal_real, TK_LONG, 1, 73);
setname(symbol_universal_real, "universal_real");
constr_new = constraint_new(CONSTRAINT_DELTA);
numeric_constraint_low(constr_new) = (char *) val_node3(rat_fri(int_fri(-1),
int_fri(0)));
numeric_constraint_high(constr_new) = (char *) val_node3(rat_fri(int_fri(1),
int_fri(0)));
numeric_constraint_delta(constr_new) =
(char *) val_node3(rat_fri(int_fri(0), int_fri(1)));
numeric_constraint_small(constr_new) = (char *) OPT_NODE;
symbol_dfixed = sym_new(na_type);
sym_inits(symbol_dfixed , symbol_dfixed, constr_new, symbol_dfixed);
sym_initg(symbol_dfixed, TK_LONG, 1, 67);
setname(symbol_dfixed, "$FIXED");
constr_new = constraint_new(CONSTRAINT_RANGE);
numeric_constraint_low(constr_new) = (char *) val_node1(0);
numeric_constraint_high(constr_new) = (char *) val_node1(ADA_MAX_INTEGER);
symbol_natural = sym_new(na_subtype);
sym_inits(symbol_natural , symbol_integer, constr_new, symbol_integer);
sym_initg(symbol_natural, TK_WORD, 1, 57);
setname(symbol_natural, "NATURAL");
constr_new = constraint_new(CONSTRAINT_RANGE);
numeric_constraint_low(constr_new) = (char *) val_node1(1);
numeric_constraint_high(constr_new) = (char *) val_node1(ADA_MAX_INTEGER);
symbol_positive = sym_new(na_subtype);
sym_inits(symbol_positive , symbol_integer,
constr_new, symbol_integer);
sym_initg(symbol_positive, TK_WORD, 1, 22);
setname(symbol_positive, "POSITIVE");
constr_new = constraint_new(CONSTRAINT_DELTA);
numeric_constraint_low(constr_new) = (char *)
val_node3(rat_fri(int_frs("-86400000"), int_fri(1000)));
numeric_constraint_high(constr_new) = (char *)
val_node3(rat_fri(int_frs("86400000"), int_fri(1000)));
numeric_constraint_delta(constr_new) =
(char *) val_node3(rat_fri(int_fri(1), int_fri(1000)));
numeric_constraint_small(constr_new) = (char *)val_node3(rat_fri(int_fri(1),
int_fri(1000)));
symbol_duration = sym_new(na_type);
sym_inits(symbol_duration , symbol_duration, constr_new, symbol_dfixed);
sym_initg(symbol_duration, TK_LONG, 1, 61);
setname(symbol_duration, "DURATION");
constr_character = constraint_new(CONSTRAINT_RANGE);
numeric_constraint_low(constr_character) = (char *) val_node1(0);
numeric_constraint_high(constr_character) = (char *) val_node1(127);
symbol_character = sym_new(na_enum);
sym_inits(symbol_character , symbol_character, constr_character,
symbol_character);
sym_initg(symbol_character, TK_WORD, 1, 43);
setname(symbol_character, "CHARACTER");
constr_new = constraint_new(CONSTRAINT_RANGE);
numeric_constraint_low(constr_new) = (char *)val_node1(0);
numeric_constraint_high(constr_new) = (char *) val_node1(1);
/* save constraint - needed to initialize symbol_constrained below*/
boolean_constraint = constr_new;
symbol_boolean = sym_new(na_enum);
sym_inits(symbol_boolean, symbol_boolean, constr_new, symbol_boolean);
sym_initg(symbol_boolean, TK_WORD, 1, 7);
setname(symbol_boolean, "BOOLEAN");
tup = tup_new(2);
tup[1] =(char *) tup_new1((char *) symbol_positive);
tup[2] = (char *) symbol_character;
symbol_string = sym_new(na_array);
sym_inits(symbol_string , symbol_string, tup, symbol_string);
sym_initg(symbol_string, -1, 1, 26);
setname(symbol_string, "STRING");
/* In SETL, symbol_string_type has a different signature from
* that defined by adasem. This symbol should never be
* used by the generator, so it seems safe to give it the
* same signature as is defined by adasem.
*/
/* symbol_character_type references should not be produced by adasem.
* However, in those cases where they do occur they should be treated
* the same as for symbol_character, so we initialize
* symbol_character_type to correspond to symbol_character.
* ds 9-26-85
*/
symbol_character_type = sym_new(na_enum);
sym_inits(symbol_character_type , symbol_character, constr_character,
symbol_character);
sym_initg(symbol_character_type, TK_WORD, 1, 43);
setname(symbol_character_type, "character_type");
symbol_string_type = sym_new(na_array);
tup = tup_new(2);
tup[1] =(char *) tup_new1((char *) symbol_positive);
tup[2] = (char *) symbol_character_type;
sym_inits(symbol_string_type , symbol_string_type, tup, symbol_string_type);
sym_initg(symbol_string_type, -1, 1, 26);
setname(symbol_string_type, "string_type");
symbol_daccess = sym_new(na_access);
sym_inits(symbol_daccess , symbol_daccess, tup_new(0), symbol_daccess);
sym_initg(symbol_daccess, TK_ADDR, 1, 1);
setname(symbol_daccess, "$ACCESS");
symbol_null = sym_new(na_obj);
sym_inits(symbol_null , symbol_daccess, tup_new(0), symbol_null);
sym_initg(symbol_null, TK_ADDR, 255, 32767);
setname(symbol_null, "null");
symbol_main_task_type = sym_new(na_task_type);
sym_inits(symbol_main_task_type , symbol_main_task_type, tup_new(0),
symbol_main_task_type);
sym_initg(symbol_main_task_type, TK_WORD, 1, 47);
setname(symbol_main_task_type, "main_task_type");
/* The signature for symbol_constrained is its default_expr,
* and corresponds to the first value entered for symbol boolean (FALSE)
*/
symbol_constrained = sym_new(na_discriminant);
sym_inits(symbol_constrained , symbol_boolean,
(Tuple) numeric_constraint_low(boolean_constraint), symbol_constrained);
sym_initg(symbol_constrained, 0, 0, 0);
setname(symbol_constrained, "constrained");
symbol_none = sym_new(na_type);
sym_inits(symbol_none , symbol_none, (Tuple)0, symbol_none);
sym_initg(symbol_none, 0, 0, 0);
setname(symbol_none, "none");
symbol_standard0 = sym_new(na_package);
setname(symbol_standard0, "STANDARD#0");
symbol_undef = sym_new(na_obj); /* for '?' case */
setname(symbol_undef, "?-undef");
symbol_standard = sym_new(na_package);
setname(symbol_standard, "standard");
symbol_unmentionable = sym_new(na_package);
setname(symbol_unmentionable, "unmentionable");
symbol_ascii = sym_new(na_package);
setname(symbol_ascii, "ASCII");
symbol_long_integer = sym_new(na_type);
setname(symbol_long_integer, "LONG_INTEGER");
symbol_long_float = sym_new(na_type);
setname(symbol_long_float, "LONG_FLOAT");
symbol_universal_fixed = sym_new(na_type);
setname(symbol_universal_fixed, "universal_fixed");
symbol_array_type = sym_new(na_array);
setname(symbol_array_type, "array_type");
symbol_discrete_type = sym_new(na_type);
setname(symbol_discrete_type, "discrete_type");
symbol_universal_integer_1 = sym_new(na_obj);
setname(symbol_universal_integer_1, "I:1");
symbol_any = sym_new(na_type);
setname(symbol_any, "any");
symbol_any_id = sym_new(na_obj);
root_type(symbol_any_id) = symbol_any;
setname(symbol_any_id, "any_id");
symbol_left = sym_new(na_in);
setname(symbol_left, "LEFT");
symbol_right = sym_new(na_in);
setname(symbol_right, "RIGHT");
symbol_boolean_type = sym_new(na_type);
setname(symbol_boolean_type, "boolean_type");
sym_op_enter(symbol_not, "not");
sym_op_enter(symbol_and, "and");
sym_op_enter(symbol_or, "or");
sym_op_enter(symbol_xor, "xor");
sym_op_enter(symbol_andthen, "andthen");
sym_op_enter(symbol_orelse, "orelse");
sym_op_enter(symbol_assign, ":=");
sym_op_enter(symbol_eq, "=");
sym_op_enter(symbol_ne, "/=");
sym_op_enter(symbol_in, "IN");
sym_op_enter(symbol_notin, "NOTIN");
symbol_order_type = sym_new(na_type);
setname(symbol_order_type, "order_type");
sym_op_enter(symbol_lt, "<");
sym_op_enter(symbol_le, "<=");
sym_op_enter(symbol_ge, ">=");
sym_op_enter(symbol_gt, ">");
symbol_numeric = sym_new(na_void);
setname(symbol_numeric, "numeric");
sym_op_enter(symbol_addu, "+u");
sym_op_enter(symbol_subu, "-u");
sym_op_enter(symbol_abs, "abs");
sym_op_enter(symbol_add, "+");
sym_op_enter(symbol_sub, "-");
sym_op_enter(symbol_mul, "*");
sym_op_enter(symbol_div, "/");
sym_op_enter(symbol_mod, "mod");
sym_op_enter(symbol_rem, "rem");
sym_op_enter(symbol_exp, "**");
sym_op_enter(symbol_cat, "&");
sym_op_enter(symbol_cat_cc, "&cc");
sym_op_enter(symbol_cat_ac, "&ac");
sym_op_enter(symbol_cat_ca, "&ca");
s = sym_new(na_op);
#ifdef IBM_PC
ORIG_NAME(s) = strjoin("any_op", "");
#else
ORIG_NAME(s) = "any_op";
#endif
sym_op_enter(symbol_modi, "modi");
sym_op_enter(symbol_remi, "remi");
sym_op_enter(symbol_addui, "+ui");
sym_op_enter(symbol_subui, "-ui");
sym_op_enter(symbol_absi, "absi");
sym_op_enter(symbol_addi, "+i");
sym_op_enter(symbol_subi, "-i");
sym_op_enter(symbol_muli, "*i");
sym_op_enter(symbol_divi, "/i");
sym_op_enter(symbol_addufl, "+ufl");
sym_op_enter(symbol_subufl, "-ufl");
sym_op_enter(symbol_absfl, "absfl");
sym_op_enter(symbol_addfl, "+fl");
sym_op_enter(symbol_subfl, "-fl");
sym_op_enter(symbol_mulfl, "*fl");
sym_op_enter(symbol_divfl, "/fl");
sym_op_enter(symbol_addufx, "+ufx");
sym_op_enter(symbol_subufx, "-ufx");
sym_op_enter(symbol_absfx, "absfx");
sym_op_enter(symbol_addfx, "+fx");
sym_op_enter(symbol_subfx, "-fx");
sym_op_enter(symbol_mulfx, "*fx");
sym_op_enter(symbol_divfx, "/fx");
sym_op_enter(symbol_mulfxi, "*fxi");
sym_op_enter(symbol_mulifx, "*ifx");
sym_op_enter(symbol_divfxi, "/fxi");
sym_op_enter(symbol_mulfli, "*fli");
sym_op_enter(symbol_mulifl, "*ifl");
sym_op_enter(symbol_divfli, "/fli");
sym_op_enter(symbol_expi, "**i");
sym_op_enter(symbol_expfl, "**fl");
symbol_exception = sym_new(na_exception);/* ?? check this */
symbol_constraint_error = sym_new (na_exception);
setname(symbol_constraint_error, "CONSTRAINT_ERROR");
symbol_numeric_error = sym_new(na_exception);
setname(symbol_numeric_error, "NUMERIC_ERROR");
symbol_program_error = sym_new(na_exception);
setname(symbol_program_error, "PROGRAM_ERROR");
symbol_storage_error = sym_new(na_exception);
setname(symbol_storage_error, "STORAGE_ERROR");
symbol_tasking_error = sym_new(na_exception);
setname(symbol_tasking_error, "TASKING_ERROR");
symbol_system_error = sym_new(na_exception);
setname(symbol_system_error, "SYSTEM_ERROR");
/*
* Printable characters are entered into SYMBTAB, as overloaded
* literals whose source name is the character between single quotes.
*/
{
int i;
char *s;
Symbol sy;
lmap = tup_new(2 * 128);
for (i = 0; i <= 127; i++ ) {
s = smalloc(4);
s[3] = '\0';
s[0] = '\'';
s[1] = i;
s[2] = '\'';
lmap[2 * i + 1] = s;
lmap[2 * i + 2] =(char *) i;
/* if (i>=32 && i<=126 ) -- all ascii chars entered in SYMBTAB */
sy = sym_new(na_literal);
ORIG_NAME(sy) = s;
}
literal_map(symbol_character) =(Set) lmap;
}
for (i = 0; p = char_names[i]; i++) {
if (p[0] == ' ')
break;
p1 = strchr(p, ' ');
if (p1 == p)
break;
sym = sym_new(na_constant);
TYPE_OF(sym) = symbol_character;
SIGNATURE(sym) =(Tuple) val_nodea1(atoi(p1));
name[0] = '\0';
strncat(name, p, p1 - p); /* extract string with name */
setname(sym, strjoin(name, "")); /* p1 points to original name */
}
s = sym_new(na_literal);
setname(s, "FALSE");
TYPE_OF(s) = symbol_boolean;
s = sym_new(na_literal);
setname(s, "TRUE");
TYPE_OF(s) = symbol_boolean;
{
char *litname;
lmap = tup_new(4);
litname = smalloc(6);
lmap[1] = strcpy(litname, "FALSE");
lmap[2] = (char *) 0;
litname = smalloc(5);
lmap[3] = strcpy(litname, "TRUE");
lmap[4] =(char *) 1;
literal_map(symbol_boolean) =(Set) lmap;
}
/* The only predefined aggregate is the one for string literals.*/
sym_new(na_aggregate);
/* Next four symbols introduced for maps incp_types, priv_types */
symbol_private = sym_new(na_type);
setname(symbol_private, "private");
symbol_limited_private = sym_new(na_type);
setname(symbol_limited_private, "limited_private");
symbol_limited = sym_new(na_type);
setname(symbol_limited, "limited");
symbol_incomplete = sym_new(na_type);
setname(symbol_incomplete, "incomplete");
/* the following symbols are used as markers by check_type in chapter 4 */
symbol_universal_type = sym_new(na_void);
setname(symbol_universal_type, "universal_type");
symbol_integer_type = sym_new(na_void);
setname(symbol_integer_type, "integer_type");
symbol_real_type = sym_new(na_void);
setname(symbol_real_type, "real_type");
symbol_composite_type = sym_new(na_void);
setname(symbol_composite_type, "composite_type");
symbol_equal_type = sym_new(na_void);
setname(symbol_equal_type, "equal_type");
/* new symbol definitions that are common with the code generator should */
/* be placed before this comment. */
/* 'task_block' is marker symbol used in expand.c - it need never be
* written out
*/
symbol_task_block = sym_new(na_void);
/* Initialize bounds of predefined types. */
/* Note that val_node is only called from this procedure, so that
* calling sequence can be changed if necessary; moreover the code
* should be put in this module, not in utilities
*/
/* set size of init_nodes.
* NOTE, must NOT make any new entries to init_nodes after
* doing assignment of tup_size below ds 24 sep 84
*/
init_nodes[0] = (char *)init_node_count;
#ifdef DEBUG
if (list_unit_0)
zpunit(0);
#endif
}
void radc_compiler::compile(int options)
{
if (_cache_program != -1)
{
varlist = programs[_cache_program].value->varlist;
statements = programs[_cache_program].value->statements;
return ;
}
char * str = buffer.c_ptr();
int line = 1;
int depth = 0;
_options = options;
while (*str && !is_error())
{
str = str_skip(str, ' ');
if (*str == '#') // comment
{
while (*str && *str != '\n')
++str;
if (*str == '\n')
++str;
continue;
}
char * line_str = str;
int line_length = 0;
while (*str && *str != '\n')
{
++str;
++line_length;
}
if (*str == '\n')
{
*str = 0;
++str;
}
str_trim(line_str, line_length);
if (*line_str)
{
const char * matched_str = NULL;
radc_stat * stat = NULL;
bool insert_empty = false;
do
{
matched_str = str_match(line_str, "function");
if (matched_str && (*matched_str == ' ' || *matched_str == '\0'))
{
matched_str = str_skip(matched_str, ' ');
matched_str = str_match(matched_str, "main");
if (matched_str)
{
stat = new rstat_entry;
stat->str = str_skip(matched_str, ' ');
}
else
{
set_error("Error: [%d] - main.", line);
}
depth += 1;
break;
}
matched_str = str_match(line_str, "if");
if (matched_str && (*matched_str == ' ' || *matched_str == '\0'))
{
stat = new rstat_if;
stat->str = str_skip(matched_str, ' ');
insert_empty = true;
depth += 1;
break;
}
matched_str = str_match(line_str, "else");
if (matched_str && (*matched_str == ' ' || *matched_str == '\0'))
{
matched_str = str_skip(matched_str, ' ');
const char * matched_str2 = str_match(matched_str, "if");
if (matched_str2 && (*matched_str2 == ' ' || *matched_str2 == '\0'))
{
stat = new rstat_elseif;
stat->str = str_skip(matched_str2, ' ');
insert_empty = true;
}
else
{
stat = new rstat_else;
stat->str = str_skip(matched_str, ' ');
insert_empty = true;
}
break;
}
matched_str = str_match(line_str, "end");
if (matched_str && (*matched_str == ' ' || *matched_str == '\0'))
{
stat = new rstat_end;
stat->str = str_skip(matched_str, ' ');
depth -= 1;
break;
}
matched_str = str_match(line_str, "while");
if (matched_str && (*matched_str == ' ' || *matched_str == '\0'))
{
stat = new rstat_while;
stat->str = str_skip(matched_str, ' ');
insert_empty = true;
depth += 1;
break;
}
matched_str = str_match(line_str, "return");
if (matched_str && (*matched_str == ' ' || *matched_str == '\0'))
{
stat = new rstat_return;
stat->str = str_skip(matched_str, ' ');
break;
}
stat = new rstat_exp;
stat->str = str_skip(line_str, ' ');
} while (0);
if (stat != NULL)
{
stat->line = line;
statements.PushBack(stat);
if (insert_empty)
{
statements.PushBack(new rstat_empty);
}
}
}
++line;
}
if (!is_error() && depth != 0)
{
set_error("Error: end don't macthed.");
}
// if Ìøת
for (int i = 0; i < statements.Size(); ++i)
{
if (TYPE_OF(rstat_if, statements[i]) ||
TYPE_OF(rstat_elseif, statements[i]) ||
TYPE_OF(rstat_else, statements[i]))
{
int in_if = 0, end_if = 0;
for (int j = i + 1; j < statements.Size(); ++j)
{
if (TYPE_OF(rstat_elseif, statements[j]) ||
TYPE_OF(rstat_else, statements[j]) ||
TYPE_OF(rstat_end, statements[j]))
{
if (in_if == 0)
{
end_if = j - 1;
statements[i]->jump = j;
break;
}
}
if (TYPE_OF(rstat_if, statements[j]) ||
TYPE_OF(rstat_while, statements[j]))
{
in_if += 1;
}
if (TYPE_OF(rstat_end, statements[j]))
{
in_if -= 1;
}
}
d_assert (end_if > i);
in_if = 0;
for (int j = end_if + 1; j < statements.Size(); ++j)
{
if (TYPE_OF(rstat_end, statements[j]))
{
if (in_if == 0)
{
statements[end_if]->jump = j;
break;
}
}
if (TYPE_OF(rstat_if, statements[j]) ||
TYPE_OF(rstat_while, statements[j]))
{
in_if += 1;
}
if (TYPE_OF(rstat_end, statements[j]))
{
in_if -= 1;
}
}
}
}
// while Ìøת
for (int i = 0; i < statements.Size(); ++i)
{
if (TYPE_OF(rstat_while, statements[i]))
{
int in_while = 0, end_while = 0;
for (int j = i + 1; j < statements.Size(); ++j)
{
if (TYPE_OF(rstat_end, statements[j]))
{
if (in_while == 0)
{
end_while = j - 1;
statements[i]->jump = j;
break;
}
}
if (TYPE_OF(rstat_if, statements[j]) ||
TYPE_OF(rstat_while, statements[j]))
{
in_while += 1;
}
if (TYPE_OF(rstat_end, statements[j]))
{
in_while -= 1;
}
}
d_assert (end_while > i);
statements[end_while]->jump = i;
}
}
for (int i = 0; i < statements.Size(); ++i)
{
statements[i]->build();
}
}