static void select_move(Node node, Symbol type_name) /*;select_move*/
{
if (is_simple_type(type_name)) {
if ((N_KIND(node) != as_null
&& is_simple_name(node) && !is_renaming(N_UNQ(node)))
|| (N_KIND(node) == as_selector || N_KIND(node) == as_index
|| N_KIND(node) == as_all)) {
gen_address(node);
gen_k(I_INDIRECT_MOVE, kind_of(type_name));
}
else {
gen_value(node);
gen_k(I_MOVE, kind_of(type_name));
}
}
else {
if (is_array_type(type_name)) {
gen_value(node);
gen(I_ARRAY_MOVE);
}
else {
gen_value(node);
gen_s(I_RECORD_MOVE, type_name);
}
}
}
static void
do_encrypt(gcry_mpi_t a, gcry_mpi_t b, gcry_mpi_t input, ELG_public_key *pkey )
{
gcry_mpi_t k;
/* Note: maybe we should change the interface, so that it
* is possible to check that input is < p and return an
* error code.
*/
k = gen_k( pkey->p, 1 );
gcry_mpi_powm( a, pkey->g, k, pkey->p );
/* b = (y^k * input) mod p
* = ((y^k mod p) * (input mod p)) mod p
* and because input is < p
* = ((y^k mod p) * input) mod p
*/
gcry_mpi_powm( b, pkey->y, k, pkey->p );
gcry_mpi_mulm( b, b, input, pkey->p );
#if 0
if( DBG_CIPHER )
{
log_mpidump("elg encrypted y= ", pkey->y);
log_mpidump("elg encrypted p= ", pkey->p);
log_mpidump("elg encrypted k= ", k);
log_mpidump("elg encrypted M= ", input);
log_mpidump("elg encrypted a= ", a);
log_mpidump("elg encrypted b= ", b);
}
#endif
mpi_free(k);
}
/*
* Return the signature struct (r,s) from the message hash. The caller
* must have allocated R and S.
*/
static gpg_err_code_t
sign (gcry_mpi_t input, ECC_secret_key *skey, gcry_mpi_t r, gcry_mpi_t s)
{
gpg_err_code_t err = 0;
gcry_mpi_t k, dr, sum, k_1, x;
mpi_point_t I;
mpi_ec_t ctx;
k = NULL;
dr = mpi_alloc (0);
sum = mpi_alloc (0);
k_1 = mpi_alloc (0);
x = mpi_alloc (0);
point_init (&I);
mpi_set_ui (s, 0);
mpi_set_ui (r, 0);
ctx = _gcry_mpi_ec_init (skey->E.p, skey->E.a);
while (!mpi_cmp_ui (s, 0)) /* s == 0 */
{
while (!mpi_cmp_ui (r, 0)) /* r == 0 */
{
/* Note, that we are guaranteed to enter this loop at least
once because r has been intialized to 0. We can't use a
do_while because we want to keep the value of R even if S
has to be recomputed. */
mpi_free (k);
k = gen_k (skey->E.n, GCRY_STRONG_RANDOM);
_gcry_mpi_ec_mul_point (&I, k, &skey->E.G, ctx);
if (_gcry_mpi_ec_get_affine (x, NULL, &I, ctx))
{
if (DBG_CIPHER)
log_debug ("ecc sign: Failed to get affine coordinates\n");
err = GPG_ERR_BAD_SIGNATURE;
goto leave;
}
mpi_mod (r, x, skey->E.n); /* r = x mod n */
}
mpi_mulm (dr, skey->d, r, skey->E.n); /* dr = d*r mod n */
mpi_addm (sum, input, dr, skey->E.n); /* sum = hash + (d*r) mod n */
mpi_invm (k_1, k, skey->E.n); /* k_1 = k^(-1) mod n */
mpi_mulm (s, k_1, sum, skey->E.n); /* s = k^(-1)*(hash+(d*r)) mod n */
}
leave:
_gcry_mpi_ec_free (ctx);
point_free (&I);
mpi_free (x);
mpi_free (k_1);
mpi_free (sum);
mpi_free (dr);
mpi_free (k);
return err;
}
void gen_case(Tuple case_table, Tuple bodies_arg, Node others_body,int mem_unit)
/*;gen_case*/
{
/* Generates the code to select the right alternative and the bodies */
int index, lower_bound, i, n;
Node body_node;
Symbol end_case, jumpsym;
Tuple jump_table, tup;
Fortup ft1;
Tuple bodies;
bodies = tup_copy(bodies_arg); /* copy needed since used in tup_fromb */
end_case = new_unique_name("end_case");
gen_k(I_CASE, mem_unit);
/* The SETL jump_table map is represented as a 'tuple map' in C, with
* procedures jump_table_get() and jump_table_put() (defined below) used
* to retrieve and insert values in this map.
*/
jump_table = tup_new(0);
jump_table = jump_table_put(jump_table, 0, new_unique_name("case"));
gen_ks(I_CASE_TABLE, tup_size(case_table), jump_table_get(jump_table, 0) );
FORTUP(tup = (Tuple), case_table, ft1);
lower_bound = (int) tup[1];
index = (int) tup[2];
jumpsym = jump_table_get(jump_table, index);
if (jumpsym == (Symbol)0) { /* if no entry yet, make new one */
jumpsym = new_unique_name("case");
jump_table = jump_table_put(jump_table, index, jumpsym);
}
gen_ks(I_CASE_TABLE, lower_bound, jumpsym);
ENDFORTUP(ft1);
index = 0;
bodies = tup_exp(bodies, tup_size(bodies) + 1);
n = tup_size(bodies);
for (i = n; i > 1; i--) {
bodies[i] = bodies[i-1];
}
bodies[1] = (char *) others_body;
while (tup_size(bodies) != 0) {
body_node = (Node) tup_fromb(bodies);
gen_s(I_LABEL, jump_table_get(jump_table, index));
compile(body_node);
if (tup_size(bodies) != 0) { /* to avoid useless "jump $+1" */
gen_s(I_JUMP, end_case );
}
index += 1;
}
gen_s(I_LABEL, end_case);
tup_free(bodies);
}
static void
sign(gcry_mpi_t a, gcry_mpi_t b, gcry_mpi_t input, ELG_secret_key *skey )
{
gcry_mpi_t k;
gcry_mpi_t t = mpi_alloc( mpi_get_nlimbs(a) );
gcry_mpi_t inv = mpi_alloc( mpi_get_nlimbs(a) );
gcry_mpi_t p_1 = mpi_copy(skey->p);
/*
* b = (t * inv) mod (p-1)
* b = (t * inv(k,(p-1),(p-1)) mod (p-1)
* b = (((M-x*a) mod (p-1)) * inv(k,(p-1),(p-1))) mod (p-1)
*
*/
mpi_sub_ui(p_1, p_1, 1);
k = gen_k( skey->p, 0 /* no small K ! */ );
gcry_mpi_powm( a, skey->g, k, skey->p );
mpi_mul(t, skey->x, a );
mpi_subm(t, input, t, p_1 );
mpi_invm(inv, k, p_1 );
mpi_mulm(b, t, inv, p_1 );
#if 0
if( DBG_CIPHER )
{
log_mpidump("elg sign p= ", skey->p);
log_mpidump("elg sign g= ", skey->g);
log_mpidump("elg sign y= ", skey->y);
log_mpidump("elg sign x= ", skey->x);
log_mpidump("elg sign k= ", k);
log_mpidump("elg sign M= ", input);
log_mpidump("elg sign a= ", a);
log_mpidump("elg sign b= ", b);
}
#endif
mpi_free(k);
mpi_free(t);
mpi_free(inv);
mpi_free(p_1);
}
/*
* First obtain the setup. Over the finite field randomize an scalar
* secret value, and calculate the public point.
*/
static gpg_err_code_t
generate_key (ECC_secret_key *sk, unsigned int nbits, const char *name,
gcry_mpi_t g_x, gcry_mpi_t g_y,
gcry_mpi_t q_x, gcry_mpi_t q_y)
{
gpg_err_code_t err;
elliptic_curve_t E;
gcry_mpi_t d;
mpi_point_t Q;
mpi_ec_t ctx;
err = generate_curve (nbits, name, &E, &nbits);
if (err)
return err;
if (DBG_CIPHER)
{
log_mpidump ("ecc generation p", E.p);
log_mpidump ("ecc generation a", E.a);
log_mpidump ("ecc generation b", E.b);
log_mpidump ("ecc generation n", E.n);
log_mpidump ("ecc generation Gx", E.G.x);
log_mpidump ("ecc generation Gy", E.G.y);
log_mpidump ("ecc generation Gz", E.G.z);
}
if (DBG_CIPHER)
log_debug ("choosing a random x of size %u\n", nbits);
d = gen_k (E.n, GCRY_VERY_STRONG_RANDOM);
/* Compute Q. */
point_init (&Q);
ctx = _gcry_mpi_ec_init (E.p, E.a);
_gcry_mpi_ec_mul_point (&Q, d, &E.G, ctx);
/* Copy the stuff to the key structures. */
sk->E.p = mpi_copy (E.p);
sk->E.a = mpi_copy (E.a);
sk->E.b = mpi_copy (E.b);
point_init (&sk->E.G);
point_set (&sk->E.G, &E.G);
sk->E.n = mpi_copy (E.n);
point_init (&sk->Q);
point_set (&sk->Q, &Q);
sk->d = mpi_copy (d);
/* We also return copies of G and Q in affine coordinates if
requested. */
if (g_x && g_y)
{
if (_gcry_mpi_ec_get_affine (g_x, g_y, &sk->E.G, ctx))
log_fatal ("ecc generate: Failed to get affine coordinates\n");
}
if (q_x && q_y)
{
if (_gcry_mpi_ec_get_affine (q_x, q_y, &sk->Q, ctx))
log_fatal ("ecc generate: Failed to get affine coordinates\n");
}
_gcry_mpi_ec_free (ctx);
point_free (&Q);
mpi_free (d);
curve_free (&E);
/* Now we can test our keys (this should never fail!). */
test_keys (sk, nbits - 64);
return 0;
}
/* 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 */
}
}
void gen_condition(Node node, Symbol destination, int branch_cond)
/*;gen_condition*/
{
/* IMPORTANT WARNING: destination is where to go when expression is
* equal to branch_cond
*/
/* These maps are realized in procedures immediately following.
* const
* jump_false_code = {
* ['=', I_JUMP_IF_FALSE],
* ['!=', I_JUMP_IF_TRUE],
* ['<', I_JUMP_IF_GREATER_OR_EQUAL],
* ['>', I_JUMP_IF_LESS_OR_EQUAL],
* ['<=', I_JUMP_IF_GREATER],
* ['>=', I_JUMP_IF_LESS] },
*
* jump_true_code = {
* ['=', I_JUMP_IF_TRUE],
* ['<', I_JUMP_IF_LESS],
* ['>', I_JUMP_IF_GREATER],
* ['<=', I_JUMP_IF_LESS_OR_EQUAL],
* ['>=', I_JUMP_IF_GREATER_OR_EQUAL] };
*/
Tuple tup;
Node opnode, args, op1, op2;
Symbol opcode, optype;
#ifdef TRACE
if (debug_flag)
gen_trace_node("GEN_CONDITION", node);
#endif
if (N_KIND(node) == as_op) {
opnode = N_AST1(node);
args = N_AST2(node);
opcode = N_UNQ(opnode);
if (opcode == symbol_eq || opcode == symbol_ne || opcode == symbol_lt
|| opcode == symbol_gt || opcode == symbol_le || opcode == symbol_ge){
tup = N_LIST(args);
op1 = (Node) tup[1];
op2 = (Node) tup[2];
gen_value(op1);
gen_value(op2);
optype = get_type(op1);
if (is_simple_type(optype)) {
if (is_float_type(optype))
gen_k(I_FLOAT_COMPARE, kind_of(optype));
else
gen_k(I_COMPARE, kind_of(optype));
}
else {
if (is_record_type(optype)) {
gen_s(I_PUSH_EFFECTIVE_ADDRESS, optype);
}
if (is_array_type(optype) &&
(opcode != symbol_eq) && (opcode != symbol_ne)) {
gen(I_COMPARE_ARRAYS);
}
else {
gen(I_COMPARE_STRUC);
}
}
}
else {
gen_value(node);
opcode = symbol_eq;
}
}
else {
gen_value(node);
opcode = symbol_eq;
}
if (branch_cond)
gen_s(jump_true_code(opcode), destination);
else
gen_s(jump_false_code(opcode), destination);
}
