Ejemplo n.º 1
0
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"));
     }
}
Ejemplo n.º 2
0
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);
}
Ejemplo n.º 3
0
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);
	}
}
Ejemplo n.º 4
0
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);
}
Ejemplo n.º 5
0
Archivo: gd.c Proyecto: suprit/stuff
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
Ejemplo n.º 6
0
/*
;@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);
}
Ejemplo n.º 7
0
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);}
Ejemplo n.º 8
0
Archivo: gd.c Proyecto: suprit/stuff
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);
}
Ejemplo n.º 9
0
/*
;@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);
}
Ejemplo n.º 10
0
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);}
Ejemplo n.º 11
0
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;
}
Ejemplo n.º 12
0
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);
}
Ejemplo n.º 13
0
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);
}
Ejemplo n.º 14
0
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;
}
Ejemplo n.º 15
0
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));}
Ejemplo n.º 16
0
Archivo: gd.c Proyecto: suprit/stuff
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);
}
Ejemplo n.º 17
0
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);}
Ejemplo n.º 18
0
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);}
Ejemplo n.º 19
0
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);}
Ejemplo n.º 20
0
/*
;@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]);
}
Ejemplo n.º 21
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);
}
Ejemplo n.º 22
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));
}
Ejemplo n.º 23
0
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);
}
Ejemplo n.º 24
0
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)));}
Ejemplo n.º 25
0
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)));}
Ejemplo n.º 26
0
LISP lrandom(LISP n)
{int res;
 res = rand();
 return(flocons(NNULLP(n) ? res % get_c_long(n) : res));}
Ejemplo n.º 27
0
LISP lsrandom(LISP n)
{long seed;
 seed = get_c_long(n);
 srand(seed);
 return(NIL);}
Ejemplo n.º 28
0
LISP lmemref_byte(LISP addr)
{unsigned char *ptr = (unsigned char *) get_c_long(addr);
 return(flocons(*ptr));}
Ejemplo n.º 29
0
LISP lexit(LISP val)
{int iflag = no_interrupt(1);
 exit(get_c_long(val));
 no_interrupt(iflag);
 return(NIL);}
Ejemplo n.º 30
0
static LISP get_number(LISP row, LISP col)
{
	return flocons(ret_number(siag_buffer, siag_sht,
			get_c_long(row), get_c_long(col)));
}