LISP lsystem(LISP args)
{int retval;
long iflag;
iflag = no_interrupt(1);
retval = system(get_c_string(string_append(args)));
no_interrupt(iflag);
if (retval < 0)
return(cons(flocons(retval),llast_c_errmsg(-1)));
else
return(flocons(retval));}
static LISP decode_fstab(struct fstab *p)
{if (p)
return(symalist("spec",strcons(-1,p->fs_spec),
"file",strcons(-1,p->fs_file),
"type",strcons(-1,p->fs_type),
"freq",flocons(p->fs_freq),
"passno",flocons(p->fs_passno),
"vfstype",rintern(p->fs_vfstype),
"mntops",strcons(-1,p->fs_mntops),
NULL));
else
return(NIL);}
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);
}
}
LISP lsetfsent(void)
{long iflag;
LISP result;
iflag = no_interrupt(1);
result = flocons(setfsent());
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);
}
/*
;@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 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 ldecode_pwent(struct passwd *p)
{return(symalist(
"name",strcons(strlen(p->pw_name),p->pw_name),
"passwd",strcons(strlen(p->pw_passwd),p->pw_passwd),
"uid",flocons(p->pw_uid),
"gid",flocons(p->pw_gid),
"dir",strcons(strlen(p->pw_dir),p->pw_dir),
"gecos",strcons(strlen(p->pw_gecos),p->pw_gecos),
/* FIXME: this is horrible */
#if defined(__osf__) || defined(hpux) || defined(sun)
"comment",strcons(strlen(p->pw_comment),p->pw_comment),
#endif
#if defined(hpux) || defined(sun)
"age",strcons(strlen(p->pw_age),p->pw_age),
#endif
#if defined(__osf__)
"quota",flocons(p->pw_quota),
#endif
"shell",strcons(strlen(p->pw_shell),p->pw_shell),
NULL));}
LISP lfork(void)
{int iflag;
pid_t pid;
iflag = no_interrupt(1);
pid = fork();
if (pid == 0)
{no_interrupt(iflag);
return(NIL);}
if (pid == -1)
return(err("fork",llast_c_errmsg(-1)));
no_interrupt(iflag);
return(flocons(pid));}
lref_t lread_binary_flonum(lref_t port)
{
if (!BINARY_PORTP(port))
vmerror_wrong_type_n(1, port);
flonum_t result = 0;
if (read_binary_flonum(port, &result))
return flocons(result);
return lmake_eof();
}
lref_t ltime_apply0(lref_t fn)
{
if (!PROCEDUREP(fn))
vmerror_wrong_type_n(1, fn);
flonum_t t = sys_runtime();
flonum_t gc_t = interp.gc_total_run_time;
size_t cells = interp.gc_total_cells_allocated;
size_t fops = CURRENT_TIB()->count_fop;
size_t frames = CURRENT_TIB()->count_enter_frame;
lref_t argv[6];
argv[0] = apply1(fn, 0, NULL);
argv[1] = flocons(sys_runtime() - t);
argv[2] = flocons(interp.gc_total_run_time - gc_t);
argv[3] = fixcons(interp.gc_total_cells_allocated - cells);
argv[4] = fixcons(CURRENT_TIB()->count_fop - fops);
argv[5] = fixcons(CURRENT_TIB()->count_enter_frame - frames);
return lvector(6, argv);
}
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)));}
/*
;@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 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));
}
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 void fast_read_flonum(lref_t reader, bool complex, lref_t * retval)
{
flonum_t real_part = 0.0;
flonum_t imag_part = 0.0;
if (!read_binary_flonum(FASL_READER_PORT(reader), &real_part)) {
*retval = lmake_eof();
return;
}
if (!complex) {
*retval = flocons(real_part);
return;
}
if (!read_binary_flonum(FASL_READER_PORT(reader), &imag_part))
vmerror_fast_read("incomplete complex number", reader, NIL);
*retval = cmplxcons(real_part, imag_part);
}
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 max_columns_fun(void)
{
return flocons(max_columns);
}
/* A C function to do Lisp-style Formatted I/O ******************
*
* ~s - write the lisp object
* ~a - display the lisp object
* REVISIT: remove scvwritef ~u in favor of some kind of print_unreadable_object call
* ~u - display the lisp object in unprintable fashion (ie. <type@addr...>
*
* ~cs - display the C string
* ~cS - display the C string/arglist with a recursive call to scvwritef
* ~cd - display the C integer
* ~cf - display the C flonum
* ~c& - display the C pointer
* ~cc - display the C character
* ~cC - display the C integer as an octal character constant
* ~cB - display the C integer as a byte
*
* Prefixing a format code with a #\! (ie. ~!L) causes the corresponding
* value to be returned from the function as a Lisp object.
*/
lref_t scvwritef(const _TCHAR * format_str, lref_t port, va_list arglist)
{
char ch;
if (NULLP(port))
port = CURRENT_OUTPUT_PORT();
assert(PORTP(port));
_TCHAR buf[STACK_STRBUF_LEN];
lref_t lisp_arg_value = NULL;
_TCHAR *str_arg_value = NULL;
_TCHAR char_arg_value = _T('\0');
long int long_arg_value = 0;
unsigned long int ulong_arg_value = 0;
flonum_t flonum_arg_value = 0.0;
lref_t unprintable_object = NIL;
lref_t return_value = NIL;
for (;;)
{
ch = *format_str;
if (ch == '\0')
break;
bool return_next_value = false;
format_str++;
if (ch != '~')
{
write_char(port, ch);
continue;
}
ch = *format_str;
format_str++;
if (ch == '!')
{
ch = *format_str;
format_str++;
return_next_value = true;
}
switch (ch)
{
case 's':
lisp_arg_value = va_arg(arglist, lref_t);
if (return_next_value)
return_value = lisp_arg_value;
debug_print_object(lisp_arg_value, port, true);
break;
case 'a':
lisp_arg_value = va_arg(arglist, lref_t);
if (return_next_value)
return_value = lisp_arg_value;
debug_print_object(lisp_arg_value, port, false);
break;
case 'u':
unprintable_object = va_arg(arglist, lref_t);
if (return_next_value)
return_value = unprintable_object;
if (DEBUG_FLAG(DF_PRINT_FOR_DIFF))
scwritef("#<~cs@(no-addr)", port, typecode_name(TYPE(unprintable_object)));
else
scwritef("#<~cs@~c&", port,
typecode_name(TYPE(unprintable_object)), unprintable_object);
break;
case '~':
write_char(port, '~');
break;
case 'c': /* C object prefix */
ch = *format_str; /* read the next format character */
format_str++;
switch (ch)
{
case 's':
str_arg_value = va_arg(arglist, _TCHAR *);
if (return_next_value)
return_value = strconsbuf(str_arg_value);
if (str_arg_value)
write_text(port, str_arg_value, _tcslen(str_arg_value));
else
WRITE_TEXT_CONSTANT(port, _T("<null>"));
break;
case 'S':
str_arg_value = va_arg(arglist, _TCHAR *);
if (return_next_value)
return_value = scvwritef(str_arg_value, port, arglist);
else
scvwritef(str_arg_value, port, arglist);
break;
case 'd':
long_arg_value = va_arg(arglist, long int);
if (return_next_value)
return_value = fixcons(long_arg_value);
_sntprintf(buf, STACK_STRBUF_LEN, _T("%d"), (int) long_arg_value);
write_text(port, buf, _tcslen(buf));
break;
case 'x':
long_arg_value = va_arg(arglist, long int);
if (return_next_value)
return_value = fixcons(long_arg_value);
_sntprintf(buf, STACK_STRBUF_LEN, _T("%08lx"), long_arg_value);
write_text(port, buf, _tcslen(buf));
break;
case 'f':
flonum_arg_value = va_arg(arglist, flonum_t);
if (return_next_value)
return_value = flocons(flonum_arg_value);
_sntprintf(buf, STACK_STRBUF_LEN, _T("%f"), flonum_arg_value);
write_text(port, buf, _tcslen(buf));
break;
case '&':
_sntprintf(buf, STACK_STRBUF_LEN, _T("%p"), (void *) va_arg(arglist, void *));
if (return_next_value)
return_value = strconsbuf(buf);
write_text(port, buf, _tcslen(buf));
break;
case 'c':
ulong_arg_value = va_arg(arglist, unsigned long int);
if (return_next_value)
return_value = fixcons(ulong_arg_value);
char_arg_value = (_TCHAR) ulong_arg_value;
write_text(port, &char_arg_value, 1);
break;
case 'C':
ulong_arg_value = va_arg(arglist, unsigned long int);
if (return_next_value)
return_value = fixcons(ulong_arg_value);
_sntprintf(buf, STACK_STRBUF_LEN, _T("%03o"), (uint32_t) ulong_arg_value);
write_text(port, buf, _tcslen(buf));
break;
case 'B':
ulong_arg_value = va_arg(arglist, unsigned long int);
if (return_next_value)
return_value = fixcons(ulong_arg_value);
_sntprintf(buf, STACK_STRBUF_LEN, _T("0x%02x"), (uint32_t) ulong_arg_value);
write_text(port, buf, _tcslen(buf));
break;
default:
panic(_T("Invalid C object format character in scwritef"));
break;
};
break;
default:
panic(_T("Invalid format character in scwritef"));
break;
}
return_next_value = false;
}
va_end(arglist);
if (!NULLP(unprintable_object))
scwritef(">", port);
return return_value;
}
if (!(pt = (gdPointPtr) ptr->storage_as.string.data))
err("gd point deallocated",ptr);
*n = ptr->storage_as.string.dim;
return(pt);
}
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
value = flocons(pt[i].x);
return(value);
}
LISP lgdPointy(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].y = get_c_long(value);
else
value = flocons(pt[i].y);
return(value);
LISP lgetppid(void)
{return(flocons(getppid()));}
static LISP siag_time(void)
{
double t = time(NULL);
return flocons(t);
}
static LISP get_number(LISP row, LISP col)
{
return flocons(ret_number(siag_buffer, siag_sht,
get_c_long(row), get_c_long(col)));
}
LISP lgetpgrp(void)
{return(flocons(getpgrp()));}
LISP lrandom(LISP n)
{int res;
res = rand();
return(flocons(NNULLP(n) ? res % get_c_long(n) : res));}
static LISP get_col(void)
{
double dcol = siag_col;
return flocons(dcol);
}
static LISP get_row(void)
{
double drow = siag_row;
return flocons(drow);
}
LISP lmemref_byte(LISP addr)
{unsigned char *ptr = (unsigned char *) get_c_long(addr);
return(flocons(*ptr));}
LISP ltrunc(LISP x)
{long i;
if NFLONUMP(x) err("wta to trunc",x);
i = (long) FLONM(x);
return(flocons((double) i));}
LISP lstatfs(LISP path)
{long iflag;
struct statfs s;
iflag = no_interrupt(1);
if (statfs(get_c_string(path),&s,sizeof(s)))
return(err("statfs",llast_c_errmsg(-1)));
no_interrupt(iflag);
return(symalist("type",(((s.f_type >= 0) && (s.f_type < MNT_NUMTYPES) &&
mnt_names[s.f_type])
? rintern(mnt_names[s.f_type])
: flocons(s.f_type)),
"bsize",flocons(s.f_bsize),
"blocks",flocons(s.f_blocks),
"bfree",flocons(s.f_bfree),
"bavail",flocons(s.f_bavail),
"files",flocons(s.f_files),
"ffree",flocons(s.f_ffree),
"mntonname",strcons(-1,s.f_mntonname),
"mntfromname",strcons(-1,s.f_mntfromname),
NULL));}
