自学教程：C++ xlgetarg函数代码示例

LVAL xslpzgedi(V){  LVAL a, ipvt, det, work;  dcomplex *da, *ddet, *dwork;  int lda, offa, n, *dipvt, job, i, ilda;  a = xlgetarg();  offa = getfixnum(xlgafixnum());  lda = getfixnum(xlgafixnum());  n = getfixnum(xlgafixnum());  ipvt = xlgetarg();  det = xlgetarg();  work = xlgetarg();  job = getfixnum(xlgafixnum());  xllastarg();  checkldim(lda, n);  da = getlinalgzvec(offa, lda * n, a);  dipvt = getlinalgivec(0, n, ipvt);  ddet = (job / 10 != 0) ? getlinalgzvec(0, 2, det) : NULL;  dwork = getlinalgzvec(0, n, work);  if (job % 10 != 0)    for (i = 0, ilda = 0; i < n; i++, ilda += lda)      if (da[ilda + i].r == 0.0 && da[ilda + i].i == 0.0)	xlfail("matrix is (numerically) singular");  linpack_zgedi(da, lda, n, dipvt, ddet, dwork, job);  return NIL;}

LVAL xslpzgesl(V){  LVAL a, ipvt, b;  dcomplex *da, *db;  int lda, offa, n, *dipvt, job, i, ilda;  a = xlgetarg();  offa = getfixnum(xlgafixnum());  lda = getfixnum(xlgafixnum());  n = getfixnum(xlgafixnum());  ipvt = xlgetarg();  b = xlgetarg();  job = getfixnum(xlgafixnum());  xllastarg();  checkldim(lda, n);  da = getlinalgzvec(offa, lda * n, a);  dipvt = getlinalgivec(0, n, ipvt);  db = getlinalgzvec(0, n, b);  for (i = 0, ilda = 0; i < n; i++, ilda += lda)    if (da[ilda + i].r == 0.0 && da[ilda + i].i == 0.0)      xlfail("matrix is (numerically) singular");  linpack_zgesl(da, lda, n, dipvt, db, job);  return NIL;}

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 xsbasespline(V){  LVAL x, y, xs, ys, work;  double *dx, *dy, *dxs, *dys, *dwork;  int n, ns, error;  n = getfixnum(xlgafixnum());  x = xlgetarg();  y = xlgetarg();  ns = getfixnum(xlgafixnum());  xs = xlgetarg();  ys = xlgetarg();  work = xlgetarg();  xllastarg();  dx = getlinalgdvec(0, n, x);  dy = getlinalgdvec(0, n, y);  dxs = getlinalgdvec(0, ns, xs);  dys = getlinalgdvec(0, ns, ys);  dwork = getlinalgdvec(0, 2 * n, work);  error = fit_spline(n, dx, dy, ns, dxs, dys, dwork);  return error ? s_true : NIL;}

LVAL xsbasekernelsmooth(V){  LVAL x, y, xs, ys, targ;  int n, ns, error, ktype;  double *dx, *dy, *dxs, *dys, width;  n = getfixnum(xlgafixnum());  x = xlgetarg();  y = xlgetarg();  ns = getfixnum(xlgafixnum());  xs = xlgetarg();  ys = xlgetarg();  width = makefloat(xlgetarg());  targ = xlgasymbol();  xllastarg();  dx = getlinalgdvec(0, n, x);  dy = null(y) ? NULL : getlinalgdvec(0, n, y);  dxs = getlinalgdvec(0, ns, xs);  dys = getlinalgdvec(0, ns, ys);  switch (getstring(getpname(targ))[0]) {  case 'U': ktype = 'U'; break;  case 'T': ktype = 'T'; break;  case 'G': ktype = 'G'; break;  default:  ktype = 'B'; break;  }  error = kernel_smooth(dx, dy, n, width, NULL, NULL, dxs, dys, ns, ktype);  return error ? s_true : NIL;}

