static void validate_structure_layout(size_t slots, lref_t layout)
{
if (!CONSP(layout))
vmerror_wrong_type_n(2, layout);
size_t len = (size_t) get_c_long(llength(layout));
if (len != 2)
vmerror_arg_out_of_range(layout, _T("bad structure layout, length<>2"));
lref_t slot_layout = CAR(CDR(layout));
if (get_c_long(llength(slot_layout)) != (long) slots)
vmerror_arg_out_of_range(lcons(slot_layout, fixcons(slots)),
_T("bad structure layout, wrong number of slots"));
for (; CONSP(slot_layout); slot_layout = CDR(slot_layout))
{
if (!CONSP(CAR(slot_layout)))
vmerror_arg_out_of_range(lcons(slot_layout, layout),
_T("bad structure layout, bad slot layout"));
if (!SYMBOLP(CAR(CAR(slot_layout))))
vmerror_arg_out_of_range(layout,
_T("bad structure layout, missing slot name"));
}
}
static LISP x_get_string(LISP row, LISP col, LISP bname)
{
int r, c;
int s;
char *p;
buffer *buf;
r = get_c_long(row);
c = get_c_long(col);
if (r < 1 || r > BUFFER_ROWS || c < 1 || c > BUFFER_COLS)
return NIL;
if (NULLP(bname)) {
buf = siag_buffer;
s = siag_sht;
} else if (TYPEP(bname, tc_string)) {
buf = find_sheet_by_name(bname->storage_as.string.data,
siag_buffer, &s);
if (buf == NULL) return NIL;
}
else return NIL;
if (ret_type(buf, s, r, c) == ERROR) p = "";
else p = ret_pvalue(NULL, buf, s, r, c, -1);
return strcons(strlen(p), p);
}
static LISP x_get_cell(LISP row, LISP col, LISP bname)
{
int r, c;
char *p;
buffer *buf;
int s;
r = get_c_long(row);
c = get_c_long(col);
if (r < 1 || r > BUFFER_ROWS || c < 1 || c > BUFFER_COLS)
return NIL;
if (NULLP(bname)) {
buf = siag_buffer;
s = siag_sht;
} else if (TYPEP(bname, tc_string)) {
buf = find_sheet_by_name(bname->storage_as.string.data,
siag_buffer, &s);
if (buf == NULL) return NIL;
}
else return NIL;
switch (ret_type(buf, s, r, c)) {
case STRING:
p = ret_string(buf, s, r, c);
return strcons(strlen(p), p);
case LABEL:
p = ret_text(buf, s, r, c);
return strcons(strlen(p), p);
case EMPTY:
case ERROR:
return NIL;
default:
return flocons(ret_val(buf, s, r, c).number);
}
}
static LISP get_text(LISP row, LISP col)
{
char *text = ret_text(buffer_of_window(w_list), w_list->sht,
get_c_long(row), get_c_long(col));
if (!text) text = "";
return strcons(strlen(text), text);
}
LISP lgdPointx(LISP ptr,LISP j,LISP value)
{ long n,i;
gdPointPtr pt;
pt = get_gdPointPtr(ptr,&n);
i = get_c_long(j);
if ((i < 0) || (i >= n)) err("index out of range",j);
if NNULLP(value)
pt[i].x = get_c_long(value);
else
/*
;@siag_colsum(c1, c2)
;@Returns the sum of all cells on the current row from column c1 to c2.
;@
;@siag_rowsum
*/
static LISP lsiag_colsum(LISP c1, LISP c2)
{
double sum = 0;
int i;
long tmp = get_c_long(c2);
for (i = get_c_long(c1); i <= tmp; i++)
sum += ret_val(siag_buffer, siag_sht, siag_row, i).number;
return flocons(sum);
}
LISP lkill(LISP pid,LISP sig)
{long iflag;
iflag = no_interrupt(1);
if (kill(get_c_long(pid),
NULLP(sig) ? SIGKILL : get_c_long(sig)))
err("kill",llast_c_errmsg(-1));
else
no_interrupt(iflag);
return(NIL);}
LISP lgdImageCreate(LISP sx,LISP sy)
{ LISP result;
long iflag;
result = cons(NIL,NIL);
result->type = tc_gdimage;
iflag = no_interrupt(1);
result->storage_as.string.data = (char *) gdImageCreate(get_c_long(sx),
get_c_long(sy));
no_interrupt(iflag);
return(result);
}
/*
;@pwr(y, n)
;@Compute an integral power of a double precision number.
;@
;@
*/
static LISP cc_pwr(LISP ly, LISP ln)
{
double y = get_c_double(ly);
int n = get_c_long(ln);
double z = pwr(y, n);
return flocons(z);
}
LISP lmkdir(LISP p,LISP m)
{long iflag;
iflag = no_interrupt(1);
if (mkdir(get_c_string(p),get_c_long(m)))
return(err("mkdir",llast_c_errmsg(-1)));
no_interrupt(iflag);
return(NIL);}
static LISP ani_property(LISP name, LISP value)
{
buffer *b = w_list->buf;
MwAniScript *lasts = w_list->script;
MwAniObject *lasto = w_list->object;
int n = get_c_long(name);
if (!lasts) err("Last script is NULL", NIL);
if (FLONUMP(value)) {
int lv = get_c_long(value);
switch (n) {
case MW_ANI_X:
lasts->x = lv;
break;
case MW_ANI_Y:
lasts->y = lv;
break;
case MW_ANI_WIDTH:
lasts->width = lv;
break;
case MW_ANI_HEIGHT:
lasts->height = lv;
break;
case MW_ANI_VISIBLE:
lasts->visible = lv;
break;
case MW_ANI_FORMAT:
lasto->fmt = lv;
break;
default:
err("No such property", name);
}
} else {
char *tv = get_c_string(value);
switch (n) {
case MW_ANI_TEXT:
lasto->string = MwStrdup(tv);
break;
default:
err("No such property", name);
}
}
b->change = TRUE;
pr_scr_flag = TRUE;
return NIL;
}
lref_t lmemref(lref_t addr)
{
size_t baseaddr = (size_t) get_c_long(addr);
intptr_t *obj = (intptr_t *) baseaddr;
return fixcons((fixnum_t)*obj);
}
static LISP get_type(LISP bname, LISP row, LISP col)
{
buffer *buf;
int s, t, r, c;
if (NULLP (bname)) {
buf = buffer_of_window(w_list);
s = w_list->sht;
} else {
buf = find_sheet_by_name(get_c_string(bname),
w_list->buf, &s);
}
r = get_c_long(row);
c = get_c_long(col);
t = ret_type(buf, s, r, c);
return flocons(t);
}
static LISP lani_ctl(LISP mode, LISP now)
{
int m = get_c_long(mode);
stage_init(w_list);
XtVaSetValues(w_list->ui->stage,
XtNanimatorMode, m,
(char *)0);
return NIL;
}
LISP lnice(LISP val)
{int iflag,n;
n = get_c_long(val);
iflag = no_interrupt(1);
n = nice(n);
if (n == -1)
err("nice",llast_c_errmsg(-1));
no_interrupt(iflag);
return(flocons(n));}
LISP lgdPoint(LISP args)
{ LISP result,l;
long iflag,j,m,n = nlength(args);
gdPointPtr pt;
if ((n % 2) || (!n))
err("must be an even positive length",args);
m = n / 2;
result = cons(NIL,NIL);
result->type = tc_gdpoint;
iflag = no_interrupt(1);
pt = (gdPointPtr) must_malloc(sizeof(gdPoint) * m);
result->storage_as.string.data = (char *) pt;
result->storage_as.string.dim = m;
no_interrupt(iflag);
for(j=0,l=args; j<m; ++j,l=cddr(l))
{ pt[j].x = get_c_long(car(l));
pt[j].y = get_c_long(cadr(l));
}
return(result);
}
LISP lgetpwuid(LISP luid)
{int iflag;
uid_t uid;
struct passwd *p;
LISP result = NIL;
uid = get_c_long(luid);
iflag = no_interrupt(1);
if ((p = getpwuid(uid)))
result = ldecode_pwent(p);
no_interrupt(iflag);
return(result);}
int assemble_options(LISP l, ...)
{int result = 0,val,noptions,nmask = 0;
LISP lsym,lp = NIL;
char *sym;
va_list syms;
if NULLP(l) return(0);
noptions = CONSP(l) ? get_c_long(llength(l)) : -1;
va_start(syms,l);
while((sym = va_arg(syms,char *)))
{val = va_arg(syms,int);
lsym = cintern(sym);
if (EQ(l,lsym) || (CONSP(l) && NNULLP(lp = memq(lsym,l))))
{result |= val;
if (noptions > 0)
nmask = nmask | (1 << (noptions - get_c_long(llength(lp))));
else
noptions = -2;}}
va_end(syms);
if ((noptions == -1) ||
((noptions > 0) && (nmask != ((1 << noptions) - 1))))
err("contains undefined options",l);
return(result);}
LISP lgetgrgid(LISP n)
{gid_t gid;
struct group *gr;
long iflag,j;
LISP result = NIL;
gid = get_c_long(n);
iflag = no_interrupt(1);
if ((gr = getgrgid(gid)))
{result = cons(strcons(strlen(gr->gr_name),gr->gr_name),result);
for(j=0;gr->gr_mem[j];++j)
result = cons(strcons(strlen(gr->gr_mem[j]),gr->gr_mem[j]),result);
result = nreverse(result);}
no_interrupt(iflag);
return(result);}
/*
;@cc_solv(a, b, n)
;@ Solve a general linear system A*x = b.
;
; int solv(double a[],double b[],int n)
;
; a = array containing system matrix A in row order
; (altered to L-U factored form by computation)
;
; b = array containing system vector b at entry and
; solution vector x at exit
;
; n = dimension of system
;@
;@
*/
static LISP cc_solv1(LISP a1, LISP a2, LISP b1, LISP b2)
{
int row, col, sheet;
buffer *buf;
int ax1 = get_c_long(CAR(a1)), ay1 = get_c_long(CDR(a1));
int ax2 = get_c_long(CAR(a2)), ay2 = get_c_long(CDR(a2));
int bx1 = get_c_long(CAR(b1)), by1 = get_c_long(CDR(b1));
int bx2 = get_c_long(CDR(b2)), by2 = get_c_long(CDR(b2));
int n = by2-by1+1;
double *a = fetch_array(ax1, ay1, ax2, ay2);
double *b = fetch_array(bx1, by1, bx2, by2);
if (a == NULL || b == NULL || solv(a, b, n) == 0) return NIL;
get_siod_coords(&row, &col, &sheet, &buf);
store_array(row, col, row+n-1, col, b);
return flocons(b[0]);
}
static LISP siag_sum(LISP start, LISP end)
{
double sum;
int r, c, startr, startc, endr, endc;
startr = get_c_long(car(start));
startc = get_c_long(cdr(start));
endr = get_c_long(car(end));
endc = get_c_long(cdr(end));
if (startr > endr) {
r = startr;
startr = endr;
endr = r;
}
if (startc > endc) {
c = startc;
startc = endc;
endc = c;
}
sum = 0;
for (r = startr; r <= endr; r++)
for (c = startc; c <= endc; c++)
sum += ret_val(siag_buffer, siag_sht, r, c).number;
return flocons(sum);
}
static LISP h_avg(LISP rows)
{
int nr = get_c_long(rows);
int i;
int first, last;
double sum = 0.0;
if (nr < 0) {
first = siag_col+nr;
last = siag_col-1;
} else {
first = siag_col+1;
last = siag_col+nr;
}
for (i = first; i <= last; i++) {
sum += ret_number(siag_buffer, siag_sht, siag_row, i);
}
return flocons(sum/(last-first+1));
}
lref_t lset_stack_limit(lref_t amount)
{
size_t new_size_limit = 0;
if (!NULLP(amount) && !FALSEP(amount))
new_size_limit = get_c_long(amount);
void *new_limit_obj = sys_set_stack_limit(new_size_limit);
if (!new_size_limit)
{
dscwritef(DF_SHOW_GC, ("stack limit disabled!"));
return boolcons(false);
}
dscwritef(DF_SHOW_GC, ("stack_size = ~cd bytes, [~c&,~c&]\n", new_size_limit, new_limit_obj, sys_get_stack_start()));
return fixcons(new_size_limit);
}
LISP lwait(LISP lpid,LISP loptions)
{pid_t pid,ret;
int iflag,status = 0,options;
pid = NULLP(lpid) ? -1 : get_c_long(lpid);
options = assemble_options(loptions,
#ifdef WCONTINUED
"WCONTINUED",WCONTINUED,
#endif
#ifdef WNOWAIT
"WNOWAIT",WNOWAIT,
#endif
"WNOHANG",WNOHANG,
"WUNTRACED",WUNTRACED,
NULL);
iflag = no_interrupt(1);
ret = waitpid(pid,&status,options);
no_interrupt(iflag);
if (ret == 0)
return(NIL);
else if (ret == -1)
return(err("wait",llast_c_errmsg(-1)));
else
/* should do more decoding on the status */
return(cons(flocons(ret),cons(flocons(status),NIL)));}
static long longfield(char *name,LISP alist)
{LISP value,key = rintern(name);
if NULLP(value = assq(key,alist))
return(0);
return(get_c_long(cdr(value)));}
LISP lrandom(LISP n)
{int res;
res = rand();
return(flocons(NNULLP(n) ? res % get_c_long(n) : res));}
LISP lsrandom(LISP n)
{long seed;
seed = get_c_long(n);
srand(seed);
return(NIL);}
LISP lmemref_byte(LISP addr)
{unsigned char *ptr = (unsigned char *) get_c_long(addr);
return(flocons(*ptr));}
LISP lexit(LISP val)
{int iflag = no_interrupt(1);
exit(get_c_long(val));
no_interrupt(iflag);
return(NIL);}
static LISP get_number(LISP row, LISP col)
{
return flocons(ret_number(siag_buffer, siag_sht,
get_c_long(row), get_c_long(col)));
}