Symbol getsymptr(int seq, int unit) /*;getsymptr*/
{
/* here to convert seq and unit to pointer to symbol.
* we require that the symbol has already been allocated
*/
Tuple symptr;
Symbol sym;
int items;
/* here to convert seq and unit to pointer to symbol.
* we require that the symbol has already been allocated
*/
/* TBSL: need to get SEQPTR table for unit, and return address
*/
if (unit == 0 ) {
if (seq == 0) return (Symbol)0;
if (seq>0 && seq <= tup_size(init_symbols)) {
sym = (Symbol) init_symbols[seq];
return sym;
}
else
chaos("unit 0 error getsymptr");
}
if (unit <= unit_numbers) {
struct unit *pUnit = pUnits[unit];
symptr = (Tuple) pUnit->aisInfo.symbols;
if (symptr == (Tuple)0) {
items = pUnit->aisInfo.numberSymbols;
symptr = tup_new(items);
pUnit->aisInfo.symbols = (char *) symptr;
}
if (seq <= tup_size(symptr)) {
sym = (Symbol) symptr[seq];
if (sym == (Symbol)0) {
sym = sym_new_noseq(na_void);
symptr[seq] = (char *) sym;
S_SEQ(sym) = seq;
S_UNIT(sym) = unit;
}
#ifdef DEBUG
if (trapss>0 && seq == trapss && unit == trapsu) traps(sym);
#endif
return sym; /* return newly allocated symbol */
}
else
chaos("getsymptr error"); return (Symbol) 0;
}
chaos("getsymptr unable to find node"); return (Symbol) 0;
}
static int const_cmp_kind(Const cleft, Const cright) /*;const_cmp_kind*/
{
int ckind;
ckind = cleft->const_kind;
if (ckind == CONST_OM) chaos("const comparison left operand not defined");
if (ckind != cright->const_kind) {
#ifdef DEBUG
zpcon(cleft);
zpcon(cright);
#endif
chaos("const comparison operands differing kinds");
}
return ckind;
}
static void put_slot(IFILE *file, Tuple tup) /*;put_slot*/
{
/* This procedure writes out the SLOTS information. These are maps from
* symbols to unit names. The interpreter needs only to know the names
* of the symbols so we write their names if available, else
* an empty string.
*/
int i, n;
Slot slot;
n = tup_size(tup);
putnum(file, "slot-entries", n);
for (i = 1; i <= n; i++) {
slot = (Slot) tup[i];
if (slot == (Slot)0) {
if (compiling_predef)
chaos("undefined slot compiling predef");
putnum(file, "slot-exists", 0);
}
else {
putnum(file, "slot-exists", 1);
putnum(file, "slot-seq", slot->slot_seq);
putnum(file, "slot-unit", slot->slot_unit);
putnum(file, "slot-number", slot->slot_number);
putstr(file, "slot-name", slot->slot_name);
}
}
}
void predef_exceptions(Tuple tup) /*;predef_exceptions*/
{
/* This procedure writes out the SLOTS information.
* This variant of put_slot writes out definitions of predefined exceptions
* when compiling predef, in a form suitable for inclusion as the body
* of init_predef_exceptions (cf. init.c).
*/
int i, n;
Slot slot;
n = tup_size(tup);
printf("exception slots\n");
/* first five exceptions defined in standard */
for (i = 6; i <= n; i++) {
slot = (Slot) tup[i];
if (slot == (Slot)0) {
if (compiling_predef)
chaos("undefined slot compiling predef");
}
else {
printf(" init_predef_exception(%d, %d, %d, \"%s\");\n",
slot->slot_seq, slot->slot_unit, slot->slot_number,
slot->slot_name);
}
}
}
void on()
{
if(mode == 0)
dim_all();
else if(mode == 1)
run(red,1);
else if(mode == 2)
run(red,0);
else if(mode == 3)
run(yellow,0);
else if(mode == 4)
run(lightblue,0);
else if(mode == 5)
run(green,1);
else if(mode == 6)
run(green,0);
else if(mode == 7)
chaos();
else if(mode == 8)
cu_mode();
else if(mode == 9)
run(red,1);//PWM();
else if(mode < 0)
mode = total_modes;
else if(mode > total_modes)
mode = 0;
else
run(orange,0);
}
int segment_get_int(Segment s, int i) /*;segment_get_int*/
{
/* get value of word from location i in segment seg. */
int *resp;
seg_check(s);
if (i >= s->seg_maxpos) {
chaos("segment.c: get_int retrieving from undefined location\n");
return 0;
}
if (s->seg_kind == SEGMENT_KIND_DATA) {
resp = (int *) s->seg_data + i;
return *resp;
}
else {
#ifdef ALIGN_WORD
/* retrieve byte by byte to avoid alignment problems */
register int j;
int v;
register char *sp, *tp;
resp = (int *) (s->seg_data + i);
sp = (char *) resp;
tp = (char *) &v;
for (j = 0; j < sizeof(int); j++) *tp++ = *sp++;
return v;
#else
resp = (int *) (s->seg_data + i);
return *resp;
#endif
}
}
/* Not used */
void node_free(Node node) /*;node_free*/
{
/* free nodeentry. Since state of allocated fields not clear
* only free the node block itself
*/
chaos("node free");
if (node != (Node)0) efreet((char *) node, "node-free");
}
char *unit_name_names(char *u) /*;unit_name_names*/
{
char *s1;
if (u == NULL || strlen(u) <= 2)
chaos("unit_name_names: invalid unit name");
s1 = u+2; /* point to start of names fields */
return strjoin("", s1);
}
int const_cmp_undef(Const cleft, Const cright) /*;const_cmp_undef*/
{
#ifdef DEBUG
zpcon(cleft);
zpcon(cright);
#endif
chaos("const comparison not defined for these constant types");
return 0; /* for sake of lint */
}
static int jump_true_code(Symbol op) /*;jump_true_code*/
{
if (op == symbol_eq) return I_JUMP_IF_TRUE;
else if (op == symbol_ne) return I_JUMP_IF_FALSE;
else if (op == symbol_lt) return I_JUMP_IF_LESS;
else if (op == symbol_gt) return I_JUMP_IF_GREATER;
else if (op == symbol_le) return I_JUMP_IF_LESS_OR_EQUAL;
else if (op == symbol_ge) return I_JUMP_IF_GREATER_OR_EQUAL;
else chaos("jump_true_code");
return I_JUMP_IF_TRUE; /* return junk value for lint's sake */
}
Span get_left_span(Node node) /*;get_left_span */
{
Span lspan;
lspan = retrieve_l_span(node);
if (lspan == (Span)0 && node != current_node)
lspan = retrieve_l_span(current_node);
if (lspan == (Span)0)
chaos("get_left_span: cannot find spans");
return lspan;
}
int predef_code(char *name) /*;predef_code*/
{
/* return code given predef opcode name */
int i;
for (i = 0; ; i++) {
if (pretab[i].pretab_name == (char *)0) chaos("predef_code failed");
if (strcmp(pretab[i].pretab_name, name) == 0 ) break;
}
return pretab[i].pretab_code;
}
Span get_right_span(Node node) /*;get_right_span */
{
Span rspan;
rspan = retrieve_r_span(node);
if (rspan == (Span)0 && node != current_node)
rspan = retrieve_r_span(current_node);
if (rspan == (Span)0)
chaos("get_right_span: cannot find spans");
return rspan;
}
void morph_ifs ( void )
{
FILE *stream;
stream= fopen( "hilist.dat", "rb" );
while( fread( morph_list, 4, _MAX_POINT, stream ) == _MAX_POINT )
{
morph();
chaos();
wait_count( 70 * 1 );
}
fclose( stream );
}
int is_subunit(char *u) /*;is_subunit*/
{
char *s1, *s2;
if (u == NULL) chaos("is_subunit: null pointer");
if (strlen(u) <= 2) return FALSE;
s1 = u+2; /* point to start of name*/
s2 = strchr(s1, '.'); /* look for dot after first name */
if (s2 == NULL) /* if no dot take rest of string */
return FALSE;
return TRUE; /* if subunit*/
}
void chaos_update(void) {
region *r;
/* Chaos */
for (r = regions; r; r = r->next) {
int i;
if (fval(r, RF_CHAOTIC)) {
chaos(r);
}
i = get_chaoscount(r);
if (i) {
add_chaoscount(r, -(int)(i * ((double)(rng_int() % 10)) / 100.0));
}
}
}
void segment_append(Segment s, Segment sa) /*;segment_append*/
{
/* append segment sa at end of segment s */
int i, la;
seg_check(s);
if (s->seg_kind != SEGMENT_KIND_DATA)
chaos("segment_append not appending a data segment");
s->seg_pos = s->seg_maxpos;
la = sa->seg_maxpos;
for (i = 0; i < la; i++) {
segment_put_int(s, ((int *)(sa->seg_data))[i]);
}
}
void segment_put_byte(Segment s, int v) /*;segment_put_byte*/
{
unsigned newpos, pos;
seg_check(s);
if (s->seg_kind != SEGMENT_KIND_CODE)
chaos("segment.c: segment_put_byte called on data segment");
pos = s->seg_pos;
newpos = pos + 1;
if (newpos >= s->seg_dim) {
segment_realloc(s, newpos);
}
s->seg_data[pos] = (char) v;
s->seg_pos = newpos;
if (s->seg_maxpos < newpos) s->seg_maxpos = newpos;
}
void segment_set_pos(Segment s, unsigned pos, unsigned offtyp)
/*;segment_set_pos*/
{
/* set position of segment to offset pos. offtyp is type of offset,
* interpreted similarly to lseek(2); i.e., offtyp is 0 for offset
* from start of segment, 1 for offset from current position, and 2
* for offset from end of segment. Only the cases 0 and 2 are supported now.
*/
seg_check(s);
if (offtyp == 2) { /* to position at end ignore pos */
s->seg_pos = s->seg_maxpos;
return;
}
if (offtyp != 0)
chaos("segment_set_pos bad offset type");
s->seg_pos = pos;
}
void segment_put_const(Segment seg, Const con) /*;segment_put_const*/
{
if (con->const_kind == CONST_INT) {
/* can safely put integers - defer others for later */
segment_put_word(seg, INTV(con));
}
else if(con->const_kind == CONST_REAL) {
segment_put_real(seg, REALV(con));
}
else if(con->const_kind == CONST_FIXED) {
segment_put_long(seg, FIXEDV(con));
}
else {
#ifdef DEBUG
zpcon(con);
#endif
chaos("segment.c - meaningless kind of literal");
}
}
static int is_subunit(char *u) /*;is_subunit*/
{
/* In C, IS_SUBUNIT is procedure is_subunit():
* IS_SUBUNIT(na); (#na > 2) endm;
*/
int n;
char *s1, *s2;
if (u == (char *)0)
chaos("is_subunit: null pointer");
n = strlen(u);
if (n <= 2)
return FALSE;
s1 = u + 2; /* point to start of name*/
s2 = strchr(s1, '.'); /* look for dot after first name */
if (s2 == (char *)0) /* if no dot take rest of string */
return FALSE;
return TRUE; /* if subunit*/
}
void segment_put_off(Segment s, int i, int v) /*;segment_put_off*/
{
/* put value of v, interpreted as offset (16 bits) at location i
* in segment seg.
* We assume this is used to overwrite a previously defined location
* and raise chaos if this is not the case.
*/
unsigned pos, oldpos;
int *d;
seg_check(s);
if (i >= s->seg_maxpos)
chaos("segment.c: segment_put_off of undefined location");
pos = i;
if (s->seg_kind == SEGMENT_KIND_DATA) {
d = (int *) s->seg_data;
d[pos] = v;
}
else {
#ifdef ALIGN_WORD
{
int iv;
iv = v;
oldpos = s->seg_pos; /* save pos since segment_put_n may alter it */
segment_put_n(s, i, sizeof(int), (char *)&iv);
s->seg_pos = oldpos;
}
#else
d = (int *) (s->seg_data + pos);
*d = v;
#endif
}
}
void randomevents(void)
{
region *r;
faction *monsters = get_monsters();
icebergs();
godcurse();
orc_growth();
demon_skillchanges();
/* Orkifizierte Regionen mutieren und mutieren zurück */
for (r = regions; r; r = r->next) {
if (fval(r, RF_ORCIFIED)) {
direction_t dir;
double probability = 0.0;
for (dir = 0; dir < MAXDIRECTIONS; dir++) {
region *rc = rconnect(r, dir);
if (rc && rpeasants(rc) > 0 && !fval(rc, RF_ORCIFIED))
probability += 0.02;
}
if (chance(probability)) {
ADDMSG(&r->msgs, msg_message("deorcified", "region", r));
freset(r, RF_ORCIFIED);
}
} else {
attrib *a = a_find(r->attribs, &at_orcification);
if (a != NULL) {
double probability = 0.0;
if (rpeasants(r) <= 0)
continue;
probability = a->data.i / (double)rpeasants(r);
if (chance(probability)) {
fset(r, RF_ORCIFIED);
a_remove(&r->attribs, a);
ADDMSG(&r->msgs, msg_message("orcified", "region", r));
} else {
a->data.i -= _max(10, a->data.i / 10);
if (a->data.i <= 0)
a_remove(&r->attribs, a);
}
}
}
}
/* Vulkane qualmen, brechen aus ... */
for (r = regions; r; r = r->next) {
if (r->terrain == newterrain(T_VOLCANO_SMOKING)) {
if (a_find(r->attribs, &at_reduceproduction)) {
ADDMSG(&r->msgs, msg_message("volcanostopsmoke", "region", r));
rsetterrain(r, T_VOLCANO);
} else {
if (rng_int() % 100 < 12) {
ADDMSG(&r->msgs, msg_message("volcanostopsmoke", "region", r));
rsetterrain(r, T_VOLCANO);
} else if (r->age > 20 && rng_int() % 100 < 8) {
volcano_outbreak(r);
}
}
} else if (r->terrain == newterrain(T_VOLCANO)) {
if (rng_int() % 100 < 4) {
ADDMSG(&r->msgs, msg_message("volcanostartsmoke", "region", r));
rsetterrain(r, T_VOLCANO_SMOKING);
}
}
}
/* Monumente zerfallen, Schiffe verfaulen */
for (r = regions; r; r = r->next) {
building **blist = &r->buildings;
while (*blist) {
building *b = *blist;
if (fval(b->type, BTF_DECAY) && !building_owner(b)) {
b->size -= _max(1, (b->size * 20) / 100);
if (b->size == 0) {
remove_building(blist, r->buildings);
}
}
if (*blist == b)
blist = &b->next;
}
}
/* monster-einheiten desertieren */
if (monsters) {
for (r = regions; r; r = r->next) {
unit *u;
for (u = r->units; u; u = u->next) {
if (u->faction && !is_monsters(u->faction)
&& (u_race(u)->flags & RCF_DESERT)) {
if (fval(u, UFL_ISNEW))
continue;
if (rng_int() % 100 < 5) {
ADDMSG(&u->faction->msgs, msg_message("desertion",
"unit region", u, r));
u_setfaction(u, monsters);
}
}
}
}
}
/* Chaos */
for (r = regions; r; r = r->next) {
int i;
if (fval(r, RF_CHAOTIC)) {
chaos(r);
}
i = chaoscount(r);
if (i) {
chaoscounts(r, -(int)(i * ((double)(rng_int() % 10)) / 100.0));
}
}
#ifdef HERBS_ROT
rotting_herbs();
#endif
dissolve_units();
}
static Const fold_unop(Node node) /*;fold_unop*/
{
Node opn, oplist;
Const result, op1;
int op1_kind;
Symbol sym;
opn = N_AST1(node);
oplist = N_AST2(node);
op1 = const_fold((Node) (N_LIST(oplist))[1]);
if (is_const_om(op1)) return op1;
op1_kind = op1->const_kind;
sym = N_UNQ(opn);
if (sym == symbol_addui) {
/* the "+" can be ignored if it is used as a unary op */
result = op1;
}
else if (sym == symbol_addufl) {
result = op1;
}
else if (sym == symbol_addufx) {
result = op1;
}
else if (sym == symbol_subui ||
sym == symbol_subufl || sym == symbol_subufx) {
if (is_simple_value(op1)) {
if (sym == symbol_subui) {
if (is_const_int(op1)) {
if (INTV(op1) == ADA_MIN_INTEGER) {
create_raise(node, symbol_constraint_error);
result = const_new(CONST_OM);
}
else {
result = int_const(-INTV(op1));
}
}
else if (is_const_uint(op1))
result = uint_const(int_umin(UINTV(op1)));
else chaos("eval:subui bad type");
}
else if (sym == symbol_subufl) {
const_check(op1, CONST_REAL);
result = real_const(-REALV(op1));
}
}
else {
const_check(op1, CONST_RAT);
result= rat_const(rat_umin(RATV(op1)));
}
}
else if ( sym == symbol_not) {
if (is_simple_value (op1)) {
if (op1_kind == CONST_INT)
result = int_const(1-INTV(op1)); /*bnot in setl */
else chaos("fold_unop: bad kind");
}
else { /*TBSL*/
result = const_new(CONST_OM);
}
}
else if ( sym == symbol_absi ||
sym == symbol_absfl || sym == symbol_absfx) {
if (is_simple_value(op1)) {
if (sym == symbol_absi) {
if (op1_kind == CONST_INT) result = int_const(abs(INTV(op1)));
else if (op1_kind == CONST_UINT)chaos("fold_unit absi in uint");
else chaos("fold_unop: bad kind");
}
else if (sym == symbol_absfl) {
result = real_const(fabs(REALV(op1)));
}
}
else {
result= rat_const(rat_abs(RATV(op1)));
}
}
return result;
}
static Const fold_op(Node node) /*;fold_op*/
{
Node opn, arg1, arg2, oplist;
Const result, op1, op2, tryc;
Symbol sym, op_name;
int *uint;
int rm;
Tuple tup;
int res, overflow;
opn = N_AST1(node);
oplist = N_AST2(node);
tup = N_LIST(oplist);
arg1 = (Node) tup[1];
arg2 = (Node) tup[2];
op1 = const_fold(arg1);
op2 = const_fold(arg2);
op_name = N_UNQ(opn);
/* If either operand raises and exception, so does the operation */
if (N_KIND(arg1) == as_raise) {
copy_attributes(arg1, node);
return const_new(CONST_OM);
}
if (N_KIND(arg2) == as_raise
&& op_name != symbol_andthen && op_name != symbol_orelse) {
copy_attributes(arg2, node);
return const_new(CONST_OM);
}
if (is_const_om(op1) || (is_const_om(op2)
&& (op_name != symbol_in || op_name != symbol_notin))) {
return const_new(CONST_OM);
}
sym = op_name;
if ( sym == symbol_addi || sym == symbol_addfl) {
if (sym == symbol_addi) {
res = word_add(INTV(op1), INTV(op2), &overflow);
if (overflow) {
create_raise(node, symbol_constraint_error);
result = const_new(CONST_OM);
}
else result = int_const(res);
}
else
result = real_const(REALV(op1) + REALV(op2));
}
else if ( sym == symbol_addfx) {
const_check(op1, CONST_RAT);
const_check(op2, CONST_RAT);
result= rat_const(rat_add(RATV(op1), RATV(op2)));
}
else if ( sym == symbol_subi) {
if (is_const_int(op1)) {
if (is_const_int(op2)) {
res = word_sub(INTV(op1), INTV(op2), &overflow);
if (overflow) {
create_raise(node, symbol_constraint_error);
result = const_new(CONST_OM);
}
else result = int_const(res);
}
else {
chaos("fold_op: subi operand types");
}
}
}
else if (sym == symbol_subfl) {
result = real_const(REALV(op1) - REALV(op2));
}
else if ( sym == symbol_subfx) {
const_check(op1, CONST_RAT);
const_check(op2, CONST_RAT);
result= rat_const(rat_sub(RATV(op1), RATV(op2)));
}
else if ( sym == symbol_muli) {
#ifdef TBSL
-- need to check for overflow and convert result back to int if not
-- note that low-level setl is missing calls to check_overflow that
-- are present in high-level and should be in low-level as well
result = int_mul(int_fri(op1), int_fri(op2));
#endif
/* until overflow check in */
const_check(op1, CONST_INT);
const_check(op2, CONST_INT);
res = word_mul(INTV(op1), INTV(op2), &overflow);
if (overflow) {
create_raise(node, symbol_constraint_error);
result = const_new(CONST_OM);
}
else result = int_const(res);
}
char *predef_name(int op) /*;predef_name*/
{
/* return name given predef opcode */
if (op < 1 || op > 130 ) chaos("predef_name failed");
return pretab[op];
}
void main ( void )
{
uint pos,count;
for( pos=0; pos<_MAX_POINT; pos++ )
{
point_list[ pos ].x= 320L << _FP;
point_list[ pos ].y= 240L << _FP;
point_list[ pos ].sx= ( rand() - rand() /2 ) * 16L;
point_list[ pos ].sy= ( rand() - rand() /2 ) * 16L;
point_list[ pos ].old_offset=0;
point_list[ pos ].old_mask=255;
}
videomode(0x12);
outpw( 0x3c4, 0x0f02 );
while( !kbhit() )
{
wvbl();
draw( point_list, _MAX_POINT, 0 );
move( point_list, _MAX_POINT );
}
getch();
morph_ifs();
for( pos=0; pos<_MAX_POINT; pos++ )
{
point_list[ pos ].sx= ( ( ( long ) ( 65536.0 * ( 320.0 + 220 * sin ( ( double ) pos * 6.28 / _MAX_POINT ) ) ) ) - point_list[ pos ].x ) / ( 70 * 1 );
point_list[ pos ].sy= ( ( ( long ) ( 65536.0 * ( 240.0 + 220 * cos ( ( double ) pos * 6.28 / _MAX_POINT ) ) ) ) - point_list[ pos ].y ) / ( 70 * 1 );
}
chaos();
wait_count( 70 * 1 );
for( pos=0; pos<_MAX_POINT; pos++ )
{
point_list[ pos ].sx= ( ( ( long ) ( 65536.0 * ( 320.0 + ( 220.0 * pos / _MAX_POINT ) * sin ( ( double ) pos * 6.28 * 8 / _MAX_POINT ) ) ) ) - point_list[ pos ].x ) / ( 70 * 1 );
point_list[ pos ].sy= ( ( ( long ) ( 65536.0 * ( 240.0 + ( 220.0 * pos / _MAX_POINT ) * cos ( ( double ) pos * 6.28 * 8 / _MAX_POINT ) ) ) ) - point_list[ pos ].y ) / ( 70 * 1 );
}
chaos();
wait_count( 70 * 1 );
for( pos=0; pos<_MAX_POINT; pos++ )
{
point_list[ pos ].sx= ( ( ( long ) ( 65536.0 * ( 320.0 + ( 220.0 * pos / _MAX_POINT ) * cos ( ( double ) pos * 6.28 * 8 / _MAX_POINT ) ) ) ) - point_list[ pos ].x ) / ( 70 * 1 );
point_list[ pos ].sy= ( ( ( long ) ( 65536.0 * ( 240.0 + ( 220.0 * pos / _MAX_POINT ) * sin ( ( double ) pos * 6.28 * 8 / _MAX_POINT ) ) ) ) - point_list[ pos ].y ) / ( 70 * 1 );
}
chaos();
wait_count( 70 * 1 );
while( !kbhit() )
{
wvbl();
draw( point_list, _MAX_POINT, 0 );
move_gravity ( point_list, _MAX_POINT, 65536L );
}
getch();
while( !kbhit() )
{
wvbl();
border( 1 );
draw( point_list, _MAX_POINT, 0 );
border( 2 );
move( point_list, _MAX_POINT );
border( 0 );
}
videomode(3);
}
void seg_check(Segment seg) /*;seg_check*/
{
if (seg->seg_id != SEG_ID)
chaos("invalid segment - check word invalid ");
}