LVAL xsmake_rotation(V){  LVAL x, y, dx, dy, val;  double alpha=0.0;  int n, use_alpha = FALSE;    x = xlgetarg();  y = xlgetarg();  if (moreargs()) {    use_alpha = TRUE;    alpha = makefloat(xlgetarg());  }  xllastarg();    xlstkcheck(3);  xlsave(dx);  xlsave(dy);  xlsave(val);  dx = coerce_to_tvec(x, s_c_double);  dy = coerce_to_tvec(y, s_c_double);  n = gettvecsize(dx);  if (gettvecsize(dy) != n)    xlfail("sequences not the same length");  val = mktvec(n * n, s_c_double);  make_rotation(n, REDAT(val), REDAT(dx), REDAT(dy), use_alpha, alpha);  val = linalg2genmat(val, n, n, FALSE);    xlpopn(3);  return val;}

LVAL xlc_snd_save(void){    LVAL arg1 = xlgetarg();    long arg2 = getfixnum(xlgafixnum());    unsigned char * arg3 = getstring(xlgastring());    long arg4 = getfixnum(xlgafixnum());    long arg5 = getfixnum(xlgafixnum());    long arg6 = getfixnum(xlgafixnum());    long arg7 = getfixnum(xlgafixnum());    double arg8 = 0.0;    long arg9 = 0;    double arg10 = 0.0;    LVAL arg11 = xlgetarg();    double result;    xllastarg();    result = sound_save(arg1, arg2, arg3, arg4, arg5, arg6, arg7, &arg8, &arg9, &arg10, arg11);    {	LVAL *next = &getvalue(RSLT_sym);	*next = cons(NIL, NIL);	car(*next) = cvflonum(arg8);	next = &cdr(*next);	*next = cons(NIL, NIL);	car(*next) = cvfixnum(arg9);	next = &cdr(*next);	*next = cons(NIL, NIL);	car(*next) = cvflonum(arg10);    }    return cvflonum(result);}

/* xformat - formatted output function */LVAL xformat(void){    unsigned char *fmt;    LVAL stream,val;    int ch;    /* protect stream in case it is a new ustream */    xlsave1(stream);    /* get the stream and format string */    stream = xlgetarg();    if (stream == NIL)        val = stream = newustream();    else {        if (stream == s_true)            stream = getvalue(s_stdout);        else if (!streamp(stream) && !ustreamp(stream))            xlbadtype(stream);        val = NIL;    }    fmt = getstring(xlgastring());    /* process the format string */    while ((ch = *fmt++))        if (ch == '~') {            switch (*fmt++) {            case '/0':                xlerror("expecting a format directive",cvstring((char *) (fmt-1)));            case 'a': case 'A':                xlprint(stream,xlgetarg(),FALSE);                break;            case 's': case 'S':                xlprint(stream,xlgetarg(),TRUE);                break;            case '%':                xlterpri(stream);                break;            case '~':                xlputc(stream,'~');                break;            case '/n':			case '/r':				/* mac may read /r -- this should be ignored */				if (*fmt == '/r') fmt++;                  while (*fmt && *fmt != '/n' && isspace(*fmt))                    ++fmt;                break;            default:                xlerror("unknown format directive",cvstring((char *) (fmt-1)));            }        }        else            xlputc(stream,ch);            /* return the value */    if (val) val = getstroutput(val);    xlpop();    return val;}

LVAL xlc_snd_multiseq(void){    LVAL arg1 = xlgetarg();    LVAL arg2 = xlgetarg();    LVAL result;    xllastarg();    result = snd_make_multiseq(arg1, arg2);    return (result);}

static LVAL base_ifelse(V){  LVAL a, b, c;    a = xlgetarg();  b = xlgetarg();  c = xlgetarg();  xllastarg();    return((a != NIL) ? b : c);}

/* xequal - are these equal? (recursive) */LVAL xequal(void){    LVAL arg1,arg2;    /* get the two arguments */    arg1 = xlgetarg();    arg2 = xlgetarg();    xllastarg();    /* compare the arguments */    return (lval_equal(arg1,arg2) ? s_true : NIL);}

/* xcons - construct a new list cell */LVAL xcons(){    LVAL carval,cdrval;    /* get the two arguments */    carval = xlgetarg();    cdrval = xlgetarg();    xllastarg();    /* construct a new cons node */    return (cons(carval,cdrval));}

