C++ cvfixnum函数代码示例

LOCAL VOID pushnextargs P4C(LVAL, fcn, int, n, LVAL, args, int, i)
{
  LVAL *newfp, next, value = NULL;

  /* build a new argument stack frame */
  newfp = xlsp;
  pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  pusharg(fcn);
  pusharg(cvfixnum((FIXTYPE)n));
  
  /* push the arguments and shift the list pointers */
  for (next = args; consp(next); next = cdr(next)) {
    switch (ntype(car(next))) {
    case VECTOR:
      value = getelement(car(next), i);
      break;
    case TVEC:
      value = gettvecelement(car(next), i);
      break;
    case CONS:
      value = car(car(next));
      rplaca(next, cdr(car(next)));
      break;
    }
    pusharg(value);
  }

  /* establish the new stack frame */
  xlfp = newfp;
}

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

/* evalhook - call the evalhook function */
LOCAL LVAL evalhook(LVAL expr)
{
    LVAL *newfp,olddenv,val;

    /* create the new call frame */
    newfp = xlsp;
    pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
    pusharg(getvalue(s_evalhook));
    pusharg(cvfixnum((FIXTYPE)2));
    pusharg(expr);
    pusharg(cons(xlenv,xlfenv));
    xlfp = newfp;

    /* rebind the hook functions to nil */
    olddenv = xldenv;
    xldbind(s_evalhook,NIL);
    xldbind(s_applyhook,NIL);

    /* call the hook function */
    val = xlapply(2);

    /* unbind the symbols */
    xlunbind(olddenv);

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

/* clisnew - initialize a new class */
LVAL clisnew(void)
{
    LVAL self,ivars,cvars,super;
    int n;

    /* get self, the ivars, cvars and superclass */
    self = xlgaobject();
    ivars = xlgalist();
    cvars = (moreargs() ? xlgalist() : NIL);
    super = (moreargs() ? xlgaobject() : object);
    xllastarg();

    /* store the instance and class variable lists and the superclass */
    setivar(self,IVARS,ivars);
    setivar(self,CVARS,cvars);
    setivar(self,CVALS,(cvars ? newvector(listlength(cvars)) : NIL));
    setivar(self,SUPERCLASS,super);

    /* compute the instance variable count */
    n = listlength(ivars);
    setivar(self,IVARCNT,cvfixnum((FIXTYPE)n));
    n += getivcnt(super,IVARTOTAL);
    setivar(self,IVARTOTAL,cvfixnum((FIXTYPE)n));

    /* return the new class object */
    return (self);
}

/* evpushargs - evaluate and push a list of arguments */
LOCAL int evpushargs(LVAL fun, LVAL args)
{
    LVAL *newfp;
    int argc;
    
    /* protect the argument list */
    xlprot1(args);

    /* build a new argument stack frame */
    newfp = xlsp;
    pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
    pusharg(fun);
    pusharg(NIL); /* will be argc */

    /* evaluate and push each argument */
    for (argc = 0; consp(args); args = cdr(args), ++argc)
        pusharg(xleval(car(args)));

    /* establish the new stack frame */
    newfp[2] = cvfixnum((FIXTYPE)argc);
    xlfp = newfp;
    
    /* restore the stack */
    xlpop();

    /* return the number of arguments */
    return (argc);
}

/* dotest2 - call a test function with two arguments */
int dotest2 P3C(LVAL, arg1, LVAL, arg2, LVAL, fun)
{
    FRAMEP newfp;

    /* Speedup for default case TAA MOD */
    if (fun == getfunction(s_eql))
        return (eql(arg1,arg2));

    /* Speedup for EQ and EQUAL for hash tables */
    if (fun == getfunction(s_eq))
        return (arg1 == arg2);
    if (fun == getfunction(s_equal))
        return (equal(arg1,arg2));

    /* create the new call frame */
    newfp = xlsp;
    pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
    pusharg(fun);
    pusharg(cvfixnum((FIXTYPE)2));
    pusharg(arg1);
    pusharg(arg2);
    xlfp = newfp;

    /* return the result of applying the test function */
    return (xlapply(2) != NIL);

}

VOID StGWObDoMouse P5C(LVAL, object, int, x, int, y, MouseEventType, type, MouseClickModifier, mods)
{
  LVAL Lx, Ly, argv[6], olddenv;
  int extend, option;
  
  xlstkcheck(2);
  xlsave(Lx);
  xlsave(Ly);
  argv[0] = object;
  argv[2] = Lx = cvfixnum((FIXTYPE) x);
  argv[3] = Ly = cvfixnum((FIXTYPE) y);

  olddenv = xldenv;
  xldbind(s_in_callback, s_true);
  if (type == MouseClick) {
	extend = ((int) mods) % 2;
	option = ((int) mods) / 2;
    argv[1] = sk_do_click;
	argv[4] = (extend) ? s_true : NIL;
	argv[5] = (option) ? s_true : NIL;
    xscallsubrvec(xmsend, 6, argv);
  }
  else {
    argv[1] = sk_do_motion;
    xscallsubrvec(xmsend, 4, argv);
  }
  xlpopn(2);
  xlunbind(olddenv);
}

/* callmacro - call a read macro */
LVAL callmacro(LVAL fptr, int ch)
{
    LVAL *newfp;

    /* create the new call frame */
    newfp = xlsp;
    pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
    pusharg(cdr(getelement(getvalue(s_rtable),ch)));
    pusharg(cvfixnum((FIXTYPE)2));
    pusharg(fptr);
    pusharg(cvchar(ch));
    xlfp = newfp;
    return (xlapply(2));
}

/* xmkstrinput - make a string input stream */
LVAL xmkstrinput(void)
{
    int start,end,len,i;
    unsigned char *str;
    LVAL string,val;

    /* protect the return value */
    xlsave1(val);
    
    /* get the string and length */
    string = xlgastring();
    str = getstring(string);
    len = getslength(string) - 1;

    /* get the starting offset */
    if (moreargs()) {
        val = xlgafixnum();
        start = (int)getfixnum(val);
    }
    else start = 0;

    /* get the ending offset */
    if (moreargs()) {
        val = xlgafixnum();
        end = (int)getfixnum(val);
    }
    else end = len;
    xllastarg();

    /* check the bounds */
    if (start < 0 || start > len)
        xlerror("string index out of bounds",cvfixnum((FIXTYPE)start));
    if (end < 0 || end > len)
        xlerror("string index out of bounds",cvfixnum((FIXTYPE)end));

    /* make the stream */
    val = newustream();

    /* copy the substring into the stream */
    for (i = start; i < end; ++i)
        xlputc(val,str[i]);

    /* restore the stack */
    xlpop();

    /* return the new stream */
    return (val);
}

/* search for string within a string */
LVAL xstrsearch(void)
{
    int start,end,pat_len,str_len;
    unsigned char *pat,*str,*patptr,*strptr,*patend;
    LVAL str1,str2;

    /* get the strings */
    str1 = xlgastring(); /* the pat */
    str2 = xlgastring(); /* the string */

    /* get the substring specifiers */
    getbounds(str2, k_start, k_end, &start, &end);    

    /* setup the string pointers */
    pat = getstring(str1);
    str = &getstring(str2)[start];

    pat_len = getslength(str1) - 1;
    str_len = end - start;
    patend = pat + pat_len;
    for (; pat_len <= str_len; str_len--) {
        patptr = pat;
        strptr = str;
        /* two outcomes: (1) no match, goto step (2) match, return */
        while (patptr < patend) {
            if (*patptr++ != *strptr++) goto step;
        }
        /* compute match index */
        return cvfixnum(str - getstring(str2));
    step:
        str++;
    }
    /* no match */
    return NIL;
}

static NODE *binary(NODE *args, int fcn)
{
long ival,iarg;
float fval,farg;
NODE *arg;
int imode;
arg = xlarg(&args);
if (((arg) && (arg)->n_type == 5)) {
ival = ((arg)->n_info.n_xint.xi_int);
imode = 1;
}
else if (((arg) && (arg)->n_type == 9)) {
fval = ((arg)->n_info.n_xfloat.xf_float);
imode = 0;
}
else
xlerror("bad argument type",arg);
if (fcn == '-' && args == (NODE *)0)
if (imode)
ival = -ival;
else
fval = -fval;
while (args) {
arg = xlarg(&args);
if (((arg) && (arg)->n_type == 5))
if (imode) iarg = ((arg)->n_info.n_xint.xi_int);
else farg = (float)((arg)->n_info.n_xint.xi_int);
else if (((arg) && (arg)->n_type == 9))
if (imode) { fval = (float)ival; farg = ((arg)->n_info.n_xfloat.xf_float); imode = 0; }
else farg = ((arg)->n_info.n_xfloat.xf_float);
else
xlerror("bad argument type",arg);
if (imode)
switch (fcn) {
case '+':	ival += iarg; break;
case '-':	ival -= iarg; break;
case '*':	ival *= iarg; break;
case '/':	checkizero(iarg); ival /= iarg; break;
case '%':	checkizero(iarg); ival %= iarg; break;
case 'M':	if (iarg > ival) ival = iarg; break;
case 'm':	if (iarg < ival) ival = iarg; break;
case '&':	ival &= iarg; break;
case '|':	ival |= iarg; break;
case '^':	ival ^= iarg; break;
default:	badiop();
}
else
switch (fcn) {
case '+':	fval += farg; break;
case '-':	fval -= farg; break;
case '*':	fval *= farg; break;
case '/':	checkfzero(farg); fval /= farg; break;
case 'M':	if (farg > fval) fval = farg; break;
case 'm':	if (farg < fval) fval = farg; break;
case 'E':	fval = pow(fval,farg); break;
default:	badfop();
}
}
return (imode ? cvfixnum(ival) : cvflonum(fval));
}

/* xdigitp - built-in function 'digit-char-p' */
LVAL xdigitp(void)
{
    int ch;
    ch = getchcode(xlgachar());
    xllastarg();
    return (isdigit(ch) ? cvfixnum((FIXTYPE)(ch - '0')) : NIL);
}

/* xlapp1 - apply a function of a single argument */
LVAL xlapp1 P2C(LVAL, fun, LVAL, arg)
{
    FRAMEP newfp;

    /* create the new call frame */
    newfp = xlsp;
    pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
    pusharg(fun);
    pusharg(cvfixnum((FIXTYPE)1));
    pusharg(arg);
    xlfp = newfp;

    /* return the result of applying the function */
    return xlapply(1);

}

LVAL xseispackrs(V)
{
  int nm, n, matz, ierr;
  LVAL a, w, z, fv1, fv2;
  double *da, *dw, *dz, *dfv1, *dfv2;

  nm = getfixnum(xlgafixnum());
  n = getfixnum(xlgafixnum());
  a = xlgetarg();
  w = xlgetarg();
  matz = getfixnum(xlgafixnum());
  z = xlgetarg();
  fv1 = xlgetarg();
  fv2 = xlgetarg();
  xllastarg();
  
  checkldim(nm, n);
  da = getlinalgdvec(0, nm * n, a);
  dw = getlinalgdvec(0, n, w);
  dz = (matz != 0) ? getlinalgdvec(0, nm * n, z) : NULL;
  dfv1 = getlinalgdvec(0, n, fv1);
  dfv2 = getlinalgdvec(0, n, fv2);

  
  eispack_rs(nm, n, da, dw, matz, dz, dfv1, dfv2, &ierr);
  return (ierr == 0) ? NIL : cvfixnum((FIXTYPE) ierr);
}

LVAL xssystem()
{
  char *cmd;
  int status;
  LVAL stream = NIL;
  FILE *p;
  int ch;

  cmd = (char *) getstring(xlgastring());
  if (moreargs()) {
    stream = xlgetarg();
    if (stream == s_true)
      stream = getvalue(s_stdout);
    else if (!streamp(stream) && !ustreamp(stream))
      xlbadtype(stream);
  }
  
  if (stream == NIL) {
    status = system(cmd);
    if (status == 127) xlfail("shell could not execute command");
  }
  else {
    if ((p = popen(cmd, "r")) == NULL)
      xlfail("could not execute command");
    while ((ch = getc(p)) != EOF) xlputc(stream, ch);
    status = pclose(p);
  }
  return(cvfixnum((FIXTYPE) status));
}