Annotation of OpenXM_contrib2/asir2000/builtin/pf.c, Revision 1.19
1.2 noro 1: /*
2: * Copyright (c) 1994-2000 FUJITSU LABORATORIES LIMITED
3: * All rights reserved.
4: *
5: * FUJITSU LABORATORIES LIMITED ("FLL") hereby grants you a limited,
6: * non-exclusive and royalty-free license to use, copy, modify and
7: * redistribute, solely for non-commercial and non-profit purposes, the
8: * computer program, "Risa/Asir" ("SOFTWARE"), subject to the terms and
9: * conditions of this Agreement. For the avoidance of doubt, you acquire
10: * only a limited right to use the SOFTWARE hereunder, and FLL or any
11: * third party developer retains all rights, including but not limited to
12: * copyrights, in and to the SOFTWARE.
13: *
14: * (1) FLL does not grant you a license in any way for commercial
15: * purposes. You may use the SOFTWARE only for non-commercial and
16: * non-profit purposes only, such as academic, research and internal
17: * business use.
18: * (2) The SOFTWARE is protected by the Copyright Law of Japan and
19: * international copyright treaties. If you make copies of the SOFTWARE,
20: * with or without modification, as permitted hereunder, you shall affix
21: * to all such copies of the SOFTWARE the above copyright notice.
22: * (3) An explicit reference to this SOFTWARE and its copyright owner
23: * shall be made on your publication or presentation in any form of the
24: * results obtained by use of the SOFTWARE.
25: * (4) In the event that you modify the SOFTWARE, you shall notify FLL by
1.3 noro 26: * e-mail at risa-admin@sec.flab.fujitsu.co.jp of the detailed specification
1.2 noro 27: * for such modification or the source code of the modified part of the
28: * SOFTWARE.
29: *
30: * THE SOFTWARE IS PROVIDED AS IS WITHOUT ANY WARRANTY OF ANY KIND. FLL
31: * MAKES ABSOLUTELY NO WARRANTIES, EXPRESSED, IMPLIED OR STATUTORY, AND
32: * EXPRESSLY DISCLAIMS ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS
33: * FOR A PARTICULAR PURPOSE OR NONINFRINGEMENT OF THIRD PARTIES'
34: * RIGHTS. NO FLL DEALER, AGENT, EMPLOYEES IS AUTHORIZED TO MAKE ANY
35: * MODIFICATIONS, EXTENSIONS, OR ADDITIONS TO THIS WARRANTY.
36: * UNDER NO CIRCUMSTANCES AND UNDER NO LEGAL THEORY, TORT, CONTRACT,
37: * OR OTHERWISE, SHALL FLL BE LIABLE TO YOU OR ANY OTHER PERSON FOR ANY
38: * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, PUNITIVE OR CONSEQUENTIAL
39: * DAMAGES OF ANY CHARACTER, INCLUDING, WITHOUT LIMITATION, DAMAGES
40: * ARISING OUT OF OR RELATING TO THE SOFTWARE OR THIS AGREEMENT, DAMAGES
41: * FOR LOSS OF GOODWILL, WORK STOPPAGE, OR LOSS OF DATA, OR FOR ANY
42: * DAMAGES, EVEN IF FLL SHALL HAVE BEEN INFORMED OF THE POSSIBILITY OF
43: * SUCH DAMAGES, OR FOR ANY CLAIM BY ANY OTHER PARTY. EVEN IF A PART
44: * OF THE SOFTWARE HAS BEEN DEVELOPED BY A THIRD PARTY, THE THIRD PARTY
45: * DEVELOPER SHALL HAVE NO LIABILITY IN CONNECTION WITH THE USE,
46: * PERFORMANCE OR NON-PERFORMANCE OF THE SOFTWARE.
47: *
1.19 ! noro 48: * $OpenXM: OpenXM_contrib2/asir2000/builtin/pf.c,v 1.18 2013/06/14 04:47:17 ohara Exp $
1.2 noro 49: */
1.1 noro 50: #include "ca.h"
51: #include "math.h"
52: #include "parse.h"
53: #if 0
54: #include <alloca.h>
55: #endif
56:
57: double const_pi(),const_e();
58:
59: void make_ihyp(void);
60: void make_hyp(void);
61: void make_itri(void);
62: void make_tri(void);
63: void make_exp(void);
64: void simplify_pow(PFINS,Obj *);
1.18 ohara 65: FNODE partial_eval(FNODE f);
1.1 noro 66:
1.10 noro 67: void Pfunctor(),Pargs(),Pfunargs(),Pvtype(),Pcall(),Pdeval(),Pfunargs_ext();
1.1 noro 68: void Pregister_handler();
1.4 noro 69: void Peval_quote();
1.13 ohara 70: void Pmapat(), Pmap();
1.9 noro 71: void Padd_handler();
72: void Plist_handler();
73: void Pclear_handler();
1.1 noro 74:
75: struct ftab puref_tab[] = {
1.7 noro 76: {"mapat",Pmapat,-99999999},
1.13 ohara 77: {"map",Pmap,-99999999},
1.1 noro 78: {"functor",Pfunctor,1},
79: {"args",Pargs,1},
80: {"funargs",Pfunargs,1},
1.10 noro 81: {"funargs_ext",Pfunargs_ext,1},
1.1 noro 82: {"register_handler",Pregister_handler,1},
1.9 noro 83: {"add_handler",Padd_handler,2},
84: {"list_handler",Plist_handler,1},
85: {"clear_handler",Pclear_handler,1},
1.1 noro 86: {"call",Pcall,2},
87: {"vtype",Pvtype,1},
88: {"deval",Pdeval,1},
1.11 noro 89: {"eval_quote",Peval_quote,-2},
1.1 noro 90: {0,0,0},
91: };
92:
1.6 ohara 93: #if defined(PARI)
1.1 noro 94: int p_pi(),p_e();
95: int p_log(),p_exp(),p_pow();
96: int p_sin(),p_cos(),p_tan(),p_asin(),p_acos(),p_atan();
97: int p_sinh(),p_cosh(),p_tanh(),p_asinh(),p_acosh(),p_atanh();
98: #else
99: int p_pi,p_e;
100: int p_log,p_exp,p_pow;
101: int p_sin,p_cos,p_tan,p_asin,p_acos,p_atan;
102: int p_sinh,p_cosh,p_tanh,p_asinh,p_acosh,p_atanh;
103: #endif
104:
105: static V *uarg,*darg;
106: static P x,y;
107: static PF pidef,edef;
108: static PF logdef,expdef,powdef;
109: static PF sindef,cosdef,tandef;
110: static PF asindef,acosdef,atandef;
111: static PF sinhdef,coshdef,tanhdef;
112: static PF asinhdef,acoshdef,atanhdef;
113:
114: #define OALLOC(p,n) ((p)=(Obj *)CALLOC((n),sizeof(Obj)))
115:
116: double const_pi() { return 3.14159265358979323846264338327950288; }
117: double const_e() { return 2.718281828459045235360287471352662497; }
118:
1.19 ! noro 119: int simplify_elemfunc_ins();
! 120:
1.1 noro 121: void pf_init() {
122: uarg = (V *)CALLOC(1,sizeof(V));
123: uarg[0] = &oVAR[26]; MKV(uarg[0],x);
124:
125: darg = (V *)CALLOC(2,sizeof(V));
126: darg[0] = &oVAR[26];
127: darg[1] = &oVAR[27]; MKV(darg[1],y);
128:
129: mkpf("@pi",0,0,0,(int (*)())p_pi,const_pi,0,&pidef);
130: mkpf("@e",0,0,0,(int (*)())p_e,const_e,0,&edef);
131:
1.19 ! noro 132: mkpf("log",0,1,uarg,(int (*)())p_log,log,simplify_elemfunc_ins,&logdef);
! 133: mkpf("exp",0,1,uarg,(int (*)())p_exp,exp,simplify_elemfunc_ins,&expdef);
1.1 noro 134: mkpf("pow",0,2,darg,(int (*)())p_pow,pow,(int (*)())simplify_pow,&powdef);
135:
1.19 ! noro 136: mkpf("sin",0,1,uarg,(int (*)())p_sin,sin,simplify_elemfunc_ins,&sindef);
! 137: mkpf("cos",0,1,uarg,(int (*)())p_cos,cos,simplify_elemfunc_ins,&cosdef);
! 138: mkpf("tan",0,1,uarg,(int (*)())p_tan,tan,simplify_elemfunc_ins,&tandef);
! 139: mkpf("asin",0,1,uarg,(int (*)())p_asin,asin,simplify_elemfunc_ins,&asindef);
! 140: mkpf("acos",0,1,uarg,(int (*)())p_acos,acos,simplify_elemfunc_ins,&acosdef);
! 141: mkpf("atan",0,1,uarg,(int (*)())p_atan,atan,simplify_elemfunc_ins,&atandef);
! 142:
! 143: mkpf("sinh",0,1,uarg,(int (*)())p_sinh,sinh,simplify_elemfunc_ins,&sinhdef);
! 144: mkpf("cosh",0,1,uarg,(int (*)())p_cosh,cosh,simplify_elemfunc_ins,&coshdef);
! 145: mkpf("tanh",0,1,uarg,(int (*)())p_tanh,tanh,simplify_elemfunc_ins,&tanhdef);
1.1 noro 146: #if !defined(VISUAL)
1.19 ! noro 147: mkpf("asinh",0,1,uarg,(int (*)())p_asinh,asinh,simplify_elemfunc_ins,&asinhdef);
! 148: mkpf("acosh",0,1,uarg,(int (*)())p_acosh,acosh,simplify_elemfunc_ins,&acoshdef);
! 149: mkpf("atanh",0,1,uarg,(int (*)())p_atanh,atanh,simplify_elemfunc_ins,&atanhdef);
1.1 noro 150: #endif
151: make_exp();
152: make_tri();
153: make_itri();
154: make_hyp();
155: #if !defined(VISUAL)
156: make_ihyp();
157: #endif
158: }
159:
160: void make_exp() {
161: V v;
162: P u,vexp,vlog,vpow;
163: Obj *args;
164:
165: mkpfins(expdef,uarg,&v); MKV(v,vexp);
166: mkpfins(powdef,darg,&v); MKV(v,vpow);
167: mkpfins(logdef,uarg,&v); MKV(v,vlog);
168:
169: /* d/dx(log(x)) = 1/x */
170: OALLOC(logdef->deriv,1); divr(CO,(Obj)ONE,(Obj)x,&logdef->deriv[0]);
171:
172: /* d/dx(exp(x)) = exp(x) */
173: OALLOC(expdef->deriv,1); expdef->deriv[0] = (Obj)vexp;
174:
175: /* d/dy(x^y) = log(x)*x^y */
176: OALLOC(powdef->deriv,2); mulp(CO,vpow,vlog,(P *)&powdef->deriv[1]);
177:
178: /* d/dx(x^y) = y*x^(y-1) */
179: args = (Obj *)ALLOCA(2*sizeof(Obj));
180: args[0] = (Obj)x; subp(CO,y,(P)ONE,(P *)&args[1]);
181: _mkpfins(powdef,args,&v); MKV(v,u);
182: mulr(CO,(Obj)u,(Obj)y,&powdef->deriv[0]);
183: }
184:
185: void make_tri() {
186: V v;
187: P vcos,vsin,vtan,t;
188:
189: mkpfins(cosdef,uarg,&v); MKV(v,vcos);
190: mkpfins(sindef,uarg,&v); MKV(v,vsin);
191: mkpfins(tandef,uarg,&v); MKV(v,vtan);
192:
193: /* d/dx(sin(x)) = cos(x) */
194: OALLOC(sindef->deriv,1); sindef->deriv[0] = (Obj)vcos;
195:
196: /* d/dx(cos(x)) = -sin(x) */
197: OALLOC(cosdef->deriv,1); chsgnp(vsin,(P *)&cosdef->deriv[0]);
198:
199: /* d/dx(tan(x)) = 1+tan(x)^2 */
200: OALLOC(tandef->deriv,1);
201: mulr(CO,(Obj)vtan,(Obj)vtan,(Obj *)&t); addp(CO,(P)ONE,t,(P *)&tandef->deriv[0]);
202: }
203:
204: void make_itri() {
205: P t,xx;
206: Q mtwo;
207: V v;
208: Obj *args;
209:
210: /* d/dx(asin(x)) = (1-x^2)^(-1/2) */
211: OALLOC(asindef->deriv,1);
212: args = (Obj *)ALLOCA(2*sizeof(Obj));
213: mulp(CO,x,x,&xx); subp(CO,(P)ONE,xx,(P *)&args[0]);
214: STOQ(-2,mtwo); divq(ONE,mtwo,(Q *)&args[1]);
215: _mkpfins(powdef,args,&v); MKV(v,t);
216: asindef->deriv[0] = (Obj)t;
217:
218: /* d/dx(acos(x)) = -(1-x^2)^(-1/2) */
219: OALLOC(acosdef->deriv,1); chsgnp((P)asindef->deriv[0],(P *)&acosdef->deriv[0]);
220:
221: /* d/dx(atan(x)) = 1/(x^2+1) */
222: OALLOC(atandef->deriv,1);
223: addp(CO,(P)ONE,xx,&t); divr(CO,(Obj)ONE,(Obj)t,&atandef->deriv[0]);
224: }
225:
226: void make_hyp() {
227: V v;
228: P vcosh,vsinh,vtanh,t;
229:
230: mkpfins(coshdef,uarg,&v); MKV(v,vcosh);
231: mkpfins(sinhdef,uarg,&v); MKV(v,vsinh);
232: mkpfins(tanhdef,uarg,&v); MKV(v,vtanh);
233:
234: /* d/dx(sinh(x)) = cosh(x) */
235: OALLOC(sinhdef->deriv,1); sinhdef->deriv[0] = (Obj)vcosh;
236:
237: /* d/dx(cosh(x)) = sinh(x) */
238: OALLOC(coshdef->deriv,1); coshdef->deriv[0] = (Obj)vsinh;
239:
240: /* d/dx(tanh(x)) = 1-tanh(x)^2 */
241: OALLOC(tanhdef->deriv,1);
242: mulr(CO,(Obj)vtanh,(Obj)vtanh,(Obj *)&t); subp(CO,(P)ONE,t,(P *)&tanhdef->deriv[0]);
243: }
244:
245: void make_ihyp() {
246: P t,xx;
247: Q mtwo;
248: V v;
249: Obj *args;
250:
251: /* d/dx(asinh(x)) = (1+x^2)^(-1/2) */
252: OALLOC(asinhdef->deriv,1);
253: args = (Obj *)ALLOCA(2*sizeof(Obj));
254: mulp(CO,x,x,&xx); addp(CO,(P)ONE,xx,(P *)&args[0]);
255: STOQ(-2,mtwo); divq(ONE,mtwo,(Q *)&args[1]);
256: _mkpfins(powdef,args,&v); MKV(v,t);
257: asinhdef->deriv[0] = (Obj)t;
258:
259: /* d/dx(acosh(x)) = (x^2-1)^(-1/2) */
260: OALLOC(acoshdef->deriv,1);
261: subp(CO,xx,(P)ONE,(P *)&args[0]);
262: _mkpfins(powdef,args,&v); MKV(v,t);
263: acoshdef->deriv[0] = (Obj)t;
264:
265: /* d/dx(atanh(x)) = 1/(1-x^2) */
266: OALLOC(atanhdef->deriv,1);
267: subp(CO,(P)ONE,xx,&t); divr(CO,(Obj)ONE,(Obj)t,&atanhdef->deriv[0]);
268: }
269:
270: void mkpow(vl,a,e,r)
271: VL vl;
272: Obj a;
273: Obj e;
274: Obj *r;
275: {
276: PFINS ins;
277: PFAD ad;
278:
279: ins = (PFINS)CALLOC(1,sizeof(PF)+2*sizeof(struct oPFAD));
280: ins->pf = powdef; ad = ins->ad;
281: ad[0].d = 0; ad[0].arg = a; ad[1].d = 0; ad[1].arg = e;
282: simplify_ins(ins,r);
283: }
284:
285: void simplify_pow(ins,rp)
286: PFINS ins;
287: Obj *rp;
288: {
289: PF pf;
290: PFAD ad;
291: Obj a0,a1;
292: V v;
293: P t;
294:
295: pf = ins->pf; ad = ins->ad; a0 = ad[0].arg; a1 = ad[1].arg;
296: if ( !a1 )
297: *rp = (Obj)ONE;
1.8 noro 298: else if ( !a0 ) {
299: if ( RATN(a1) && SGN((Q)a1)>0 )
300: *rp = 0;
301: else if ( RATN(a1) && SGN((Q)a1) < 0 )
302: error("simplify_pow : division by 0");
303: else {
304: instov(ins,&v); MKV(v,t); *rp = (Obj)t;
305: }
306: } else if ( NUM(a1) && INT(a1) )
1.1 noro 307: arf_pwr(CO,a0,a1,rp);
308: else {
309: instov(ins,&v); MKV(v,t); *rp = (Obj)t;
310: }
311: }
312:
313: #define ISPFINS(p)\
1.10 noro 314: ((p)&&(ID(p) == O_P)&&((int)VR((P)p)->attr==V_PF)&&\
315: UNIQ(DEG(DC((P)p)))&&UNIQ(COEF(DC((P)p))))
1.1 noro 316:
317: void Pfunctor(arg,rp)
318: NODE arg;
319: P *rp;
320: {
321: P p;
322: FUNC t;
323: PF pf;
324: PFINS ins;
325:
326: p = (P)ARG0(arg);
327: if ( !ISPFINS(p) )
328: *rp = 0;
329: else {
330: ins = (PFINS)VR(p)->priv; pf = ins->pf;
331: t = (FUNC)MALLOC(sizeof(struct oFUNC));
1.7 noro 332: t->name = t->fullname = pf->name; t->id = A_PURE; t->argc = pf->argc;
1.1 noro 333: t->f.puref = pf;
334: makesrvar(t,rp);
335: }
336: }
337:
338: void Pargs(arg,rp)
339: NODE arg;
340: LIST *rp;
341: {
342: P p;
343: PF pf;
344: PFAD ad;
345: PFINS ins;
346: NODE n,n0;
347: int i;
348:
349: p = (P)ARG0(arg);
350: if ( !ISPFINS(p) )
351: *rp = 0;
352: else {
353: ins = (PFINS)VR(p)->priv; ad = ins->ad; pf = ins->pf;
354: for ( i = 0, n0 = 0; i < pf->argc; i++ ) {
355: NEXTNODE(n0,n); BDY(n) = (pointer)ad[i].arg;
356: }
357: if ( n0 )
358: NEXT(n) = 0;
359: MKLIST(*rp,n0);
360: }
361: }
362:
363: void Pfunargs(arg,rp)
364: NODE arg;
365: LIST *rp;
366: {
367: P p;
368: P f;
369: FUNC t;
370: PF pf;
371: PFINS ins;
372: PFAD ad;
373: NODE n,n0;
374: int i;
375:
376: p = (P)ARG0(arg);
377: if ( !ISPFINS(p) )
378: *rp = 0;
379: else {
380: ins = (PFINS)VR(p)->priv; ad = ins->ad; pf = ins->pf;
381: t = (FUNC)MALLOC(sizeof(struct oFUNC));
1.7 noro 382: t->name = t->fullname = pf->name; t->id = A_PURE; t->argc = pf->argc;
1.1 noro 383: t->f.puref = pf;
384: makesrvar(t,&f);
1.5 noro 385: n = n0 = 0; NEXTNODE(n0,n); BDY(n) = (pointer)f;
1.1 noro 386: for ( i = 0; i < pf->argc; i++ ) {
387: NEXTNODE(n0,n); BDY(n) = (pointer)ad[i].arg;
388: }
389: NEXT(n) = 0;
1.10 noro 390: MKLIST(*rp,n0);
391: }
392: }
393:
394: void Pfunargs_ext(arg,rp)
395: NODE arg;
396: LIST *rp;
397: {
398: P p;
399: P f;
400: FUNC t;
401: PF pf;
402: PFINS ins;
403: PFAD ad;
404: NODE n,n0,d,d0,a,a0;
405: LIST alist,dlist;
406: Q q;
407: int i;
408:
409: p = (P)ARG0(arg);
410: if ( !ISPFINS(p) )
411: *rp = 0;
412: else {
413: ins = (PFINS)VR(p)->priv; ad = ins->ad; pf = ins->pf;
414: t = (FUNC)MALLOC(sizeof(struct oFUNC));
415: t->name = t->fullname = pf->name; t->id = A_PURE; t->argc = pf->argc;
416: t->f.puref = pf;
417: makesrvar(t,&f);
418:
419: d0 = a0 = 0;
420: for ( i = 0; i < pf->argc; i++ ) {
421: NEXTNODE(d0,d); STOQ(ad[i].d,q); BDY(d) = (pointer)q;
422: NEXTNODE(a0,a); BDY(a) = (pointer)ad[i].arg;
423: }
424: NEXT(d) = 0; NEXT(a) = 0; MKLIST(alist,a0); MKLIST(dlist,d0);
425:
426: n0 = mknode(3,f,dlist,alist);
1.1 noro 427: MKLIST(*rp,n0);
428: }
429: }
430:
431: void Pvtype(arg,rp)
432: NODE arg;
433: Q *rp;
434: {
435: P p;
436:
437: p = (P)ARG0(arg);
438: if ( !p || ID(p) != O_P )
439: *rp = 0;
440: else
441: STOQ((int)VR(p)->attr,*rp);
442: }
443:
1.9 noro 444: extern NODE user_int_handler,user_quit_handler;
1.1 noro 445:
446: void Pregister_handler(arg,rp)
447: NODE arg;
448: Q *rp;
449: {
450: P p;
451: V v;
1.9 noro 452: NODE n;
1.1 noro 453: FUNC func;
454:
455: p = (P)ARG0(arg);
1.9 noro 456: if ( !p ) {
457: user_int_handler = 0;
458: *rp = 0;
459: return;
460: } else if ( OID(p) != 2 )
1.1 noro 461: error("register_hanlder : invalid argument");
462: v = VR(p);
463: if ( (int)v->attr != V_SR )
464: error("register_hanlder : no such function");
465: else {
466: func = (FUNC)v->priv;
467: if ( func->argc )
468: error("register_hanlder : the function must be with no argument");
469: else {
1.9 noro 470: MKNODE(n,(pointer)func,user_int_handler);
471: user_int_handler = n;
1.1 noro 472: *rp = ONE;
1.9 noro 473: }
474: }
475: }
476:
477: void Padd_handler(arg,rp)
478: NODE arg;
479: Q *rp;
480: {
481: P p;
482: V v;
483: NODE n;
484: FUNC func;
485: char *name;
486: NODE *hlistp;
487:
488: asir_assert(ARG0(arg),O_STR,"add_handler");
489: name = BDY((STRING)ARG0(arg));
490: p = (P)ARG1(arg);
491: if ( !strcmp(name,"intr") )
492: hlistp = &user_int_handler;
493: else if ( !strcmp(name,"quit") )
494: hlistp = &user_quit_handler;
495: else
496: error("add_handler : invalid keyword (must be \"intr\" or \"quit\")");
497: if ( !p ) {
498: *hlistp = 0; *rp = 0;
499: return;
500: }
501: if ( OID(p) == 2 ) {
502: v = VR(p);
503: if ( (int)v->attr != V_SR )
504: error("add_hanlder : no such function");
505: func = (FUNC)v->priv;
506: } else if ( OID(p) == O_STR ) {
507: gen_searchf_searchonly(BDY((STRING)p),&func);
508: if ( !func )
509: error("add_hanlder : no such function");
1.1 noro 510: }
1.9 noro 511: if ( func->argc )
512: error("register_hanlder : the function must be with no argument");
513: else {
514: MKNODE(n,(pointer)func,*hlistp);
515: *hlistp = n;
516: *rp = ONE;
517: }
518: }
519:
520: void Plist_handler(arg,rp)
521: NODE arg;
522: LIST *rp;
523: {
524: NODE r0,r,t;
525: char *name;
526: NODE hlist;
527: STRING fname;
528:
529: asir_assert(ARG0(arg),O_STR,"list_handler");
530: name = BDY((STRING)ARG0(arg));
531: if ( !strcmp(name,"intr") )
532: hlist = user_int_handler;
533: else if ( !strcmp(name,"quit") )
534: hlist = user_quit_handler;
535: else
536: error("list_handler : invalid keyword (must be \"intr\" or \"quit\")");
537: for ( r0 = 0, t = hlist; t; t = NEXT(t) ) {
538: NEXTNODE(r0,r);
539: MKSTR(fname,((FUNC)BDY(t))->fullname);
540: BDY(r) = (pointer)fname;
541: }
542: if ( r0 ) NEXT(r) = 0;
543: MKLIST(*rp,r0);
544: }
545:
546: void Pclear_handler(arg,rp)
547: NODE arg;
548: Q *rp;
549: {
550: NODE r0,r,t;
551: char *name;
552: NODE hlist;
553: STRING fname;
554:
555: asir_assert(ARG0(arg),O_STR,"clear_handler");
556: name = BDY((STRING)ARG0(arg));
557: if ( !strcmp(name,"intr") )
558: user_int_handler = 0;
559: else if ( !strcmp(name,"quit") )
560: user_quit_handler = 0;
561: else
562: error("clear_handler : invalid keyword (must be \"intr\" or \"quit\")");
563: *rp = 0;
1.1 noro 564: }
565:
1.7 noro 566: void Pcall(NODE arg,Obj *rp)
1.1 noro 567: {
568: P p;
569: V v;
1.14 ohara 570: NODE n,n1;
571: LIST list;
572: VECT vect;
573: pointer *a;
574: int len,i;
1.1 noro 575:
576: p = (P)ARG0(arg);
577: if ( !p || OID(p) != 2 )
578: error("call : invalid argument");
579: v = VR(p);
580: if ( (int)v->attr != V_SR )
581: error("call : no such function");
1.14 ohara 582: else {
583: list = (LIST) ARG1(arg);
584: if ( list ) {
585: switch (OID(list)) {
586: case O_VECT:
587: vect = (VECT)list; len = vect->len; a = BDY(vect);
588: for ( i = len - 1, n = 0; i >= 0; i-- ) {
589: MKNODE(n1,a[i],n); n = n1;
590: }
591: MKLIST(list,n);
592: /* falling next case */
593: case O_LIST:
1.15 ohara 594: *rp = (Obj)bevalf_with_opts((FUNC)v->priv,BDY(list),current_option);
1.14 ohara 595: return;
596: default:
597: break;
598: }
599: }
600: error("call : invalid argument");
601: }
1.7 noro 602: }
603:
604: /* at=position of arg to be used for iteration */
605:
606: void Pmapat(NODE arg,Obj *rp)
607: {
608: LIST args;
609: NODE node,rest,t0,t,n,r,r0;
610: P fpoly;
611: V fvar;
612: FUNC f;
613: VECT v,rv;
614: MAT m,rm;
615: LIST rl;
616: int len,row,col,i,j,pos;
617: Obj iter;
618: pointer val;
1.16 ohara 619: NODE option;
620:
621: option = current_option;
1.7 noro 622:
623: if ( argc(arg) < 3 )
624: error("mapat : too few arguments");
625:
626: fpoly = (P)ARG0(arg);
627: if ( !fpoly || OID(fpoly) != O_P )
628: error("mapat : invalid function specification");
629: fvar = VR(fpoly);
630: if ( fvar->attr != (pointer)V_SR || !(f=(FUNC)fvar->priv) )
631: error("mapat : invalid function specification");
632: if ( !INT(ARG1(arg)) )
633: error("mapat : invalid position");
634: pos = QTOS((Q)ARG1(arg));
635: node = NEXT(NEXT(arg));
636: len = length(node);
637: if ( pos >= len )
638: error("evalmapatf : invalid position");
639: r0 = 0;
640: for ( i = 0, t = node; i < pos; i++, t = NEXT(t) ) {
641: NEXTNODE(r0,r);
642: BDY(r) = BDY(t);
643: }
644: NEXTNODE(r0,r);
645: iter = BDY(t); rest = NEXT(t);
646: if ( !iter ) {
1.16 ohara 647: *rp = bevalf_with_opts(f,node,option);
1.7 noro 648: return;
649: }
650: switch ( OID(iter) ) {
651: case O_VECT:
652: v = (VECT)iter; len = v->len; MKVECT(rv,len);
653: for ( i = 0; i < len; i++ ) {
654: BDY(r) = BDY(v)[i]; NEXT(r) = rest;
1.16 ohara 655: BDY(rv)[i] = bevalf_with_opts(f,r0,option);
1.7 noro 656: }
657: *rp = (Obj)rv;
658: break;
659: case O_MAT:
660: m = (MAT)iter; row = m->row; col = m->col; MKMAT(rm,row,col);
661: for ( i = 0; i < row; i++ )
662: for ( j = 0; j < col; j++ ) {
663: BDY(r) = BDY(m)[i][j]; NEXT(r) = rest;
1.16 ohara 664: BDY(rm)[i][j] = bevalf_with_opts(f,r0,option);
1.7 noro 665: }
666: *rp = (Obj)rm;
667: break;
668: case O_LIST:
669: n = BDY((LIST)iter);
670: for ( t0 = t = 0; n; n = NEXT(n) ) {
671: BDY(r) = BDY(n); NEXT(r) = rest;
1.16 ohara 672: NEXTNODE(t0,t); BDY(t) = bevalf_with_opts(f,r0,option);
1.7 noro 673: }
674: if ( t0 )
675: NEXT(t) = 0;
676: MKLIST(rl,t0);
677: *rp = (Obj)rl;
678: break;
679: default:
1.16 ohara 680: *rp = bevalf_with_opts(f,node,option);
1.7 noro 681: break;
682: }
1.1 noro 683: }
684:
1.13 ohara 685: /* An implementation of 'map' as builtin function. */
686: void Pmap(NODE arg,Obj *rp)
687: {
688: LIST args;
689: NODE node,rest,t0,t,n,r,r0;
690: P fpoly;
691: V fvar;
692: FUNC f;
693: VECT v,rv;
694: MAT m,rm;
695: LIST rl;
696: int len,row,col,i,j;
697: Obj iter;
698: pointer val;
1.16 ohara 699: NODE option;
700:
701: option = current_option;
1.13 ohara 702:
703: if ( argc(arg) < 2 )
704: error("mapat : too few arguments");
705:
706: fpoly = (P)ARG0(arg);
707: if ( !fpoly || OID(fpoly) != O_P )
708: error("map : invalid function specification");
709: fvar = VR(fpoly);
710: if ( fvar->attr != (pointer)V_SR || !(f=(FUNC)fvar->priv) )
711: error("map : invalid function specification");
712:
713: node = NEXT(arg);
714: len = length(node);
715: if ( 0 >= len )
716: error("evalmapf : invalid position");
717: r0 = 0;
718: NEXTNODE(r0,r);
1.17 noro 719: iter = BDY(node); rest = NEXT(node);
1.13 ohara 720: if ( !iter ) {
1.16 ohara 721: *rp = bevalf_with_opts(f,node,option);
1.13 ohara 722: return;
723: }
724: switch ( OID(iter) ) {
725: case O_VECT:
726: v = (VECT)iter; len = v->len; MKVECT(rv,len);
727: for ( i = 0; i < len; i++ ) {
728: BDY(r) = BDY(v)[i]; NEXT(r) = rest;
1.16 ohara 729: BDY(rv)[i] = bevalf_with_opts(f,r0,option);
1.13 ohara 730: }
731: *rp = (Obj)rv;
732: break;
733: case O_MAT:
734: m = (MAT)iter; row = m->row; col = m->col; MKMAT(rm,row,col);
735: for ( i = 0; i < row; i++ )
736: for ( j = 0; j < col; j++ ) {
737: BDY(r) = BDY(m)[i][j]; NEXT(r) = rest;
1.16 ohara 738: BDY(rm)[i][j] = bevalf_with_opts(f,r0,option);
1.13 ohara 739: }
740: *rp = (Obj)rm;
741: break;
742: case O_LIST:
743: n = BDY((LIST)iter);
744: for ( t0 = t = 0; n; n = NEXT(n) ) {
745: BDY(r) = BDY(n); NEXT(r) = rest;
1.16 ohara 746: NEXTNODE(t0,t); BDY(t) = bevalf_with_opts(f,r0,option);
1.13 ohara 747: }
748: if ( t0 )
749: NEXT(t) = 0;
750: MKLIST(rl,t0);
751: *rp = (Obj)rl;
752: break;
753: default:
1.16 ohara 754: *rp = bevalf_with_opts(f,node,option);
1.13 ohara 755: break;
756: }
757: }
758:
1.1 noro 759: void Pdeval(arg,rp)
760: NODE arg;
761: Obj *rp;
762: {
763: asir_assert(ARG0(arg),O_R,"deval");
764: devalr(CO,(Obj)ARG0(arg),rp);
765: }
766:
1.4 noro 767: void Peval_quote(arg,rp)
768: NODE arg;
769: Obj *rp;
770: {
1.11 noro 771: FNODE a;
772: QUOTE q;
1.12 noro 773: Obj f;
1.11 noro 774:
1.12 noro 775: f = (Obj)ARG0(arg);
776: if ( !f || OID(f) != O_QUOTE ) {
777: *rp = f;
778: return;
779: }
1.11 noro 780: if ( argc(arg) == 2 && ARG1(arg) ) {
781: a = partial_eval((FNODE)BDY((QUOTE)ARG0(arg)));
782: MKQUOTE(q,a);
783: *rp = (Obj)q;
784: } else
785: *rp = eval((FNODE)BDY((QUOTE)ARG0(arg)));
1.4 noro 786: }
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>