/* xcons - construct a new list cell */LVAL xcons(void){    LVAL arg1,arg2;    /* get the two arguments */    arg1 = xlgetarg();    arg2 = xlgetarg();    xllastarg();    /* construct a new list element */    return (cons(arg1,arg2));}

LVAL xlc_snd_ifft(void){    double arg1 = testarg2(xlgaanynum());    double arg2 = testarg2(xlgaanynum());    LVAL arg3 = xlgetarg();    long arg4 = getfixnum(xlgafixnum());    LVAL arg5 = xlgetarg();    sound_type result;    xllastarg();    result = snd_ifft(arg1, arg2, arg3, arg4, arg5);    return cvsound(result);}

LVAL xseispackch(V){  int nm, n, matz, ierr;  LVAL ar, ai, w, zr, zi, fv1, fv2, fm1;  double *dar, *dai, *dw, *dzr, *dzi, *dfv1, *dfv2, *dfm1;  nm = getfixnum(xlgafixnum());  n = getfixnum(xlgafixnum());  ar = xlgetarg();  ai = xlgetarg();  w = xlgetarg();  matz = getfixnum(xlgafixnum());  zr = xlgetarg();  zi = xlgetarg();  fv1 = xlgetarg();  fv2 = xlgetarg();  fm1 = xlgetarg();  xllastarg();    checkldim(nm, n);  dar = getlinalgdvec(0, nm * n, ar);  dai = getlinalgdvec(0, nm * n, ai);  dw = getlinalgdvec(0, n, w);  dzr = (matz != 0) ? getlinalgdvec(0, nm * n, zr) : NULL;  dzi = (matz != 0) ? getlinalgdvec(0, nm * n, zi) : NULL;  dfv1 = getlinalgdvec(0, n, fv1);  dfv2 = getlinalgdvec(0, n, fv2);  dfm1 = getlinalgdvec(0, 2 * n, fm1);  eispack_ch(nm, n, dar, dai, dw, matz, dzr, dzi, dfv1, dfv2, dfm1, &ierr);  return (ierr == 0) ? NIL : cvfixnum((FIXTYPE) ierr);}

LVAL xsgen2linalg(V){  LVAL x, type;  int m, n, trans;  x = xlgetarg();  m = getfixnum(xlgafixnum());  n = getfixnum(xlgafixnum());  type = xlgetarg();  trans = moreargs() ? ! null(xlgetarg()) : FALSE;  xllastarg();  return gen2linalg(x, m, n, type, trans);}

LVAL xstransposeinto(V){  LVAL x, y;  int m, n;  x = xlgetarg();  m = getfixnum(xlgafixnum());  n = getfixnum(xlgafixnum());  y = xlgetarg();  xllastarg();  transposeinto(x, m, n, y);  return y;}

/* x1macroexpand - expand a macro call */LVAL x1macroexpand(void){    LVAL form,fun,args;    /* protect some pointers */    xlstkcheck(2);    xlsave(fun);    xlsave(args);    /* get the form */    form = xlgetarg();    xllastarg();    /* expand until the form isn't a macro call */    if (consp(form)) {        fun = car(form);		/* get the macro name */        args = cdr(form);		/* get the arguments */        if (symbolp(fun) && fboundp(fun)) {            fun = xlgetfunction(fun);	/* get the expansion function */            macroexpand(fun,args,&form);        }    }    /* restore the stack and return the expansion */    xlpopn(2);    return (form);}

/* xmacroexpand - expand a macro call repeatedly */LVAL xmacroexpand(void){    LVAL form;    form = xlgetarg();    xllastarg();    return (xlexpandmacros(form));}

/* xquote - special form 'quote' */LVAL xquote(V){    LVAL val;    val = xlgetarg();    xllastarg();    return (val);}

