Esempio n. 1
0
File: xleval.c Progetto: 8l/csolve
/* evalhook - call the evalhook function */
LOCAL NODE *evalhook(NODE *expr)
{
    NODE ***oldstk,*ehook __HEAPIFY,*ahook __HEAPIFY,*args __HEAPIFY,*val;

    /* create a new stack frame */
    oldstk = xlsave3(&ehook,&ahook,&args);

    /* make an argument list */
    args = consa(expr);
    rplacd(args,consa(xlenv));

    /* rebind the hook functions to nil */
    ehook = getvalue(s_evalhook);
    setvalue(s_evalhook,NIL);
    ahook = getvalue(s_applyhook);
    setvalue(s_applyhook,NIL);

    /* call the hook function */
    val = xlapply(ehook,args);

    /* unbind the symbols */
    setvalue(s_evalhook,ehook);
    setvalue(s_applyhook,ahook);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the value */
    return (val);
}
Esempio n. 2
0
/* xcomplement - create a complementary function */
LVAL xcomplement(V)
{
    LVAL val;
    LVAL args, body;
    LVAL newxlenv;

    /* protect some pointers */
    xlstkcheck(3);
    xlsave(newxlenv);
    xlsave(args);
    xlsave(body);


    /* get the argument */
    val = xlgetarg();
    xllastarg();

    /* build the argument list (&rest x) */
    args = cons(lk_rest, consa(s_x));

    /* build body (not (apply s x)) */
    body = consa(cons(s_not, consa(cons(s_apply, cons(s_s, consa(s_x))))));

    /* create a closure for lambda expressions */
    newxlenv = xlframe(newxlenv);
    xlpbind(s_s, val, newxlenv);
    val = xlclose(NIL,s_lambda,args,body,newxlenv,NIL);

    /* unprotect pointers */
    xlpopn(3);

    /* return the function */
    return (val);
}
Esempio n. 3
0
mword *new_dstack_entry(mword *operand, mword alloc_type){ // new_dstack_entry#

    return
        consa( operand,
            consa( _newva( alloc_type), nil )); //FIXME DEPRECATED _newva

}
Esempio n. 4
0
LOCAL VOID set_hardware_address P3C(CPTR, ptr, LVAL, object, int *, type)
{
  LVAL t, p, last, result, oblistsym, newoblist;
  
  if (! objectp(object)) xlerror("not an object", object);
  
  oblistsym = s_hardware_objects;
  if (! consp(getvalue(oblistsym))) setvalue(oblistsym, NIL);
  
  xlstkcheck(4);
  xlsave(t);
  xlsave(p);
  xlsave(result);
  xlsave(newoblist);
  
  t = cvfixnum((FIXTYPE) time_stamp);
  p = cvfixnum((FIXTYPE) ptr);
  result = last = consa(object);
  result = cons(p, result);
  result = cons(t, result);
  
  newoblist = cons(result, getvalue(oblistsym));
  setvalue(oblistsym, newoblist);
  set_slot_value(object, s_hardware_address, result);
  
  for (;*type != NONE; type++, last = cdr(last)) {
    t = cvfixnum((FIXTYPE) *type);
    t = consa(t);
    rplacd(last, t);
  }
  xlpopn(4);
}
Esempio n. 5
0
mword *new_rstack_entry(mword *operand, mword *eval_type){ // new_rstack_entry#

    return
        consa( operand,
            consa( eval_type, nil ));

}
Esempio n. 6
0
/* if list is NIL.                                                    */
LOCAL LVAL rplac_end P2C(LVAL, list, LVAL, item)
{
  LVAL next; 
  if (list == NIL) return(consa(item));
  else if (listp(list)) {
    for (next = list; consp(cdr(next)); next = cdr(next))
      ;
    rplacd(next, consa(item));
    return(list);
  }
  else xlerror("not a list", list);
  return NIL; /* not reached */
}
Esempio n. 7
0
LVAL iview_hist_add_points(V)
{
  IVIEW_WINDOW w;
  int old_n, n;
  LVAL object, data, hdata;
  
  gethistargs(&w, &object, &hdata);
  if (IVIEW_WINDOW_NULL(w)) return(NIL);
  
  old_n = IViewNumPoints(w);
  
  xlsave1(data);
  data = xlgetarg();
  data = (fixp(data) || (consp(data) && seqp(car(data)))) 
       ? data : consa(data);
  internal_iview_add_points(w, object, data);
  xlpop();
  
  n = IViewNumPoints(w);
  allocate_internal_points(object, n);
  initialize_points(w, hdata, old_n, n);
  
  check_add_to_screen(object, 'P', old_n, n, TRUE);
  
  return(NIL);
}
Esempio n. 8
0
/* xlputc - put a character to a file or stream */
void xlputc(LVAL fptr, int ch)
{
    LVAL lptr;
    FILE *fp;

    /* count the character */
    ++xlfsize;

    /* check for output to nil */
    if (fptr == NIL)
        ;

    /* otherwise, check for output to an unnamed stream */
    else if (ustreamp(fptr)) {
        lptr = consa(cvchar(ch));
        if (gettail(fptr))
            rplacd(gettail(fptr),lptr);
        else
            sethead(fptr,lptr);
        settail(fptr,lptr);
    }

    /* otherwise, check for terminal output or file output */
    else {
        fp = getfile(fptr);
        if (!fp)
            xlfail("file not open");
        else if (fp == stdout || fp == STDERR)
            ostputc(ch);
        else
            osaputc(ch,fp);
    }
}
Esempio n. 9
0
LVAL xschol_decomp(V)
{
  LVAL a, da, val;
  int n;
  double maxoffl, maxadd;

  a = xlgadarray();
  maxoffl = moreargs() ? makefloat(xlgetarg()) : 0.0;
  xllastarg();

  checksquarematrix(a);
  n = numrows(a);

  xlstkcheck(2);
  xlsave(da);
  xlsave(val);

  da = gen2linalg(a, n, n, s_c_double, FALSE);
  choldecomp(REDAT(da), n, maxoffl, &maxadd);

  val = consa(cvflonum((FLOTYPE) maxadd));
  val = cons(linalg2genmat(da, n, n, FALSE), val);

  xlpopn(2);

  return val;
}
Esempio n. 10
0
/* remif - common code for 'remove-if' and 'remove-if-not' */
LOCAL LVAL remif(int tresult)
{
    LVAL list,fcn,val,last=NULL,next;

    /* protect some pointers */
    xlstkcheck(2);
    xlsave(fcn);
    xlsave(val);

    /* get the expression to remove and the list */
    fcn = xlgetarg();
    list = xlgalist();
    xllastarg();

    /* remove matches */
    for (; consp(list); list = cdr(list))

        /* check to see if this element should be deleted */
        if (dotest1(car(list),fcn) != tresult) {
            next = consa(car(list));
            if (val) rplacd(last,next);
            else val = next;
            last = next;
        }

    /* restore the stack */
    xlpopn(2);

    /* return the updated list */
    return (val);
}
Esempio n. 11
0
/* xappend - built-in function append */
LVAL xappend(void)
{
    LVAL list,last=NULL,next,val;

    /* protect some pointers */
    xlsave1(val);

    /* initialize */
    val = NIL;
    
    /* append each argument */
    if (moreargs()) {
        while (xlargc > 1) {

            /* append each element of this list to the result list */
            for (list = nextarg(); consp(list); list = cdr(list)) {
                next = consa(car(list));
                if (val) rplacd(last,next);
                else val = next;
                last = next;
            }
        }

        /* handle the last argument */
        if (val) rplacd(last,nextarg());
        else val = nextarg();
    }

    /* restore the stack */
    xlpop();

    /* return the list */
    return (val);
}
Esempio n. 12
0
VOID initialize_graph_window P1C(LVAL, object)
{
  LVAL internals, value;
  int v, width, height, size;
  StGWWinInfo *gwinfo;
  ColorCode bc,dc; /* added JKL */
  
  internals = newadata(StGWWinInfoSize(), 1, FALSE);
  set_slot_value(object, s_internals, consa(internals));
  StGWInitWinInfo(object);
  
  gwinfo = StGWObWinInfo(object);
  if (gwinfo == NULL) return;
  
  StGWSetObject(gwinfo, object);
  
  if (slot_value(object, s_black_on_white) == NIL) {
    bc = StGWBackColor(gwinfo);         /* this seems better for color */
    dc = StGWDrawColor(gwinfo);         /* machines - 0 and 1 are not  */
    StGWSetDrawColor(gwinfo, bc);       /* the default draw and back   */
    StGWSetBackColor(gwinfo, dc);       /* colors on the Amiga   JKL   */
  }
  
  StGetScreenSize(&width, &height);
  size = (width > height) ? width : height;
  if ((value = slot_value(object, s_has_h_scroll)) != NIL) {
    v =  (fixp(value)) ? getfixnum(value) : size;
    StGWSetHasHscroll(gwinfo, TRUE, v);
  }
  if ((value = slot_value(object, s_has_v_scroll)) != NIL) {
    v =  (fixp(value)) ? getfixnum(value) : size;
    StGWSetHasVscroll(gwinfo, TRUE, v);
  }
}
Esempio n. 13
0
/* xlputc - put a character to a file or stream */
VOID xlputc P2C(LVAL, fptr, int, ch)
{
    LVAL lptr;
    FILEP fp;

    /* TAA MOD -- delete output to NIL and character counting 1/97 */
    /* check for output to an unnamed stream */
    if (ntype(fptr) == USTREAM) {	/* TAA MOD, was ustreamp() */
	lptr = consa(cvchar((unsigned char)ch));
	if (gettail(fptr)!=NIL)
	    rplacd(gettail(fptr),lptr);
	else
	    sethead(fptr,lptr);
	settail(fptr,lptr);
    }

    /* otherwise, check for terminal output or file output */
    else {
	fp = getfile(fptr);
        if (fp == CLOSED)   /* TAA MOD -- give error */
            xlfail("can't write closed stream");
	if (fp == CONSOLE)  /* TAA MOD -- for redirecting */
	    ostputc(ch);
	else {
	  if ((fptr->n_sflags & S_FORWRITING) == 0)
	    xlerror("can't write read-only file stream", fptr);
	  if ((fptr->n_sflags & S_WRITING) == 0) {
	    /* possible direction change*/
	    if (fptr->n_sflags & S_READING) {
	      OSSEEKCUR(fp,
                        (getsavech(fptr)?(setsavech(fptr,'\0'),-1L):0L));
	    }
	    fptr->n_sflags |= S_WRITING;
	    fptr->n_sflags &= ~S_READING;
#ifdef BIGNUMS
	    if ((fptr->n_sflags & S_BINARY) == 0)
#endif
	    fptr->n_cpos = 0;   /* best guess */
	  }
#ifdef BIGNUMS
	  if ((fptr->n_sflags & S_BINARY) == 0) {
#endif
	  if (ch == '\n') fptr->n_cpos = 0;
	  else fptr->n_cpos++;
#ifdef BIGNUMS
	}
#endif
#ifdef OSAGETC
	  if (((fptr->n_sflags & S_BINARY) ?
	       OSPUTC(ch,fp) : OSAPUTC(ch,fp)) == EOF)
	    /* TAA MOD to check for write to RO file */
	    xlerror("write failed", fptr);
#else
	  if (OSPUTC(ch,fp)==EOF) /* TAA MOD to check for write to RO file*/
	    xlerror("write failed", fptr);
#endif
        }
    }
}
Esempio n. 14
0
void fromobject__fetch(register fromobject_susp_type susp, snd_list_type snd_list)
{
    int cnt = 0; /* how many samples computed */
    int togo;
    int n;
    sample_block_type out;
    register sample_block_values_type out_ptr;

    register sample_block_values_type out_ptr_reg;

    register boolean done_reg;
    register LVAL src_reg;
    falloc_sample_block(out, "fromobject__fetch");
    out_ptr = out->samples;
    snd_list->block = out;

    while (cnt < max_sample_block_len) { /* outer loop */
	/* first compute how many samples to generate in inner loop: */
	/* don't overflow the output sample block: */
	togo = max_sample_block_len - cnt;

        if (susp->done) {
            togo = 0; /* indicate termination */
            break;    /* we're done */
        }

	n = togo;
	done_reg = susp->done;
	src_reg = susp->src;
	out_ptr_reg = out_ptr;
	if (n) do { /* the inner sample computation loop */
            LVAL rslt = xleval(cons(s_send, cons(src_reg,
                                                 consa(s_next))));
            if (floatp(rslt)) {
                *out_ptr_reg++ = (sample_type) getflonum(rslt);
            } else {
                done_reg = true;
                /* adjust togo to what it should have been */
                break;
            };
	} while (--n); /* inner loop */

	togo -= n;
	susp->done = done_reg;
	out_ptr += togo;
	cnt += togo;
    } /* outer loop */

    /* test for termination */
    if (togo == 0 && cnt == 0) {
	snd_list_terminate(snd_list);
    } else {
	snd_list->block_len = cnt;
	susp->susp.current += cnt;
    }
} /* fromobject__fetch */
Esempio n. 15
0
VOID newhistinternals P1C(LVAL, object)
{
  LVAL val;
  
  xlsave1(val);
  val = newadata(sizeof(struct hist), 1, FALSE);
  val = consa(val);
  set_slot_value(object, s_histogram_internals, val);
  xlpop();
}
Esempio n. 16
0
/* plist - parse a list */
LOCAL LVAL plist(LVAL fptr)
{
    LVAL val,expr,lastnptr,nptr;

    /* protect some pointers */
    xlstkcheck(2);
    xlsave(val);
    xlsave(expr);

    /* keep appending nodes until a closing paren is found */
    for (lastnptr = NIL; nextch(fptr) != ')'; )

        /* get the next expression */
        switch (readone(fptr,&expr)) {
        case EOF:
            badeof(fptr);
        case TRUE:

            /* check for a dotted tail */
            if (expr == s_dot) {
                /* make sure there's a node */
                if (lastnptr == NIL)
                    xlfail("invalid dotted pair");

                /* parse the expression after the dot */
                if (!xlread(fptr,&expr,TRUE))
                    badeof(fptr);
                rplacd(lastnptr,expr);

                /* make sure its followed by a close paren */
                if (nextch(fptr) != ')')
                    xlfail("invalid dotted pair");
            }

            /* otherwise, handle a normal list element */
            else {
                nptr = consa(expr);
                if (lastnptr == NIL)
                    val = nptr;
                else
                    rplacd(lastnptr,nptr);
                lastnptr = nptr;
            }
            break;
        }

    /* skip the closing paren */
    xlgetc(fptr);

    /* restore the stack */
    xlpopn(2);

    /* return successfully */
    return (val);
}
Esempio n. 17
0
xlsinit(void)
{
NODE *array,*p;
obarray = xlmakesym("*OBARRAY*",1);
array = newvector(199);
((obarray)->n_info.n_xsym.xsy_value = (array));
p = consa(obarray);
((array)->n_info.n_xvect.xv_data[hash("*OBARRAY*",199)] = (p));
s_unbound = xlsenter("*UNBOUND*");
((s_unbound)->n_info.n_xsym.xsy_value = (s_unbound));
}
Esempio n. 18
0
/* rmlpar - read macro for '(' */
LVAL rmlpar(void)
{
    LVAL fptr,mch;

    /* get the file and macro character */
    fptr = xlgetfile();
    mch = xlgachar();
    xllastarg();

    /* make the return value */
    return (consa(plist(fptr)));
}
Esempio n. 19
0
/* rmbquote - read macro for '`' */
LVAL rmbquote(void)
{
    LVAL fptr,mch;

    /* get the file and macro character */
    fptr = xlgetfile();
    mch = xlgachar();
    xllastarg();

    /* parse the quoted expression */
    return (consa(pquote(fptr,s_bquote)));
}
Esempio n. 20
0
/* arguments by circular lists of one element.                        */
LOCAL VOID fixuparglist P1C(LVAL, list)
{
  LVAL next;
  for (next = list; consp(next); next = cdr(next))
    if (! compoundp(car(next))) { 
      /* make circular list */
      rplaca(next, consa(car(next)));
      rplacd(car(next), car(next));
    }
    else
      rplaca(next, compounddataseq(car(next)));
}
Esempio n. 21
0
xlputprop(NODE *sym, NODE *val, NODE *prp)
{
NODE ***oldstk,*p,*pair;
if ((pair = findprop(sym,prp)) == (NODE *)0) {
oldstk = xlsave(&p,(NODE **)0);
p = consa(prp);
((p)->n_info.n_xlist.xl_cdr = (pair = cons(val,((sym)->n_info.n_xsym.xsy_plist->n_info.n_xlist.xl_cdr))));
((sym)->n_info.n_xsym.xsy_plist->n_info.n_xlist.xl_cdr = (p));
xlstack = oldstk;
}
((pair)->n_info.n_xlist.xl_car = (val));
}
Esempio n. 22
0
File: xlsym.c Progetto: 8l/csolve
/* xlputprop - put a property value onto the property list */
void xlputprop(NODE *sym,NODE *val,NODE *prp)
{
    NODE ***oldstk,*p __HEAPIFY,*pair;
    if ((pair = findprop(sym,prp)) == NIL) {
	oldstk = xlsave1(&p);
	p = consa(prp);
	rplacd(p,pair = cons(val,getplist(sym)));
	setplist(sym,p);
	xlstack = oldstk;
    }
    rplaca(pair,val);
}
Esempio n. 23
0
/* pquote - parse a quoted expression */
LOCAL LVAL pquote(LVAL fptr, LVAL sym)
{
    LVAL val,p;

    /* protect some pointers */
    xlsave1(val);

    /* allocate two nodes */
    val = consa(sym);
    rplacd(val,consa(NIL));

    /* initialize the second to point to the quoted expression */
    if (!xlread(fptr,&p,TRUE))
        badeof(fptr);
    rplaca(cdr(val),p);

    /* restore the stack */
    xlpop();

    /* return the quoted expression */
    return (val);
}
Esempio n. 24
0
/* xlsinit - symbol initialization routine */
void xlsinit(void)
{
    LVAL array,p;

    /* initialize the obarray */
    obarray = xlmakesym("*OBARRAY*");
    array = newvector(HSIZE);
    setvalue(obarray,array);

    /* add the symbol *OBARRAY* to the obarray */
    p = consa(obarray);
    setelement(array,hash("*OBARRAY*",HSIZE),p);
}
Esempio n. 25
0
/* pvector - parse a vector */
LOCAL LVAL pvector(LVAL fptr)
{
    LVAL list,expr,val,lastnptr,nptr;
    int len,ch,i;

    /* protect some pointers */
    xlstkcheck(2);
    xlsave(list);
    xlsave(expr);

    /* keep appending nodes until a closing paren is found */
    for (lastnptr = NIL, len = 0; (ch = nextch(fptr)) != ')'; ) {

        /* check for end of file */
        if (ch == EOF)
            badeof(fptr);

        /* get the next expression */
        switch (readone(fptr,&expr)) {
        case EOF:
            badeof(fptr);
        case TRUE:
            nptr = consa(expr);
            if (lastnptr == NIL)
                list = nptr;
            else
                rplacd(lastnptr,nptr);
            lastnptr = nptr;
            len++;
            break;
        }
    }

    /* skip the closing paren */
    xlgetc(fptr);

    /* make a vector of the appropriate length */
    val = newvector(len);

    /* copy the list into the vector */
    for (i = 0; i < len; ++i, list = cdr(list))
        setelement(val,i,car(list));

    /* restore the stack */
    xlpopn(2);

    /* return successfully */
    return (val);
}
Esempio n. 26
0
File: xlsym.c Progetto: 8l/csolve
/* xlsinit - symbol initialization routine */
void xlsinit(void)
{
    NODE *array,*p;

    /* initialize the obarray */
    obarray = xlmakesym("*OBARRAY*",STATIC);
    array = newvector(HSIZE);
    setvalue(obarray,array);

    /* add the symbol *OBARRAY* to the obarray */
    p = consa(obarray);
    setelement(array,hash("*OBARRAY*",HSIZE),p);

    /* enter the unbound symbol indicator */
    s_unbound = xlsenter("*UNBOUND*");
    setvalue(s_unbound,s_unbound);
}
Esempio n. 27
0
/* entermsg - add a message to a class */
LOCAL LVAL entermsg(LVAL cls, LVAL msg)
{
    LVAL lptr,mptr;

    /* lookup the message */
    for (lptr = getivar(cls,MESSAGES); lptr; lptr = cdr(lptr))
        if (car(mptr = car(lptr)) == msg)
            return (mptr);

    /* allocate a new message entry if one wasn't found */
    xlsave1(mptr);
    mptr = consa(msg);
    setivar(cls,MESSAGES,cons(mptr,getivar(cls,MESSAGES)));
    xlpop();

    /* return the symbol node */
    return (mptr);
}
Esempio n. 28
0
/* rmcomma - read macro for ',' */
LVAL rmcomma(void)
{
    LVAL fptr,mch,sym;
    int ch;

    /* get the file and macro character */
    fptr = xlgetfile();
    mch = xlgachar();
    xllastarg();

    /* check the next character */
    if ((ch = xlgetc(fptr)) == '@')
        sym = s_comat;
    else {
        xlungetc(fptr,ch);
        sym = s_comma;
    }

    /* make the return value */
    return (consa(pquote(fptr,sym)));
}
Esempio n. 29
0
LVAL iview_get_nice_range(V)
{
  double low, high;
  int ticks;
  LVAL temp, result;
  
  low = makefloat(xlgetarg());
  high = makefloat(xlgetarg());
  ticks = getfixnum(xlgafixnum());
  xllastarg();
  
  GetNiceRange(&low, &high, &ticks);
  xlstkcheck(2);
  xlsave(result);
  xlsave(temp);
  temp = cvfixnum((FIXTYPE) ticks); result = consa(temp);
  temp = cvflonum((FLOTYPE) high); result = cons(temp, result);
  temp = cvflonum((FLOTYPE) low); result = cons(temp, result);  
  xlpopn(2);
  
  return(result);
}
Esempio n. 30
0
/* xlist - built a list of the arguments */
LVAL xlist(void)
{
    LVAL last=NULL,next,val;

    /* protect some pointers */
    xlsave1(val);

    /* add each argument to the list */
    for (val = NIL; moreargs(); ) {

        /* append this argument to the end of the list */
        next = consa(nextarg());
        if (val) rplacd(last,next);
        else val = next;
        last = next;
    }

    /* restore the stack */
    xlpop();

    /* return the list */
    return (val);
}