Annotation of OpenXM_contrib2/asir2000/builtin/pf.c, Revision 1.20
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.20 ! noro 48: * $OpenXM: OpenXM_contrib2/asir2000/builtin/pf.c,v 1.19 2014/09/19 01:25:59 noro 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.20 ! noro 93: int mp_pi(),mp_e();
! 94: int mp_exp(), mp_log(), mp_pow();
! 95: int mp_sin(),mp_cos(),mp_tan(),mp_asin(),mp_acos(),mp_atan();
! 96: int mp_sinh(),mp_cosh(),mp_tanh(),mp_asinh(),mp_acosh(),mp_atanh();
! 97:
1.1 noro 98:
99: static V *uarg,*darg;
100: static P x,y;
101: static PF pidef,edef;
102: static PF logdef,expdef,powdef;
103: static PF sindef,cosdef,tandef;
104: static PF asindef,acosdef,atandef;
105: static PF sinhdef,coshdef,tanhdef;
106: static PF asinhdef,acoshdef,atanhdef;
107:
108: #define OALLOC(p,n) ((p)=(Obj *)CALLOC((n),sizeof(Obj)))
109:
110: double const_pi() { return 3.14159265358979323846264338327950288; }
111: double const_e() { return 2.718281828459045235360287471352662497; }
112:
1.19 noro 113: int simplify_elemfunc_ins();
114:
1.1 noro 115: void pf_init() {
116: uarg = (V *)CALLOC(1,sizeof(V));
117: uarg[0] = &oVAR[26]; MKV(uarg[0],x);
118:
119: darg = (V *)CALLOC(2,sizeof(V));
120: darg[0] = &oVAR[26];
121: darg[1] = &oVAR[27]; MKV(darg[1],y);
122:
1.20 ! noro 123: mkpf("@pi",0,0,0,(int (*)())mp_pi,const_pi,0,&pidef);
! 124: mkpf("@e",0,0,0,(int (*)())mp_e,const_e,0,&edef);
1.1 noro 125:
1.20 ! noro 126: mkpf("log",0,1,uarg,(int (*)())mp_log,log,simplify_elemfunc_ins,&logdef);
! 127: mkpf("exp",0,1,uarg,(int (*)())mp_exp,exp,simplify_elemfunc_ins,&expdef);
! 128: mkpf("pow",0,2,darg,(int (*)())mp_pow,pow,(int (*)())simplify_pow,&powdef);
! 129:
! 130: mkpf("sin",0,1,uarg,(int (*)())mp_sin,sin,simplify_elemfunc_ins,&sindef);
! 131: mkpf("cos",0,1,uarg,(int (*)())mp_cos,cos,simplify_elemfunc_ins,&cosdef);
! 132: mkpf("tan",0,1,uarg,(int (*)())mp_tan,tan,simplify_elemfunc_ins,&tandef);
! 133: mkpf("asin",0,1,uarg,(int (*)())mp_asin,asin,simplify_elemfunc_ins,&asindef);
! 134: mkpf("acos",0,1,uarg,(int (*)())mp_acos,acos,simplify_elemfunc_ins,&acosdef);
! 135: mkpf("atan",0,1,uarg,(int (*)())mp_atan,atan,simplify_elemfunc_ins,&atandef);
! 136:
! 137: mkpf("sinh",0,1,uarg,(int (*)())mp_sinh,sinh,simplify_elemfunc_ins,&sinhdef);
! 138: mkpf("cosh",0,1,uarg,(int (*)())mp_cosh,cosh,simplify_elemfunc_ins,&coshdef);
! 139: mkpf("tanh",0,1,uarg,(int (*)())mp_tanh,tanh,simplify_elemfunc_ins,&tanhdef);
1.1 noro 140: #if !defined(VISUAL)
1.20 ! noro 141: mkpf("asinh",0,1,uarg,(int (*)())mp_asinh,asinh,simplify_elemfunc_ins,&asinhdef);
! 142: mkpf("acosh",0,1,uarg,(int (*)())mp_acosh,acosh,simplify_elemfunc_ins,&acoshdef);
! 143: mkpf("atanh",0,1,uarg,(int (*)())mp_atanh,atanh,simplify_elemfunc_ins,&atanhdef);
1.1 noro 144: #endif
145: make_exp();
146: make_tri();
147: make_itri();
148: make_hyp();
149: #if !defined(VISUAL)
150: make_ihyp();
151: #endif
152: }
153:
154: void make_exp() {
155: V v;
156: P u,vexp,vlog,vpow;
157: Obj *args;
158:
159: mkpfins(expdef,uarg,&v); MKV(v,vexp);
160: mkpfins(powdef,darg,&v); MKV(v,vpow);
161: mkpfins(logdef,uarg,&v); MKV(v,vlog);
162:
163: /* d/dx(log(x)) = 1/x */
164: OALLOC(logdef->deriv,1); divr(CO,(Obj)ONE,(Obj)x,&logdef->deriv[0]);
165:
166: /* d/dx(exp(x)) = exp(x) */
167: OALLOC(expdef->deriv,1); expdef->deriv[0] = (Obj)vexp;
168:
169: /* d/dy(x^y) = log(x)*x^y */
170: OALLOC(powdef->deriv,2); mulp(CO,vpow,vlog,(P *)&powdef->deriv[1]);
171:
172: /* d/dx(x^y) = y*x^(y-1) */
173: args = (Obj *)ALLOCA(2*sizeof(Obj));
174: args[0] = (Obj)x; subp(CO,y,(P)ONE,(P *)&args[1]);
175: _mkpfins(powdef,args,&v); MKV(v,u);
176: mulr(CO,(Obj)u,(Obj)y,&powdef->deriv[0]);
177: }
178:
179: void make_tri() {
180: V v;
181: P vcos,vsin,vtan,t;
182:
183: mkpfins(cosdef,uarg,&v); MKV(v,vcos);
184: mkpfins(sindef,uarg,&v); MKV(v,vsin);
185: mkpfins(tandef,uarg,&v); MKV(v,vtan);
186:
187: /* d/dx(sin(x)) = cos(x) */
188: OALLOC(sindef->deriv,1); sindef->deriv[0] = (Obj)vcos;
189:
190: /* d/dx(cos(x)) = -sin(x) */
191: OALLOC(cosdef->deriv,1); chsgnp(vsin,(P *)&cosdef->deriv[0]);
192:
193: /* d/dx(tan(x)) = 1+tan(x)^2 */
194: OALLOC(tandef->deriv,1);
195: mulr(CO,(Obj)vtan,(Obj)vtan,(Obj *)&t); addp(CO,(P)ONE,t,(P *)&tandef->deriv[0]);
196: }
197:
198: void make_itri() {
199: P t,xx;
200: Q mtwo;
201: V v;
202: Obj *args;
203:
204: /* d/dx(asin(x)) = (1-x^2)^(-1/2) */
205: OALLOC(asindef->deriv,1);
206: args = (Obj *)ALLOCA(2*sizeof(Obj));
207: mulp(CO,x,x,&xx); subp(CO,(P)ONE,xx,(P *)&args[0]);
208: STOQ(-2,mtwo); divq(ONE,mtwo,(Q *)&args[1]);
209: _mkpfins(powdef,args,&v); MKV(v,t);
210: asindef->deriv[0] = (Obj)t;
211:
212: /* d/dx(acos(x)) = -(1-x^2)^(-1/2) */
213: OALLOC(acosdef->deriv,1); chsgnp((P)asindef->deriv[0],(P *)&acosdef->deriv[0]);
214:
215: /* d/dx(atan(x)) = 1/(x^2+1) */
216: OALLOC(atandef->deriv,1);
217: addp(CO,(P)ONE,xx,&t); divr(CO,(Obj)ONE,(Obj)t,&atandef->deriv[0]);
218: }
219:
220: void make_hyp() {
221: V v;
222: P vcosh,vsinh,vtanh,t;
223:
224: mkpfins(coshdef,uarg,&v); MKV(v,vcosh);
225: mkpfins(sinhdef,uarg,&v); MKV(v,vsinh);
226: mkpfins(tanhdef,uarg,&v); MKV(v,vtanh);
227:
228: /* d/dx(sinh(x)) = cosh(x) */
229: OALLOC(sinhdef->deriv,1); sinhdef->deriv[0] = (Obj)vcosh;
230:
231: /* d/dx(cosh(x)) = sinh(x) */
232: OALLOC(coshdef->deriv,1); coshdef->deriv[0] = (Obj)vsinh;
233:
234: /* d/dx(tanh(x)) = 1-tanh(x)^2 */
235: OALLOC(tanhdef->deriv,1);
236: mulr(CO,(Obj)vtanh,(Obj)vtanh,(Obj *)&t); subp(CO,(P)ONE,t,(P *)&tanhdef->deriv[0]);
237: }
238:
239: void make_ihyp() {
240: P t,xx;
241: Q mtwo;
242: V v;
243: Obj *args;
244:
245: /* d/dx(asinh(x)) = (1+x^2)^(-1/2) */
246: OALLOC(asinhdef->deriv,1);
247: args = (Obj *)ALLOCA(2*sizeof(Obj));
248: mulp(CO,x,x,&xx); addp(CO,(P)ONE,xx,(P *)&args[0]);
249: STOQ(-2,mtwo); divq(ONE,mtwo,(Q *)&args[1]);
250: _mkpfins(powdef,args,&v); MKV(v,t);
251: asinhdef->deriv[0] = (Obj)t;
252:
253: /* d/dx(acosh(x)) = (x^2-1)^(-1/2) */
254: OALLOC(acoshdef->deriv,1);
255: subp(CO,xx,(P)ONE,(P *)&args[0]);
256: _mkpfins(powdef,args,&v); MKV(v,t);
257: acoshdef->deriv[0] = (Obj)t;
258:
259: /* d/dx(atanh(x)) = 1/(1-x^2) */
260: OALLOC(atanhdef->deriv,1);
261: subp(CO,(P)ONE,xx,&t); divr(CO,(Obj)ONE,(Obj)t,&atanhdef->deriv[0]);
262: }
263:
264: void mkpow(vl,a,e,r)
265: VL vl;
266: Obj a;
267: Obj e;
268: Obj *r;
269: {
270: PFINS ins;
271: PFAD ad;
272:
273: ins = (PFINS)CALLOC(1,sizeof(PF)+2*sizeof(struct oPFAD));
274: ins->pf = powdef; ad = ins->ad;
275: ad[0].d = 0; ad[0].arg = a; ad[1].d = 0; ad[1].arg = e;
276: simplify_ins(ins,r);
277: }
278:
279: void simplify_pow(ins,rp)
280: PFINS ins;
281: Obj *rp;
282: {
283: PF pf;
284: PFAD ad;
285: Obj a0,a1;
286: V v;
287: P t;
288:
289: pf = ins->pf; ad = ins->ad; a0 = ad[0].arg; a1 = ad[1].arg;
290: if ( !a1 )
291: *rp = (Obj)ONE;
1.8 noro 292: else if ( !a0 ) {
293: if ( RATN(a1) && SGN((Q)a1)>0 )
294: *rp = 0;
295: else if ( RATN(a1) && SGN((Q)a1) < 0 )
296: error("simplify_pow : division by 0");
297: else {
298: instov(ins,&v); MKV(v,t); *rp = (Obj)t;
299: }
300: } else if ( NUM(a1) && INT(a1) )
1.1 noro 301: arf_pwr(CO,a0,a1,rp);
302: else {
303: instov(ins,&v); MKV(v,t); *rp = (Obj)t;
304: }
305: }
306:
307: #define ISPFINS(p)\
1.10 noro 308: ((p)&&(ID(p) == O_P)&&((int)VR((P)p)->attr==V_PF)&&\
309: UNIQ(DEG(DC((P)p)))&&UNIQ(COEF(DC((P)p))))
1.1 noro 310:
311: void Pfunctor(arg,rp)
312: NODE arg;
313: P *rp;
314: {
315: P p;
316: FUNC t;
317: PF pf;
318: PFINS ins;
319:
320: p = (P)ARG0(arg);
321: if ( !ISPFINS(p) )
322: *rp = 0;
323: else {
324: ins = (PFINS)VR(p)->priv; pf = ins->pf;
325: t = (FUNC)MALLOC(sizeof(struct oFUNC));
1.7 noro 326: t->name = t->fullname = pf->name; t->id = A_PURE; t->argc = pf->argc;
1.1 noro 327: t->f.puref = pf;
328: makesrvar(t,rp);
329: }
330: }
331:
332: void Pargs(arg,rp)
333: NODE arg;
334: LIST *rp;
335: {
336: P p;
337: PF pf;
338: PFAD ad;
339: PFINS ins;
340: NODE n,n0;
341: int i;
342:
343: p = (P)ARG0(arg);
344: if ( !ISPFINS(p) )
345: *rp = 0;
346: else {
347: ins = (PFINS)VR(p)->priv; ad = ins->ad; pf = ins->pf;
348: for ( i = 0, n0 = 0; i < pf->argc; i++ ) {
349: NEXTNODE(n0,n); BDY(n) = (pointer)ad[i].arg;
350: }
351: if ( n0 )
352: NEXT(n) = 0;
353: MKLIST(*rp,n0);
354: }
355: }
356:
357: void Pfunargs(arg,rp)
358: NODE arg;
359: LIST *rp;
360: {
361: P p;
362: P f;
363: FUNC t;
364: PF pf;
365: PFINS ins;
366: PFAD ad;
367: NODE n,n0;
368: int i;
369:
370: p = (P)ARG0(arg);
371: if ( !ISPFINS(p) )
372: *rp = 0;
373: else {
374: ins = (PFINS)VR(p)->priv; ad = ins->ad; pf = ins->pf;
375: t = (FUNC)MALLOC(sizeof(struct oFUNC));
1.7 noro 376: t->name = t->fullname = pf->name; t->id = A_PURE; t->argc = pf->argc;
1.1 noro 377: t->f.puref = pf;
378: makesrvar(t,&f);
1.5 noro 379: n = n0 = 0; NEXTNODE(n0,n); BDY(n) = (pointer)f;
1.1 noro 380: for ( i = 0; i < pf->argc; i++ ) {
381: NEXTNODE(n0,n); BDY(n) = (pointer)ad[i].arg;
382: }
383: NEXT(n) = 0;
1.10 noro 384: MKLIST(*rp,n0);
385: }
386: }
387:
388: void Pfunargs_ext(arg,rp)
389: NODE arg;
390: LIST *rp;
391: {
392: P p;
393: P f;
394: FUNC t;
395: PF pf;
396: PFINS ins;
397: PFAD ad;
398: NODE n,n0,d,d0,a,a0;
399: LIST alist,dlist;
400: Q q;
401: int i;
402:
403: p = (P)ARG0(arg);
404: if ( !ISPFINS(p) )
405: *rp = 0;
406: else {
407: ins = (PFINS)VR(p)->priv; ad = ins->ad; pf = ins->pf;
408: t = (FUNC)MALLOC(sizeof(struct oFUNC));
409: t->name = t->fullname = pf->name; t->id = A_PURE; t->argc = pf->argc;
410: t->f.puref = pf;
411: makesrvar(t,&f);
412:
413: d0 = a0 = 0;
414: for ( i = 0; i < pf->argc; i++ ) {
415: NEXTNODE(d0,d); STOQ(ad[i].d,q); BDY(d) = (pointer)q;
416: NEXTNODE(a0,a); BDY(a) = (pointer)ad[i].arg;
417: }
418: NEXT(d) = 0; NEXT(a) = 0; MKLIST(alist,a0); MKLIST(dlist,d0);
419:
420: n0 = mknode(3,f,dlist,alist);
1.1 noro 421: MKLIST(*rp,n0);
422: }
423: }
424:
425: void Pvtype(arg,rp)
426: NODE arg;
427: Q *rp;
428: {
429: P p;
430:
431: p = (P)ARG0(arg);
432: if ( !p || ID(p) != O_P )
433: *rp = 0;
434: else
435: STOQ((int)VR(p)->attr,*rp);
436: }
437:
1.9 noro 438: extern NODE user_int_handler,user_quit_handler;
1.1 noro 439:
440: void Pregister_handler(arg,rp)
441: NODE arg;
442: Q *rp;
443: {
444: P p;
445: V v;
1.9 noro 446: NODE n;
1.1 noro 447: FUNC func;
448:
449: p = (P)ARG0(arg);
1.9 noro 450: if ( !p ) {
451: user_int_handler = 0;
452: *rp = 0;
453: return;
454: } else if ( OID(p) != 2 )
1.1 noro 455: error("register_hanlder : invalid argument");
456: v = VR(p);
457: if ( (int)v->attr != V_SR )
458: error("register_hanlder : no such function");
459: else {
460: func = (FUNC)v->priv;
461: if ( func->argc )
462: error("register_hanlder : the function must be with no argument");
463: else {
1.9 noro 464: MKNODE(n,(pointer)func,user_int_handler);
465: user_int_handler = n;
1.1 noro 466: *rp = ONE;
1.9 noro 467: }
468: }
469: }
470:
471: void Padd_handler(arg,rp)
472: NODE arg;
473: Q *rp;
474: {
475: P p;
476: V v;
477: NODE n;
478: FUNC func;
479: char *name;
480: NODE *hlistp;
481:
482: asir_assert(ARG0(arg),O_STR,"add_handler");
483: name = BDY((STRING)ARG0(arg));
484: p = (P)ARG1(arg);
485: if ( !strcmp(name,"intr") )
486: hlistp = &user_int_handler;
487: else if ( !strcmp(name,"quit") )
488: hlistp = &user_quit_handler;
489: else
490: error("add_handler : invalid keyword (must be \"intr\" or \"quit\")");
491: if ( !p ) {
492: *hlistp = 0; *rp = 0;
493: return;
494: }
495: if ( OID(p) == 2 ) {
496: v = VR(p);
497: if ( (int)v->attr != V_SR )
498: error("add_hanlder : no such function");
499: func = (FUNC)v->priv;
500: } else if ( OID(p) == O_STR ) {
501: gen_searchf_searchonly(BDY((STRING)p),&func);
502: if ( !func )
503: error("add_hanlder : no such function");
1.1 noro 504: }
1.9 noro 505: if ( func->argc )
506: error("register_hanlder : the function must be with no argument");
507: else {
508: MKNODE(n,(pointer)func,*hlistp);
509: *hlistp = n;
510: *rp = ONE;
511: }
512: }
513:
514: void Plist_handler(arg,rp)
515: NODE arg;
516: LIST *rp;
517: {
518: NODE r0,r,t;
519: char *name;
520: NODE hlist;
521: STRING fname;
522:
523: asir_assert(ARG0(arg),O_STR,"list_handler");
524: name = BDY((STRING)ARG0(arg));
525: if ( !strcmp(name,"intr") )
526: hlist = user_int_handler;
527: else if ( !strcmp(name,"quit") )
528: hlist = user_quit_handler;
529: else
530: error("list_handler : invalid keyword (must be \"intr\" or \"quit\")");
531: for ( r0 = 0, t = hlist; t; t = NEXT(t) ) {
532: NEXTNODE(r0,r);
533: MKSTR(fname,((FUNC)BDY(t))->fullname);
534: BDY(r) = (pointer)fname;
535: }
536: if ( r0 ) NEXT(r) = 0;
537: MKLIST(*rp,r0);
538: }
539:
540: void Pclear_handler(arg,rp)
541: NODE arg;
542: Q *rp;
543: {
544: NODE r0,r,t;
545: char *name;
546: NODE hlist;
547: STRING fname;
548:
549: asir_assert(ARG0(arg),O_STR,"clear_handler");
550: name = BDY((STRING)ARG0(arg));
551: if ( !strcmp(name,"intr") )
552: user_int_handler = 0;
553: else if ( !strcmp(name,"quit") )
554: user_quit_handler = 0;
555: else
556: error("clear_handler : invalid keyword (must be \"intr\" or \"quit\")");
557: *rp = 0;
1.1 noro 558: }
559:
1.7 noro 560: void Pcall(NODE arg,Obj *rp)
1.1 noro 561: {
562: P p;
563: V v;
1.14 ohara 564: NODE n,n1;
565: LIST list;
566: VECT vect;
567: pointer *a;
568: int len,i;
1.1 noro 569:
570: p = (P)ARG0(arg);
571: if ( !p || OID(p) != 2 )
572: error("call : invalid argument");
573: v = VR(p);
574: if ( (int)v->attr != V_SR )
575: error("call : no such function");
1.14 ohara 576: else {
577: list = (LIST) ARG1(arg);
578: if ( list ) {
579: switch (OID(list)) {
580: case O_VECT:
581: vect = (VECT)list; len = vect->len; a = BDY(vect);
582: for ( i = len - 1, n = 0; i >= 0; i-- ) {
583: MKNODE(n1,a[i],n); n = n1;
584: }
585: MKLIST(list,n);
586: /* falling next case */
587: case O_LIST:
1.15 ohara 588: *rp = (Obj)bevalf_with_opts((FUNC)v->priv,BDY(list),current_option);
1.14 ohara 589: return;
590: default:
591: break;
592: }
593: }
594: error("call : invalid argument");
595: }
1.7 noro 596: }
597:
598: /* at=position of arg to be used for iteration */
599:
600: void Pmapat(NODE arg,Obj *rp)
601: {
602: LIST args;
603: NODE node,rest,t0,t,n,r,r0;
604: P fpoly;
605: V fvar;
606: FUNC f;
607: VECT v,rv;
608: MAT m,rm;
609: LIST rl;
610: int len,row,col,i,j,pos;
611: Obj iter;
612: pointer val;
1.16 ohara 613: NODE option;
614:
615: option = current_option;
1.7 noro 616:
617: if ( argc(arg) < 3 )
618: error("mapat : too few arguments");
619:
620: fpoly = (P)ARG0(arg);
621: if ( !fpoly || OID(fpoly) != O_P )
622: error("mapat : invalid function specification");
623: fvar = VR(fpoly);
624: if ( fvar->attr != (pointer)V_SR || !(f=(FUNC)fvar->priv) )
625: error("mapat : invalid function specification");
626: if ( !INT(ARG1(arg)) )
627: error("mapat : invalid position");
628: pos = QTOS((Q)ARG1(arg));
629: node = NEXT(NEXT(arg));
630: len = length(node);
631: if ( pos >= len )
632: error("evalmapatf : invalid position");
633: r0 = 0;
634: for ( i = 0, t = node; i < pos; i++, t = NEXT(t) ) {
635: NEXTNODE(r0,r);
636: BDY(r) = BDY(t);
637: }
638: NEXTNODE(r0,r);
639: iter = BDY(t); rest = NEXT(t);
640: if ( !iter ) {
1.16 ohara 641: *rp = bevalf_with_opts(f,node,option);
1.7 noro 642: return;
643: }
644: switch ( OID(iter) ) {
645: case O_VECT:
646: v = (VECT)iter; len = v->len; MKVECT(rv,len);
647: for ( i = 0; i < len; i++ ) {
648: BDY(r) = BDY(v)[i]; NEXT(r) = rest;
1.16 ohara 649: BDY(rv)[i] = bevalf_with_opts(f,r0,option);
1.7 noro 650: }
651: *rp = (Obj)rv;
652: break;
653: case O_MAT:
654: m = (MAT)iter; row = m->row; col = m->col; MKMAT(rm,row,col);
655: for ( i = 0; i < row; i++ )
656: for ( j = 0; j < col; j++ ) {
657: BDY(r) = BDY(m)[i][j]; NEXT(r) = rest;
1.16 ohara 658: BDY(rm)[i][j] = bevalf_with_opts(f,r0,option);
1.7 noro 659: }
660: *rp = (Obj)rm;
661: break;
662: case O_LIST:
663: n = BDY((LIST)iter);
664: for ( t0 = t = 0; n; n = NEXT(n) ) {
665: BDY(r) = BDY(n); NEXT(r) = rest;
1.16 ohara 666: NEXTNODE(t0,t); BDY(t) = bevalf_with_opts(f,r0,option);
1.7 noro 667: }
668: if ( t0 )
669: NEXT(t) = 0;
670: MKLIST(rl,t0);
671: *rp = (Obj)rl;
672: break;
673: default:
1.16 ohara 674: *rp = bevalf_with_opts(f,node,option);
1.7 noro 675: break;
676: }
1.1 noro 677: }
678:
1.13 ohara 679: /* An implementation of 'map' as builtin function. */
680: void Pmap(NODE arg,Obj *rp)
681: {
682: LIST args;
683: NODE node,rest,t0,t,n,r,r0;
684: P fpoly;
685: V fvar;
686: FUNC f;
687: VECT v,rv;
688: MAT m,rm;
689: LIST rl;
690: int len,row,col,i,j;
691: Obj iter;
692: pointer val;
1.16 ohara 693: NODE option;
694:
695: option = current_option;
1.13 ohara 696:
697: if ( argc(arg) < 2 )
698: error("mapat : too few arguments");
699:
700: fpoly = (P)ARG0(arg);
701: if ( !fpoly || OID(fpoly) != O_P )
702: error("map : invalid function specification");
703: fvar = VR(fpoly);
704: if ( fvar->attr != (pointer)V_SR || !(f=(FUNC)fvar->priv) )
705: error("map : invalid function specification");
706:
707: node = NEXT(arg);
708: len = length(node);
709: if ( 0 >= len )
710: error("evalmapf : invalid position");
711: r0 = 0;
712: NEXTNODE(r0,r);
1.17 noro 713: iter = BDY(node); rest = NEXT(node);
1.13 ohara 714: if ( !iter ) {
1.16 ohara 715: *rp = bevalf_with_opts(f,node,option);
1.13 ohara 716: return;
717: }
718: switch ( OID(iter) ) {
719: case O_VECT:
720: v = (VECT)iter; len = v->len; MKVECT(rv,len);
721: for ( i = 0; i < len; i++ ) {
722: BDY(r) = BDY(v)[i]; NEXT(r) = rest;
1.16 ohara 723: BDY(rv)[i] = bevalf_with_opts(f,r0,option);
1.13 ohara 724: }
725: *rp = (Obj)rv;
726: break;
727: case O_MAT:
728: m = (MAT)iter; row = m->row; col = m->col; MKMAT(rm,row,col);
729: for ( i = 0; i < row; i++ )
730: for ( j = 0; j < col; j++ ) {
731: BDY(r) = BDY(m)[i][j]; NEXT(r) = rest;
1.16 ohara 732: BDY(rm)[i][j] = bevalf_with_opts(f,r0,option);
1.13 ohara 733: }
734: *rp = (Obj)rm;
735: break;
736: case O_LIST:
737: n = BDY((LIST)iter);
738: for ( t0 = t = 0; n; n = NEXT(n) ) {
739: BDY(r) = BDY(n); NEXT(r) = rest;
1.16 ohara 740: NEXTNODE(t0,t); BDY(t) = bevalf_with_opts(f,r0,option);
1.13 ohara 741: }
742: if ( t0 )
743: NEXT(t) = 0;
744: MKLIST(rl,t0);
745: *rp = (Obj)rl;
746: break;
747: default:
1.16 ohara 748: *rp = bevalf_with_opts(f,node,option);
1.13 ohara 749: break;
750: }
751: }
752:
1.1 noro 753: void Pdeval(arg,rp)
754: NODE arg;
755: Obj *rp;
756: {
757: asir_assert(ARG0(arg),O_R,"deval");
758: devalr(CO,(Obj)ARG0(arg),rp);
759: }
760:
1.4 noro 761: void Peval_quote(arg,rp)
762: NODE arg;
763: Obj *rp;
764: {
1.11 noro 765: FNODE a;
766: QUOTE q;
1.12 noro 767: Obj f;
1.11 noro 768:
1.12 noro 769: f = (Obj)ARG0(arg);
770: if ( !f || OID(f) != O_QUOTE ) {
771: *rp = f;
772: return;
773: }
1.11 noro 774: if ( argc(arg) == 2 && ARG1(arg) ) {
775: a = partial_eval((FNODE)BDY((QUOTE)ARG0(arg)));
776: MKQUOTE(q,a);
777: *rp = (Obj)q;
778: } else
779: *rp = eval((FNODE)BDY((QUOTE)ARG0(arg)));
1.4 noro 780: }
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to pf.c CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM_contrib2 / asir2000 / builtin