/* xtype - return type of a thing */LVAL xtype(void){    LVAL arg;    if (!(arg = xlgetarg()))        return (NIL);    switch (ntype(arg)) {    case SUBR:		return (a_subr);    case FSUBR:		return (a_fsubr);    case CONS:		return (a_cons);    case SYMBOL:	return (a_symbol);    case FIXNUM:	return (a_fixnum);    case FLONUM:	return (a_flonum);    case STRING:	return (a_string);    case OBJECT:	return (a_object);    case STREAM:	return (a_stream);    case VECTOR:	return (a_vector);    case CLOSURE:	return (a_closure);    case CHAR:		return (a_char);    case USTREAM:	return (a_ustream);    case EXTERN:	return (exttype(arg));    default:		xlfail("bad node type");       return NIL; /* never happens */        }}

/* xsort - built-in function 'sort' */LVAL xsort(void){    LVAL sortlist();    LVAL list,fcn;    /* protect some pointers */    xlstkcheck(2);    xlsave(list);    xlsave(fcn);    /* get the list to sort and the comparison function */    list = xlgalist();    fcn = xlgetarg();    xllastarg();    /* sort the list */    list = sortlist(list,fcn);    if (list && (ntype(list) == FREE_NODE)) {        stdputstr("error in sort 2");    }    /* restore the stack and return the sorted list */    xlpopn(2);    return (list);}

/* xlength - return the length of a list or string */LVAL xlength(void){    FIXTYPE n=0;    LVAL arg;    /* get the list or string */    arg = xlgetarg();    xllastarg();    /* find the length of a list */    if (listp(arg))        for (n = 0; consp(arg); n++)            arg = cdr(arg);    /* find the length of a string */    else if (stringp(arg))        n = (FIXTYPE)getslength(arg)-1;    /* find the length of a vector */    else if (vectorp(arg))        n = (FIXTYPE)getsize(arg);    /* otherwise, bad argument type */    else        xlerror("bad argument type",arg);    /* return the length */    return (cvfixnum(n));}

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

/* xassoc - built-in function 'assoc' */LVAL xassoc(void){    LVAL x,alist,fcn,pair,val;    int tresult;    /* protect some pointers */    xlsave1(fcn);    /* get the expression to look for and the association list */    x = xlgetarg();    alist = xlgalist();    xltest(&fcn,&tresult);    /* look for the expression */    for (val = NIL; consp(alist); alist = cdr(alist))        if ((pair = car(alist)) && consp(pair))            if (dotest2(x,car(pair),fcn) == tresult) {                val = pair;                break;            }    /* restore the stack */    xlpop();    /* return result */    return (val);}

/* xmember - built-in function 'member' */LVAL xmember(void){    LVAL x,list,fcn,val;    int tresult;    /* protect some pointers */    xlsave1(fcn);    /* get the expression to look for and the list */    x = xlgetarg();    list = xlgalist();    xltest(&fcn,&tresult);    /* look for the expression */    for (val = NIL; consp(list); list = cdr(list))        if (dotest2(x,car(list),fcn) == tresult) {            val = list;            break;        }    /* restore the stack */    xlpop();    /* return the result */    return (val);}

/* xstring - return a string consisting of a single character */LVAL xstring(void){    LVAL arg;    /* get the argument */    arg = xlgetarg();    xllastarg();    /* make sure its not NIL */    if (null(arg))        xlbadtype(arg);    /* check the argument type */    switch (ntype(arg)) {    case STRING:        return (arg);    case SYMBOL:        return (getpname(arg));    case CHAR:        buf[0] = (int)getchcode(arg);        buf[1] = '/0';        return (cvstring(buf));    case FIXNUM:        buf[0] = getfixnum(arg);        buf[1] = '/0';        return (cvstring(buf));    default:        xlbadtype(arg);        return NIL; /* never happens */    }}

LVAL iview_transformation(V){  IVIEW_WINDOW w;  LVAL m = NULL, object;  int set = FALSE;  int vars;    object = xlgaobject();  w = (IVIEW_WINDOW) get_iview_address(object);  if (moreargs()) {    set = TRUE;    m = xlgetarg();  }    vars = IViewNumVariables(w);  if (set) {    if (m == NIL) IViewSetIdentityTransformation(w);    else {      set_internal_transformation(vars, m, NIL);      IViewSetTransformation(w, transform);    }    check_redraw(object, TRUE, TRUE);  }  else m = (IViewIsTransformed(w))         ? make_transformation(IViewTransformation(w), vars) : NIL;    return(m);}

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

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