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));}