Annotation of OpenXM/src/kan96xx/Kan/primitive.c, Revision 1.18
1.18 ! takayama 1: /* $OpenXM: OpenXM/src/kan96xx/Kan/primitive.c,v 1.17 2004/09/16 02:22:03 takayama Exp $ */
1.1 maekawa 2: /* primitive.c */
3: /* The functions in this module were in stackmachine.c */
4:
5: #include <stdio.h>
1.5 takayama 6: #include <signal.h>
1.1 maekawa 7: #include "datatype.h"
8: #include "stackm.h"
9: #include "extern.h"
10: #include "gradedset.h"
11: #include "kclass.h"
12: #include <sys/types.h>
13: #include <sys/times.h>
14:
15: int PrintDollar = 1; /* flag for printObject() */
16: int PrintComma = 1; /* flag for printObject() */
1.10 takayama 17: int InSendmsg2 = 0;
1.1 maekawa 18: #define OB_ARRAY_MAX (AGLIMIT+100)
19:
20: extern int GotoP;
21: extern char *GotoLabel;
22: extern int Osp;
23: extern int Sdp;
24: extern int ClassTypes[]; /* kclass.c */
25: extern struct context *PrimitiveContextp;
26: extern struct context *CurrentContextp;
27: extern struct dictionary *SystemDictionary;
1.8 takayama 28: extern int QuoteMode;
1.1 maekawa 29:
30: static char *operatorType(int i);
31:
32: static char *operatorType(type)
1.4 takayama 33: int type;
1.1 maekawa 34: { int i;
1.4 takayama 35: for (i=0; i<Sdp; i++) {
36: if (type == (SystemDictionary[i]).obj.lc.ival) {
37: return((SystemDictionary[i]).key);
38: }
39: }
40: return("Unknown operator");
1.1 maekawa 41: }
42:
1.16 takayama 43: #define evalEA(ob1) if (ob1.tag == SexecutableArray) {\
44: executeExecutableArray(ob1,(char *)NULL,0); ob1 = Kpop();}
45:
1.1 maekawa 46: /****** primitive functions *****************************************
47: the values must be greater than 1. 0 is used for special purposes.*/
48: #define Sadd 1
49: #define Ssub 2
50: #define Smult 3
51: #define Sset_up_ring 4
52: #define Soptions 6
53: #define Sgroebner 7
54: #define Sdef 8
55: #define Spop 9
56: #define Sput 10
57: #define Sprint 11
58: #define Spstack 12
59: #define Sshow_ring 13
60: #define Sshow_systemdictionary 15
61: #define Slength 16
62: #define Sfor 17
63: #define Sroll 18
64: #define Squit 19
65: #define Stest 20 /* this is used for test of new function*/
66: #define Sfileopen 23
67: #define Sclosefile 24
68: #define Sidiv 25
69: #define Sdup 26
70: #define Smap 27
71: #define Sreduction 28
72: #define Sreplace 29
73: #define SleftBrace 30 /* primitive [ */
74: #define SrightBrace 31 /* primitive ] */
75: #define Srun 32 /* run from a file */
76: #define Sloop 33
77: #define Saload 34
78: #define Sifelse 35
79: #define Sequal 36
80: #define Sexec 37
81: #define Sset 38
82: #define Sget 41
83: #define Scopy 43
84: #define Sindex 44
85: #define Ssystem 45
86: #define Sset_order_by_matrix 50
87: #define Sshow_user_dictionary 54
88: #define Selimination_order 55
89: #define Sswitch_function 58
90: #define Sprint_switch_status 59
91: #define Scat_n 62
92: #define Sless 63
93: #define Sgreater 64
94: #define Swritestring 66
95: #define Sset_timer 67
96: #define Sspol 68
97: #define Susage 69
98: #define Sto_records 70
99: #define Scoefficients 71
100: #define Ssystem_variable 72
101: #define Sdata_conversion 73
102: #define Sdegree 74
103: #define Sinit 75
104: #define Sload 76
105: #define Seval 77
106: #define Shomogenize 78
107: #define Sprincipal 79
108: #define Spushfile 80
109: #define Sdiv 81
110: #define Sgoto 82
111: #define Sextension 83
112: #define Snewstack 84
113: #define Ssetstack 85
114: #define Sstdstack 86
115: #define Slc 87
116: #define Src 88
117: #define Sgbext 89
118: #define Snewcontext 90
119: #define Ssetcontext 91
120: #define Ssupercontext 92
121: #define Ssendmsg 93
122: #define Serror 94
123: #define Smpzext 95
124: #define Ssendmsg2 96
125: #define Sprimmsg 97
126: #define Ssupmsg2 98
127: #define Scclass 99
128: #define Scoeff2 100
1.5 takayama 129: #define Stlimit 101
1.9 takayama 130: #define Soxshell 102
1.1 maekawa 131: /***********************************************/
132: void printObject(ob,nl,fp)
1.4 takayama 133: struct object ob;
134: int nl;
135: FILE *fp;
136: /* print the object on the top of the stack. */
1.1 maekawa 137: {
138:
139: int size;
140: int i;
141: struct tokens *ta;
142:
143: if (VerboseStack >= 2) {
144: /*fprintf(fp,"@@@");*/
145: switch (ob.tag) {
146: case 0:
147: fprintf(fp,"<null> "); /* null object */
148: break;
149: case Sinteger:
150: fprintf(fp,"<integer> ");
151: break;
152: case Sstring:
153: fprintf(fp,"<literal-string> ");
154: break;
155: case Soperator:
156: fprintf(fp,"<operator> ");
157: break;
158: case Sdollar:
159: fprintf(fp,"<string(dollar)> ");
160: break;
161: case SexecutableArray:
162: fprintf(fp,"<executable array> ");
163: break;
164: case Sarray:
165: fprintf(fp,"<array> ");
166: break;
167: case SleftBraceTag:
168: fprintf(fp,"<leftBraceTag> ");
169: break;
170: case SrightBraceTag:
171: fprintf(fp,"<rightBraceTag> ");
172: break;
173: case Spoly:
174: fprintf(fp,"<poly> ");
175: break;
176: case SarrayOfPOLY:
177: fprintf(fp,"<arrayOfPOLY> ");
178: break;
179: case SmatrixOfPOLY:
180: fprintf(fp,"<matrixOfPOLY> ");
181: break;
182: case Slist:
183: fprintf(fp,"<list> ");
184: break;
185: case Sfile:
186: fprintf(fp,"<file> ");
187: break;
188: case Sring:
189: fprintf(fp,"<ring> ");
190: break;
191: case SuniversalNumber:
192: fprintf(fp,"<universalNumber> ");
193: break;
194: case Sclass:
195: fprintf(fp,"<class> ");
196: break;
197: case SrationalFunction:
198: fprintf(fp,"<rationalFunction> ");
199: break;
200: case Sdouble:
201: fprintf(fp,"<double> ");
202: break;
203: default:
204: fprintf(fp,"<Unknown object tag. %d >",ob.tag);
205: break;
206: }
207: }
208: switch (ob.tag) {
209: case 0:
210: fprintf(fp,"%%[null]"); /* null object */
211: break;
212: case Sinteger:
213: fprintf(fp,"%d",ob.lc.ival);
214: break;
215: case Sstring:
216: fprintf(fp,"%s",ob.lc.str);
217: break;
218: case Soperator:
219: fprintf(fp,"%s %%[operator] ",operatorType(ob.lc.ival));
220: break;
221: case Sdollar:
222: if (PrintDollar == 2) {
223: fprintf(fp,"(%s)",ob.lc.str);
224: } else if (PrintDollar == 0 ) {
225: fprintf(fp,"%s",ob.lc.str);
226: } else {
227: fprintf(fp,"$%s$",ob.lc.str);
228: }
229: break;
230: case SexecutableArray:
231: size = ob.rc.ival;
232: ta = ob.lc.tokenArray;
233: fprintf(fp,"{ ");
234: for (i=0; i<size; i++) {
235: switch ((ta[i]).kind) {
236: case ID:
1.4 takayama 237: fprintf(fp,"<<ID>>%s ",(ta[i]).token);
238: break;
1.1 maekawa 239: case EXECUTABLE_STRING:
1.4 takayama 240: fprintf(fp,"<<EXECUTABLE_STRING>>{%s} ",(ta[i]).token);
241: break;
1.1 maekawa 242: case EXECUTABLE_ARRAY:
1.4 takayama 243: printObject((ta[i]).object,nl,fp);
244: break;
1.1 maekawa 245: case DOLLAR:
1.4 takayama 246: fprintf(fp,"<<STRING(DOLLAR)>>%s ",(ta[i]).token);
247: break;
1.1 maekawa 248: default:
1.4 takayama 249: fprintf(fp,"Unknown token type\n");
250: break;
1.1 maekawa 251: }
252: }
253: fprintf(fp," }");
254: break;
255: case Sarray:
256: printObjectArray(ob,0,fp);
257: break;
258: case SleftBraceTag:
259: fprintf(fp,"[ ");
260: break;
261: case SrightBraceTag:
262: fprintf(fp,"] ");
263: break;
264: case Spoly:
265: fprintf(fp,"%s",KPOLYToString(ob.lc.poly));
266: break;
267: case SarrayOfPOLY:
268: fprintf(fp,"Sorry! The object arrayOfPOLY cannot be printed.");
269: break;
270: case SmatrixOfPOLY:
271: fprintf(fp,"Sorry! The object matrixOfPOLY cannot be printed.");
272: break;
273: case Slist:
274: printObjectList(&ob);
275: break;
276: case Sfile:
277: fprintf(fp,"Name=%s, FILE *=%x ",ob.lc.str,(int) ob.rc.file);
278: break;
279: case Sring:
280: fprintf(fp,"Ring."); KshowRing(KopRingp(ob));
281: break;
282: case SuniversalNumber:
283: fprintf(fp,"%s",coeffToString(ob.lc.universalNumber));
284: break;
285: case SrationalFunction:
286: fprintf(fp,"("); printObject(*(Knumerator(ob)),nl,fp);
287: fprintf(fp,")/(");printObject(*(Kdenominator(ob)),nl,fp);
288: fprintf(fp,")");
289: break;
290: case Sclass:
291: /* fprintf(fp,"Class: "); */
292: fprintClass(fp,ob);
293: break;
294: case Sdouble:
295: fprintf(fp,"%f",KopDouble(ob));
296: break;
297: default:
298: fprintf(fp,"[Unknown object tag.]");
299: break;
300: }
301: if (nl) fprintf(fp,"\n");
302: }
303:
304: void printObjectArray(ob,nl,fp)
1.4 takayama 305: struct object ob;
306: int nl;
307: FILE *fp;
1.1 maekawa 308: {
309: int size;
310: int i;
1.2 takayama 311: extern char *LeftBracket, *RightBracket;
1.1 maekawa 312: size = ob.lc.ival;
1.2 takayama 313: fprintf(fp,"%s ",LeftBracket);
1.1 maekawa 314: for (i=0; i<size; i++) {
315: if (PrintComma && (i != 0)) {
316: fprintf(fp," , ");
317: }else{
318: fprintf(fp," ");
319: }
320: printObject((ob.rc.op)[i],0,fp);
321: }
1.2 takayama 322: fprintf(fp," %s ",RightBracket);
1.1 maekawa 323: if (nl) fprintf(fp,"\n");
324: }
325:
326: void KdefinePrimitiveFunctions() {
327: /* It is recommended to sort the follows for performance */
328: putPrimitiveFunction("mul",Smult);
329: putPrimitiveFunction("add",Sadd);
330: putPrimitiveFunction("sub",Ssub);
331: putPrimitiveFunction("lt",Sless);
332: putPrimitiveFunction("set",Sset);
333: putPrimitiveFunction("eq",Sequal);
334: putPrimitiveFunction("gt",Sgreater);
335: putPrimitiveFunction("QUIT",Squit);
336: putPrimitiveFunction("[",SleftBrace);
337: putPrimitiveFunction("]",SrightBrace);
338: putPrimitiveFunction("bye",Squit);
339: putPrimitiveFunction("length",Slength);
340: putPrimitiveFunction("for",Sfor);
341: putPrimitiveFunction("roll",Sroll);
342: putPrimitiveFunction("cat_n",Scat_n);
343: putPrimitiveFunction("coefficients",Scoefficients);
344: putPrimitiveFunction("copy",Scopy);
345: putPrimitiveFunction("data_conversion",Sdata_conversion);
346: putPrimitiveFunction("aload",Saload);
347: putPrimitiveFunction("def",Sdef);
348: putPrimitiveFunction("degree",Sdegree);
349: putPrimitiveFunction("elimination_order",Selimination_order);
350: putPrimitiveFunction("exec",Sexec);
351: putPrimitiveFunction("exit",Squit);
352: putPrimitiveFunction("get",Sget);
353: putPrimitiveFunction("groebner",Sgroebner);
354: putPrimitiveFunction("ifelse",Sifelse);
355: putPrimitiveFunction("index",Sindex);
356: putPrimitiveFunction("dup",Sdup);
357: putPrimitiveFunction("init",Sinit);
358: putPrimitiveFunction("loop",Sloop);
359: putPrimitiveFunction("options",Soptions);
360: putPrimitiveFunction("pop",Spop);
361: putPrimitiveFunction("put",Sput);
362: putPrimitiveFunction("print",Sprint);
363: putPrimitiveFunction("pstack",Spstack);
364: putPrimitiveFunction("print_switch_status",Sprint_switch_status);
365: putPrimitiveFunction("quit",Squit);
366: putPrimitiveFunction("file",Sfileopen);
367: putPrimitiveFunction("closefile",Sclosefile);
368: putPrimitiveFunction("idiv",Sidiv);
369: putPrimitiveFunction("reduction",Sreduction);
370: putPrimitiveFunction("replace",Sreplace);
371: putPrimitiveFunction("run",Srun);
372: putPrimitiveFunction("set_order_by_matrix",Sset_order_by_matrix);
373: putPrimitiveFunction("set_timer",Sset_timer);
374: putPrimitiveFunction("set_up_ring@",Sset_up_ring);
375: putPrimitiveFunction("show_ring",Sshow_ring);
376: putPrimitiveFunction("show_systemdictionary",Sshow_systemdictionary);
377: putPrimitiveFunction("show_user_dictionary",Sshow_user_dictionary);
378: putPrimitiveFunction("spol",Sspol);
379: putPrimitiveFunction("switch_function",Sswitch_function);
380: putPrimitiveFunction("system",Ssystem);
381: putPrimitiveFunction("system_variable",Ssystem_variable);
382: putPrimitiveFunction("test",Stest);
1.5 takayama 383: putPrimitiveFunction("tlimit",Stlimit);
1.9 takayama 384: putPrimitiveFunction("oxshell",Soxshell);
1.1 maekawa 385: putPrimitiveFunction("map",Smap);
386: putPrimitiveFunction("to_records",Sto_records);
387: putPrimitiveFunction("Usage",Susage);
388: putPrimitiveFunction("load",Sload);
389: putPrimitiveFunction("writestring",Swritestring);
390: putPrimitiveFunction("eval",Seval);
391: putPrimitiveFunction("homogenize",Shomogenize);
392: putPrimitiveFunction("principal",Sprincipal);
393: putPrimitiveFunction("pushfile",Spushfile);
394: putPrimitiveFunction("div",Sdiv);
395: putPrimitiveFunction("goto",Sgoto);
396: putPrimitiveFunction("extension",Sextension);
397: putPrimitiveFunction("newstack",Snewstack);
398: putPrimitiveFunction("setstack",Ssetstack);
399: putPrimitiveFunction("stdstack",Sstdstack);
400: putPrimitiveFunction("lc",Slc);
401: putPrimitiveFunction("rc",Src);
402: putPrimitiveFunction("gbext",Sgbext);
403: putPrimitiveFunction("newcontext",Snewcontext);
404: putPrimitiveFunction("setcontext",Ssetcontext);
405: putPrimitiveFunction("supercontext",Ssupercontext);
406: putPrimitiveFunction("sendmsg",Ssendmsg);
407: putPrimitiveFunction("error",Serror);
408: putPrimitiveFunction("mpzext",Smpzext);
409: putPrimitiveFunction("sendmsg2",Ssendmsg2);
410: putPrimitiveFunction("primmsg",Sprimmsg);
411: putPrimitiveFunction("supmsg2",Ssupmsg2);
412: putPrimitiveFunction("cclass",Scclass);
413: putPrimitiveFunction("coeff",Scoeff2);
414: }
415:
416: int executePrimitive(ob)
1.4 takayama 417: struct object ob;
1.1 maekawa 418: {
419: struct object ob1;
420: struct object ob2;
421: struct object ob3;
422: struct object ob4;
423: struct object ob5;
424: struct object rob;
425: struct object obArray[OB_ARRAY_MAX];
426: struct object obArray2[OB_ARRAY_MAX];
427: int size;
428: int i,j,k,n;
429: int status;
1.13 takayama 430: int infixOn;
431: struct tokens infixToken;
1.1 maekawa 432: struct tokens *tokenArray;
433: struct tokens token;
434: FILE *fp;
435: char *fname;
436: int rank;
437: struct object oMat;
438: static int timerStart = 1;
439: static struct tms before, after;
440: static time_t before_real, after_real;
441: struct object oInput;
442: char *str;
443: int ccflag = 0;
444: extern int KeepInput;
445: extern int History;
446: extern struct ring *CurrentRingp;
447: extern TimerOn;
1.3 takayama 448: extern SecureMode;
1.18 ! takayama 449: extern int RestrictedMode;
1.1 maekawa 450:
1.13 takayama 451: infixOn = 0;
452:
1.1 maekawa 453: if (DebugStack >= 2) {
454: fprintf(Fstack,"In execute %d\n",ob.lc.ival); printOperandStack();
1.18 ! takayama 455: }
! 456:
! 457: if (RestrictedMode) {
! 458: switch(ob.lc.ival) {
! 459: case SleftBrace:
! 460: case SrightBrace:
! 461: case Sexec:
! 462: break;
! 463: default:
! 464: fprintf(stderr,"primitive No = %d : ", ob.lc.ival);
! 465: errorStackmachine("You cannot use this primitive in the RestrictedMode.\n");
! 466: }
1.1 maekawa 467: }
468:
469: if (GotoP) return(0);
470: switch (ob.lc.ival) {
471: /* Postscript primitives :stack */
472: case Sgoto:
473: ob1 = Kpop();
474: if (ob1.tag != Sstring) {
475: if (DebugStack>=2) printObject(ob1,0,Fstack);
476: errorStackmachine("Usage:goto");
477: }
478: GotoLabel = ob1.lc.str;
479: GotoP = 1;
480: break;
481: case Spop:
482: ob1 = Kpop();
483: break;
484:
485: case Sdup:
486: ob1 = Kpop();
487: Kpush(ob1); Kpush(ob1);
488: break;
489: case Scopy: /* copy values. cf. dup */
490: ob1 = Kpop();
491: switch(ob1.tag) {
492: case Sinteger: break;
493: default: errorStackmachine("Usage:copy");
494: }
495: size = ob1.lc.ival;
496: k = 0;
497: for (i=size-1; i>=0; i--) {
498: ob2 = peek(i+k);
499: switch(ob2.tag) {
500: case Sdollar: /* copy by value */
1.4 takayama 501: str = (char *)sGC_malloc(strlen(ob2.lc.str)+3);
502: if (str == (char *)NULL) errorStackmachine("No memory (copy)");
503: strcpy(str,ob2.lc.str);
504: Kpush(KpoString(str));
505: break;
1.1 maekawa 506: case Spoly:
1.4 takayama 507: errorStackmachine("no pCopy (copy)");
508: break;
1.1 maekawa 509: case Sarray:
1.4 takayama 510: n = ob2.lc.ival;
511: ob3 = newObjectArray(n);
512: for (j=0; j<n; j++) {
513: putoa(ob3,j,getoa(ob2,j));
514: }
515: Kpush(ob3);
516: break;
1.1 maekawa 517: default:
1.4 takayama 518: Kpush(ob2);
519: break;
1.1 maekawa 520: }
521: k++;
522: }
523: break;
524: case Sroll:
525: ob1 = Kpop();
526: ob2 = Kpop();
527: switch(ob1.tag) {
528: case Sinteger:
529: j = ob1.lc.ival;
530: break;
531: default: errorStackmachine("Usage:roll");
532: }
533: switch(ob2.tag) {
534: case Sinteger:
535: n = ob2.lc.ival;
536: break;
537: default: errorStackmachine("Usage:roll");
538: }
539: for (i=0; i<n; i++) {
540: if (i < OB_ARRAY_MAX) {
1.4 takayama 541: obArray[i] = Kpop();
1.1 maekawa 542: }else{
1.4 takayama 543: errorStackmachine("exceeded OB_ARRAY_MAX (roll)\n");
1.1 maekawa 544: }
545: }
546: for (i=0; i<n; i++) {
547: k = (j-1)%n;
548: k = (k>=0?k: k+n);
549: Kpush(obArray[k]);
550: j--;
551: }
552: break;
553: case Spstack:
554: printOperandStack();
555: break;
556:
557: /* Postscript primitives :arithmetic */
558: case Sadd:
1.16 takayama 559: ob1 = Kpop();
1.1 maekawa 560: ob2 = Kpop();
1.16 takayama 561: evalEA(ob1); evalEA(ob2);
1.1 maekawa 562: rob = KooAdd(ob1,ob2);
563: Kpush(rob);
564: break;
565: case Ssub:
566: ob2 = Kpop();
567: ob1 = Kpop();
1.16 takayama 568: evalEA(ob1); evalEA(ob2);
1.1 maekawa 569: rob = KooSub(ob1,ob2);
570: Kpush(rob);
571: break;
572: case Smult:
573: ob2 = Kpop();
574: ob1 = Kpop();
1.16 takayama 575: evalEA(ob1); evalEA(ob2);
1.1 maekawa 576: rob = KooMult(ob1,ob2);
577: Kpush(rob);
578: break;
579: case Sidiv:
580: ob2 = Kpop(); ob1 = Kpop();
1.16 takayama 581: evalEA(ob1); evalEA(ob2);
1.1 maekawa 582: rob = KooDiv(ob1,ob2);
583: Kpush(rob);
584: break;
585:
586: case Sdiv:
587: ob2 = Kpop(); ob1 = Kpop();
1.16 takayama 588: evalEA(ob1); evalEA(ob2);
1.1 maekawa 589: rob = KooDiv2(ob1,ob2);
590: Kpush(rob);
591: break;
592:
593: /* Postscript primitives :array */
594: case SleftBrace:
595: rob.tag = SleftBraceTag;
596: Kpush(rob);
597: break;
598:
599: case SrightBrace:
600: size = 0;
601: ob1 = peek(size);
602: while (!(Osp-size-1 < 0)) { /* while the stack is not underflow */
603: if (ob1.tag == SleftBraceTag) {
1.4 takayama 604: rob = newObjectArray(size);
605: for (i=0; i<size; i++) {
606: (rob.rc.op)[i] = peek(size-1-i);
607: }
608: for (i=0; i<size+1; i++) {
609: Kpop();
610: }
611: break;
1.1 maekawa 612: }
613: size++;
614: ob1 = peek(size);
615: }
616: Kpush(rob);
617: break;
618:
619: case Sget:
620: /* [a_0 ... a_{n-1}] i get a_i */
621: /* ob2 ob1 get */
622: ob1 = Kpop();
623: ob2 = Kpop();
1.12 takayama 624: Kpush(Kget(ob2,ob1));
1.1 maekawa 625: break;
626:
627: case Sput:
628: /* [a_0 ... a_{n-1}] index any put */
629: /* ob3 ob2 ob1 put */
630: /* Or; [[a_00 ....] [a_10 ....] ....] [1 0] any put. MultiIndex. */
631: ob1 = Kpop(); ob2 = Kpop(); ob3 = Kpop();
632: switch(ob2.tag) {
1.17 takayama 633: case SuniversalNumber:
634: ob2 = Kto_int32(ob2); /* do not break and go to Sinteger */
1.1 maekawa 635: case Sinteger:
636: switch(ob3.tag) {
637: case Sarray:
1.4 takayama 638: i = ob2.lc.ival;
639: size = getoaSize(ob3);
640: if ((0 <= i) && (i<size)) {
641: getoa(ob3,i) = ob1;
642: }else{
643: errorStackmachine("Index is out of bound. (put)\n");
644: }
645: break;
1.1 maekawa 646: case Sdollar:
1.4 takayama 647: i = ob2.lc.ival;
648: size = strlen(ob3.lc.str);
649: if ((0 <= i) && (i<size)) {
650: if (ob1.tag == Sdollar) {
651: (ob3.lc.str)[i] = (ob1.lc.str)[0];
652: }else{
653: (ob3.lc.str)[i] = ob1.lc.ival;
654: }
655: }else{
656: errorStackmachine("Index is out of bound. (put)\n");
657: }
658: break;
1.1 maekawa 659: default: errorStackmachine("Usage:put");
660: }
661: break;
662: case Sarray:
663: ob5 = ob3;
664: n = getoaSize(ob2);
665: for (i=0; i<n; i++) {
1.4 takayama 666: if (ob5.tag != Sarray)
667: errorStackmachine("Object pointed by the multi-index is not array (put)\n");
668: ob4 = getoa(ob2,i);
1.17 takayama 669: if (ob4.tag == SuniversalNumber) ob4 = Kto_int32(ob4);
1.4 takayama 670: if (ob4.tag != Sinteger)
671: errorStackmachine("Index has to be an integer. (put)\n");
672: k = ob4.lc.ival;
673: size = getoaSize(ob5);
674: if ((0 <= k) && (k<size)) {
675: if (i == n-1) {
676: getoa(ob5,k) = ob1;
677: }else{
678: ob5 = getoa(ob5,k);
679: }
680: }else{
681: errorStackmachine("Index is out of bound for the multi-index. (put)\n");
682: }
1.1 maekawa 683: }
684: break;
685: default: errorStackmachine("Usage:put");
686: }
687: break;
688:
689: case Sindex:
690: ob1 = Kpop();
691: switch(ob1.tag) {
692: case Sinteger: break;
693: default: errorStackmachine("Usage:index");
694: }
695: size = ob1.lc.ival;
696: Kpush(peek(size-1));
697: break;
698:
699: case Saload:
700: /* [a1 a2 ... an] aload a1 a2 ... an [a1 ... an] */
701: ob1 = Kpop();
702: switch(ob1.tag) {
703: case Sarray: break;
704: default:
705: errorStackmachine("Usage:aload");
706: }
707: size = getoaSize(ob1);
708: for (i=0; i<size; i++) {
709: Kpush(getoa(ob1,i));
710: }
711: Kpush(ob1);
712:
713: break;
714:
715: case Slength:
716: /* [a_0 ... a_{n-1}] length n */
717: /* ob1 length rob */
718: ob1 = Kpop();
719: switch(ob1.tag) {
720: case Sarray:
721: size = getoaSize(ob1);
722: Kpush(KpoInteger(size));
723: break;
724: case Sdollar:
725: Kpush(KpoInteger(strlen(ob1.lc.str)));
726: break;
727: case Spoly:
728: Kpush(KpoInteger(KpolyLength(KopPOLY(ob1))));
729: break;
730: default: errorStackmachine("Usage:length");
731: }
732: break;
733:
734: /* Postscript primitives :relation */
735: case Sequal:
736: /* obj1 obj2 == bool */
737: ob2 = Kpop();
738: ob1 = Kpop();
739: if(KooEqualQ(ob1,ob2)) {
740: Kpush(KpoInteger(1));
741: }else{
742: Kpush(KpoInteger(0));
743: }
744: break;
745:
746: case Sless:
747: /* obj1 obj2 < bool */
748: ob2 = Kpop();
749: ob1 = Kpop();
750: Kpush(KooLess(ob1,ob2));
751: break;
752:
753: case Sgreater:
754: /* obj1 obj2 < bool */
755: ob2 = Kpop();
756: ob1 = Kpop();
757: Kpush(KooGreater(ob1,ob2));
758: break;
759:
760:
761: /* Postscript primitives :controle */
762: case Sloop:
763: /* { .... exit .....} loop */
764: ob1 = Kpop();
765: switch(ob1.tag) {
766: case SexecutableArray: break;
767: default:
768: errorStackmachine("Usage:loop");
769: break;
770: }
771: while (1) {
1.15 takayama 772: status = executeExecutableArray(ob1,(char *)NULL,1);
1.13 takayama 773: if ((status & STATUS_BREAK) || GotoP) break;
1.1 maekawa 774: /* here, do not return 1. Do not propagate exit signal outside of the
1.4 takayama 775: loop. */
1.1 maekawa 776: }
777: break;
778:
779: case Sfor:
780: /* init inc limit { } for */
781: /* ob4 ob3 ob2 ob1 */
782: ob1 =Kpop(); ob2 = Kpop(); ob3 = Kpop(); ob4 = Kpop();
783: switch(ob1.tag) {
784: case SexecutableArray: break;
785: default: errorStackmachine("Usage:for");
786: }
787: switch(ob2.tag) {
788: case Sinteger: break;
789: default:
790: errorStackmachine("Usage:for The 3rd argument must be integer.");
791: }
792: switch(ob3.tag) {
793: case Sinteger: break;
794: default: errorStackmachine("Usage:for The 2nd argument must be integer.");
795: }
796: switch(ob4.tag) {
797: case Sinteger: break;
798: default: errorStackmachine("Usage:for The 1st argument must be integer.");
799: }
800: {
801: int i,lim,inc,j;
802: i = ob4.lc.ival;
803: lim = ob2.lc.ival;
804: inc = ob3.lc.ival;
805: if (inc > 0) {
806: /*
1.4 takayama 807: if (lim < i) errorStackmachine("The initial value must not be greater than limit value (for).\n");
1.1 maekawa 808: */
1.4 takayama 809: for ( ; i<=lim; i += inc) {
810: Kpush(KpoInteger(i));
1.15 takayama 811: status = executeExecutableArray(ob1,(char *)NULL,1);
1.14 takayama 812: if ((status & STATUS_BREAK) || GotoP) goto xyz;
1.13 takayama 813: }
1.1 maekawa 814: }else{
815: /*
1.4 takayama 816: if (lim > i) errorStackmachine("The initial value must not be less than limit value (for).\n");
1.1 maekawa 817: */
1.4 takayama 818: for ( ; i>=lim; i += inc) {
819: Kpush(KpoInteger(i));
1.15 takayama 820: status = executeExecutableArray(ob1,(char *)NULL,1);
1.14 takayama 821: if ((status & STATUS_BREAK) || GotoP) goto xyz;
1.4 takayama 822: }
1.1 maekawa 823: }
1.4 takayama 824: xyz: ;
1.1 maekawa 825: }
826: break;
827:
828: case Smap:
829: ob2 = Kpop(); ob1 = Kpop();
830: switch(ob1.tag) {
831: case Sarray: break;
832: default:
833: errorStackmachine("Usage:map The 1st argument must be an array.");
834: break;
835: }
836: switch(ob2.tag) {
837: case SexecutableArray: break;
838: default:
839: errorStackmachine("Usage:map The 2nd argument must be an executable array.");
840: break;
841: }
842: { int osize,size;
1.4 takayama 843: int i,j;
844: osize = getoaSize(ob1);
1.1 maekawa 845:
1.4 takayama 846: /*KSexecuteString("[");*/
847: rob.tag = SleftBraceTag;
848: Kpush(rob);
1.1 maekawa 849:
1.4 takayama 850: for (i=0; i<osize; i++) {
851: Kpush(getoa(ob1,i));
1.15 takayama 852: status = executeExecutableArray(ob2,(char *)NULL,0);
853: if (status & STATUS_BREAK) goto foor;
1.4 takayama 854: }
1.1 maekawa 855: foor: ;
1.4 takayama 856: /*KSexecuteString("]");*/
857: {
858: size = 0;
859: ob1 = peek(size);
860: while (!(Osp-size-1 < 0)) { /* while the stack is not underflow */
861: if (ob1.tag == SleftBraceTag) {
862: rob = newObjectArray(size);
863: for (i=0; i<size; i++) {
864: (rob.rc.op)[i] = peek(size-1-i);
865: }
866: for (i=0; i<size+1; i++) {
867: Kpop();
868: }
869: break;
870: }
871: size++;
872: ob1 = peek(size);
1.1 maekawa 873: }
1.4 takayama 874: Kpush(rob);
875: }
1.1 maekawa 876: }
877: break;
878:
879:
880: case Sifelse:
881: /* bool { } { } ifelse */
882: ob1 = Kpop();
883: ob2 = Kpop();
884: ob3 = Kpop();
885: switch (ob1.tag) {
886: case SexecutableArray: break;
887: default: errorStackmachine("Usage:ifelse");
888: }
889: switch (ob2.tag) {
890: case SexecutableArray: break;
891: default: errorStackmachine("Usage:ifelse");
892: }
893: switch (ob3.tag) {
894: case Sinteger: break;
895: default: errorStackmachine("Usage:ifelse");
896: }
897: if (ob3.lc.ival) {
898: /* execute ob2 */
899: ob1 = ob2;
900: }
901: /* execute ob1 */
1.15 takayama 902: status = executeExecutableArray(ob1,(char *)NULL,0);
1.14 takayama 903: if (status & STATUS_BREAK) return(status);
1.13 takayama 904:
1.1 maekawa 905: break;
906:
907: case Sexec:
908: /* { .........} exec */
909: ob1 = Kpop();
910: switch(ob1.tag) {
911: case SexecutableArray: break;
912: default: errorStackmachine("Usage:exec");
913: }
1.15 takayama 914: status = executeExecutableArray(ob1,(char *)NULL,0);
1.1 maekawa 915: break;
916:
1.4 takayama 917: /* Postscript primitives :dictionary */
1.1 maekawa 918: case Sdef:
919: ob2 = Kpop();
920: ob1 = Kpop();
921: /* type check */
922: switch(ob1.tag) {
923: case Sstring: break;
924: default:
925: errorStackmachine("Usage:def");
926: break;
927: }
928: k=putUserDictionary(ob1.lc.str,(ob1.rc.op->lc).ival,
1.4 takayama 929: (ob1.rc.op->rc).ival,ob2,
930: CurrentContextp->userDictionary);
1.1 maekawa 931: if (k < 0) {
932: str = (char *)sGC_malloc(sizeof(char)*(strlen(ob1.lc.str) + 256));
933: if (str == (char *)NULL) {
1.4 takayama 934: errorStackmachine("No memory.\n");
1.1 maekawa 935: }
936: if (k == -PROTECT) {
1.4 takayama 937: sprintf(str,"You rewrited the protected symbol %s.\n",ob1.lc.str);
938: /* cf. [(chattr) num sym] extension */
939: warningStackmachine(str);
1.1 maekawa 940: } else if (k == -ABSOLUTE_PROTECT) {
1.4 takayama 941: sprintf(str,"You cannot rewrite the protected symbol %s.\n",ob1.lc.str);
942: errorStackmachine(str);
1.1 maekawa 943: } else errorStackmachine("Unknown return value of putUserDictioanry\n");
944: }
945: break;
946:
947: case Sload:
948: ob1 = Kpop();
949: switch(ob1.tag) {
950: case Sstring: break;
951: default: errorStackmachine("Usage:load");
952: }
953: ob1 = findUserDictionary(ob1.lc.str,
1.4 takayama 954: (ob1.rc.op->lc).ival,
955: (ob1.rc.op->rc).ival,
956: CurrentContextp);
1.1 maekawa 957: if (ob1.tag == -1) Kpush(NullObject);
958: else Kpush(ob1);
959:
960: break;
961:
962: case Sset:
963: ob1 = Kpop();
964: ob2 = Kpop();
965: switch(ob1.tag) {
966: case Sstring: break;
967: default: errorStackmachine("Usage:set");
968: }
969: k= putUserDictionary(ob1.lc.str,(ob1.rc.op->lc).ival,
1.4 takayama 970: (ob1.rc.op->rc).ival,ob2,
971: CurrentContextp->userDictionary);
1.1 maekawa 972: if (k < 0) {
973: str = (char *)sGC_malloc(sizeof(char)*(strlen(ob1.lc.str) + 256));
974: if (str == (char *)NULL) {
1.4 takayama 975: errorStackmachine("No memory.\n");
1.1 maekawa 976: }
977: if (k == -PROTECT) {
1.4 takayama 978: sprintf(str,"You rewrited the protected symbol %s. \n",ob1.lc.str);
979: warningStackmachine(str);
1.1 maekawa 980: } else if (k == -ABSOLUTE_PROTECT) {
1.4 takayama 981: sprintf(str,"You cannot rewrite the protected symbol %s.\n",ob1.lc.str);
982: errorStackmachine(str);
1.1 maekawa 983: } else errorStackmachine("Unknown return value of putUserDictioanry\n");
984: }
985: break;
986:
987:
988: case Sshow_systemdictionary:
989: fprintf(Fstack,"------------- system dictionary -------------------\n");
990: showSystemDictionary(0);
991: break;
992:
993: case Sshow_user_dictionary:
994: showUserDictionary();
995: break;
996:
997:
998:
999: /* Postscript primitives : convert */
1000: case Sdata_conversion:
1001: ob2 = Kpop();
1002: ob1 = Kpop();
1003: switch(ob2.tag) {
1004: case Sdollar:
1005: if (ob1.tag != Sclass) {
1.4 takayama 1006: rob = KdataConversion(ob1,ob2.lc.str);
1.1 maekawa 1007: }else{
1.4 takayama 1008: rob = KclassDataConversion(ob1,ob2);
1.1 maekawa 1009: }
1010: break;
1011: case Sarray:
1012: rob = KclassDataConversion(ob1,ob2); break;
1013: default: errorStackmachine("Usage:data_conversion");
1014: }
1015: Kpush(rob);
1016: break;
1017:
1018:
1019: /* Postscript ptimitives :file */
1020: case Srun:
1021: ob1 = Kpop();
1022: switch(ob1.tag) {
1023: case Sdollar: break;
1024: case Sstring: break;
1025: default:
1026: errorStackmachine("Usage:run");
1027: break;
1028: }
1029: getokenSM(OPEN,ob1.lc.str); /* open the file, $filename$ run */
1030: break;
1031:
1032: case Sprint:
1033: ob1 = Kpop();
1034: printObject(ob1,0,Fstack);
1035: break;
1036:
1037: case Sfileopen: /* filename mode file descripter */
1.4 takayama 1038: /* ob2 ob1 */
1.1 maekawa 1039: ob1 = Kpop();
1040: ob2 = Kpop();
1.4 takayama 1041: if (SecureMode) errorStackmachine("Security violation: you cannot open a file.");
1.1 maekawa 1042: switch(ob1.tag) {
1043: case Sdollar: break;
1044: default: errorStackmachine("Usage:file");
1045: }
1046: switch(ob2.tag) {
1047: case Sinteger: break;
1048: case Sdollar: break;
1049: default:errorStackmachine("Usage:file");
1050: }
1051: rob = NullObject;
1052: if (ob2.tag == Sdollar) {
1053: if (strcmp(ob2.lc.str,"%stdin") == 0) {
1.4 takayama 1054: rob.tag = Sfile; rob.lc.str="%stdin"; rob.rc.file = stdin;
1.1 maekawa 1055: }else if (strcmp(ob2.lc.str,"%stdout") == 0) {
1.4 takayama 1056: rob.tag = Sfile; rob.lc.str="%stdout"; rob.rc.file = stdout;
1.1 maekawa 1057: }else if (strcmp(ob2.lc.str,"%stderr") == 0) {
1.4 takayama 1058: rob.tag = Sfile; rob.lc.str="%stderr"; rob.rc.file = stderr;
1.1 maekawa 1059: }else if ( (rob.rc.file = fopen(ob2.lc.str,ob1.lc.str)) != (FILE *)NULL) {
1.4 takayama 1060: rob.tag = Sfile; rob.lc.str = ob2.lc.str;
1.1 maekawa 1061: }else {
1.4 takayama 1062: errorStackmachine("I cannot open the file.");
1.1 maekawa 1063: }
1064: }else {
1065: rob.rc.file = fdopen(ob2.lc.ival,ob1.lc.str);
1066: if ( rob.rc.file != (FILE *)NULL) {
1.4 takayama 1067: rob.tag = Sfile; rob.lc.ival = ob2.lc.ival;
1.1 maekawa 1068: }else{
1.4 takayama 1069: errorStackmachine("I cannot fdopen the given fd.");
1.1 maekawa 1070: }
1071: }
1072:
1073: Kpush(rob);
1074: break;
1075:
1076:
1077: case Swritestring:
1078: /* file string writestring
1079: ob2 ob1
1080: */
1081: ob1 = Kpop();
1082: ob2 = Kpop();
1083: switch(ob2.tag) {
1084: case Sfile: break;
1085: default: errorStackmachine("Usage:writestring");
1086: }
1087: switch(ob1.tag) {
1088: case Sdollar: break;
1089: default: errorStackmachine("Usage:writestring");
1090: }
1091: fprintf(ob2.rc.file,"%s",ob1.lc.str);
1092: break;
1093:
1094: case Sclosefile:
1095: ob1 = Kpop();
1096: switch(ob1.tag) {
1097: case Sfile: break;
1098: default: errorStackmachine("Usage:closefile");
1099: }
1100: if (fclose(ob1.rc.file) == EOF) {
1101: errorStackmachine("I couldn't close the file.\n");
1102: }
1103: break;
1104:
1105: case Spushfile: /* filename pushfile string */
1.4 takayama 1106: /* ob2 */
1.1 maekawa 1107: ob2 = Kpop();
1108: switch(ob2.tag) {
1109: case Sdollar: break;
1110: default:errorStackmachine("Usage:pushfile");
1111: }
1112: rob = NullObject;
1113: if (strcmp(ob2.lc.str,"%stdin") == 0) {
1114: ob1.tag = Sfile; ob1.lc.str="%stdin"; ob1.rc.file = stdin;
1115: }else if (strcmp(ob2.lc.str,"%stdout") == 0) {
1116: ob1.tag = Sfile; ob1.lc.str="%stdout"; ob1.rc.file = stdout;
1117: }else if (strcmp(ob2.lc.str,"%stderr") == 0) {
1118: ob1.tag = Sfile; ob1.lc.str="%stderr"; ob1.rc.file = stderr;
1119: }else if ( (ob1.rc.file = fopen(ob2.lc.str,"r")) != (FILE *)NULL) {
1120: ob1.tag = Sfile; ob1.lc.str = ob2.lc.str;
1121: }else {
1122: if (ob1.rc.file == (FILE *)NULL) {
1.4 takayama 1123: char fname2[1024];
1124: strcpy(fname2,getLOAD_SM1_PATH());
1125: strcat(fname2,ob2.lc.str);
1126: ob1.rc.file = fopen(fname2,"r");
1127: if (ob1.rc.file == (FILE *)NULL) {
1128: strcpy(fname2,LOAD_SM1_PATH);
1129: strcat(fname2,ob2.lc.str);
1130: ob1.rc.file = fopen(fname2,"r");
1131: if (ob1.rc.file == (FILE *)NULL) {
1132: fprintf(stderr,"Warning: Cannot open the file <<%s>> for loading in the current directory nor the library directories %s and %s.\n",ob2.lc.str,getLOAD_SM1_PATH(),LOAD_SM1_PATH);
1133: errorStackmachine("I cannot open the file.");
1134: }
1135: }
1.1 maekawa 1136: }
1137: }
1138:
1139: /* read the strings
1.4 takayama 1140: */
1.1 maekawa 1141: n = 256; j=0;
1142: rob.tag = Sdollar; rob.lc.str = (char *) sGC_malloc(sizeof(char)*n);
1143: if (rob.lc.str == (char *)NULL) errorStackmachine("No more memory.");
1144: while ((i = fgetc(ob1.rc.file)) != EOF) {
1145: if (j >= n-1) {
1.4 takayama 1146: n = 2*n;
1147: if (n <= 0) errorStackmachine("Too large file to put on the stack.");
1.1 maekawa 1148: str = (char *)sGC_malloc(sizeof(char)*n);
1.4 takayama 1149: if (str == (char *)NULL) errorStackmachine("No more memory.");
1150: for (k=0; k< n/2; k++) str[k] = (rob.lc.str)[k];
1151: rob.lc.str = str;
1.1 maekawa 1152: }
1153: (rob.lc.str)[j] = i; (rob.lc.str)[j+1] = '\0';
1154: j++;
1155: }
1156:
1157: fclose(ob1.rc.file);
1158: Kpush(rob);
1159: break;
1160:
1161: /* Postscript primitives :misc */
1162: case Squit:
1163: Kclose(); stackmachine_close();
1164: exit(0);
1165: break;
1166:
1167: case Ssystem:
1168: ob1 = Kpop();
1169: switch(ob1.tag) {
1170: case Sdollar: break;
1171: case Sstring: break;
1172: default: errorStackmachine("Usage:system");
1173: }
1.4 takayama 1174: if (SecureMode) errorStackmachine("Security violation.");
1.1 maekawa 1175: system( ob1.lc.str );
1176: break;
1177:
1178: case Scat_n:
1179: ob1 = Kpop();
1180: switch(ob1.tag) {
1181: case Sinteger: break;
1182: default: errorStackmachine("Usage:cat_n");
1183: }
1184: size = ob1.lc.ival;
1185: k = 0;
1186: for (i=size-1; i>=0; i--) {
1187: ob2 = peek(i);
1188: switch(ob2.tag) {
1189: case Sdollar: break;
1.4 takayama 1190: default: errorStackmachine("Usage:cat_n");
1.1 maekawa 1191: }
1192: k += strlen(ob2.lc.str);
1193: }
1194: ob1.tag = Sdollar;
1195: ob1.lc.str = (char *)sGC_malloc(sizeof(char)*(k+1));
1196: if (ob1.lc.str == (char *)NULL) {
1197: errorStackmachine("No more memory.\n");
1198: }
1199: /* concatnate */
1200: k = 0;
1201: for (i=size-1; i>=0; i--) {
1202: ob2 = peek(i);
1203: strcpy(&((ob1.lc.str)[k]),ob2.lc.str);
1204: k = strlen(ob1.lc.str);
1205: }
1206: /* clear the arguments */
1207: for (i=size-1; i>=0; i--) {
1208: ob2 = Kpop();
1209: }
1210: Kpush(ob1);
1211: break;
1212:
1213: case Sset_timer:
1214: /* 118p */
1215: if (timerStart) {
1216: before_real = time(&before_real);
1217: times(&before);
1218: timerStart = 0; TimerOn = 1;
1219: }else{
1220: times(&after);
1221: after_real = time(&after_real);
1222: if (TimerOn) {
1.4 takayama 1223: printf("User time: %f seconds, System time: %f seconds, Real time: %d s\n",
1224: ((double)(after.tms_utime - before.tms_utime)) /100.0,
1225: ((double)(after.tms_stime - before.tms_stime)) /100.0,
1226: (int) (after_real-before_real));
1227: /* In cases of Solaris and Linux, the unit of tms_utime seems to
1228: be given 0.01 seconds. */
1.1 maekawa 1229:
1230: }
1231: timerStart = 1; TimerOn = 0;
1232: }
1233: break;
1234:
1235: case Susage:
1236: ob1 = Kpop();
1237: Kusage(ob1);
1238: break;
1239:
1240: case Sto_records:
1241: ob1 = Kpop();
1242: switch(ob1.tag) {
1243: case Sdollar: break;
1244: default: errorStackmachine("Usage:to_records");
1245: }
1246: ob2 = KtoRecords(ob1);
1247: size = getoaSize(ob2);
1248: for (i=0; i<size; i++) {
1249: Kpush(getoa(ob2,i));
1250: }
1251: rob.tag = Sinteger;
1252: rob.lc.ival = size;
1253: Kpush(rob);
1254: break;
1255:
1256: case Ssystem_variable:
1257: ob1 = Kpop();
1258: switch(ob1.tag) {
1259: case Sarray: break;
1260: default: errorStackmachine("Usage:system_variable");
1261: }
1262: Kpush(KsystemVariable(ob1));
1263: break;
1264:
1265: /* kan primitives :kan :ring */
1266: case Sset_order_by_matrix:
1267: ob1 = Kpop();
1268: KsetOrderByObjArray(ob1);
1269: break;
1270: case Sset_up_ring:
1.7 takayama 1271: KresetDegreeShift();
1.1 maekawa 1272: ob5 = Kpop(); ob4=Kpop(); ob3=Kpop(); ob2=Kpop(); ob1=Kpop();
1273: KsetUpRing(ob1,ob2,ob3,ob4,ob5);
1274: break;
1275: case Sshow_ring:
1276: KshowRing(CurrentRingp);
1277: break;
1278: case Sswitch_function:
1279: ob1 = Kpop();
1280: ob2 = Kpop();
1281: ob3 = KswitchFunction(ob2,ob1);
1282: if (!isNullObject(ob3)) {
1283: Kpush(ob3);
1284: }
1285: break;
1286: case Sprint_switch_status:
1287: KprintSwitchStatus();
1288: break;
1289: case Sreplace:
1290: ob2 = Kpop();
1291: ob1 = Kpop();
1292: Kpush(KoReplace(ob1,ob2));
1293: break;
1294:
1295: case Scoefficients:
1296: ob2 = Kpop();
1297: ob1 = Kpop();
1298: Kpush(Kparts(ob1,ob2));
1299: break;
1300:
1301: case Scoeff2:
1302: ob2 = Kpop();
1303: ob1 = Kpop();
1304: Kpush(Kparts2(ob1,ob2));
1305: break;
1306:
1307: case Sdegree:
1308: ob2 = Kpop();
1309: ob1 = Kpop();
1310: Kpush(Kdegree(ob1,ob2));
1311: break;
1312: case Sspol:
1313: ob2 = Kpop();
1314: ob1 = Kpop();
1315: Kpush(Ksp(ob1,ob2));
1316: break;
1317:
1318: case Seval:
1319: ob1 = Kpop();
1320: Kpush(Keval(ob1));
1321: break;
1322:
1323: case Sreduction:
1324: ob2 = Kpop();
1325: ob1 = Kpop();
1326: Kpush(Kreduction(ob1,ob2));
1327: break;
1328:
1329: case Sgroebner :
1330: ob1 = Kpop();
1331: Kpush(Kgroebner(ob1));
1332: break;
1333:
1334: case Shomogenize :
1335: ob1 = Kpop();
1336: Kpush(homogenizeObject(ob1,&i));
1337: break;
1338:
1339: case Sprincipal :
1340: ob1 = Kpop();
1341: Kpush(oPrincipalPart(ob1));
1342: break;
1343:
1344: case Sinit:
1345: ob2 = Kpop();
1346: if (ob2.tag != Sarray) {
1347: Kpush(Khead(ob2));
1348: }else{
1.6 takayama 1349: if (getoaSize(ob2) > 0) {
1350: if (getoa(ob2,getoaSize(ob2)-1).tag == Spoly) {
1351: Kpush(oInitW(ob2,newObjectArray(0)));
1352: }else{
1353: ob1 = Kpop();
1354: Kpush(oInitW(ob1,ob2));
1355: }
1356: }else{
1357: ob1 = Kpop();
1358: Kpush(oInitW(ob1,ob2));
1359: }
1.1 maekawa 1360: }
1361: break;
1362:
1363: case Sextension:
1364: ob1 = Kpop();
1365: Kpush(Kextension(ob1));
1366: break;
1367:
1368: case Sgbext:
1369: ob1 = Kpop();
1370: Kpush(KgbExtension(ob1));
1371: break;
1372:
1373: case Snewstack:
1374: ob1 = Kpop();
1375: switch(ob1.tag) {
1376: case Sinteger:
1377: Kpush(newOperandStack(ob1.lc.ival));
1378: break;
1379: default:
1380: errorStackmachine("Usage:newstack");
1381: break;
1382: }
1383: break;
1384:
1385: case Ssetstack:
1386: ob1 = Kpop();
1387: switch(ob1.tag) {
1388: case Sclass:
1389: setOperandStack(ob1);
1390: break;
1391: default:
1392: errorStackmachine("Usage:setstack");
1393: break;
1394: }
1395: break;
1396:
1397: case Sstdstack:
1398: stdOperandStack();
1399: break;
1400:
1401: case Slc:
1402: ob1 = Kpop();
1403: switch (ob1.tag) {
1404: case Sclass:
1405: Kpush(KpoInteger(ob1.lc.ival));
1406: break;
1407: default:
1408: errorStackmachine("Usage:lc");
1409: break;
1410: }
1411: break;
1412:
1413: case Src:
1414: ob1 = Kpop();
1415: switch (ob1.tag) {
1416: case Sclass:
1417: if (ClassTypes[ob1.lc.ival] == CLASS_OBJ) {
1.4 takayama 1418: Kpush(*(ob1.rc.op));
1.1 maekawa 1419: }else{
1.4 takayama 1420: warningStackmachine("<<obj rc >> works only for a class object with CLASS_OBJ attribute.\n");
1421: Kpush(ob1);
1.1 maekawa 1422: }
1423: break;
1424: default:
1425: errorStackmachine("Usage:rc");
1426: break;
1427: }
1428: break;
1429:
1430: case Snewcontext:
1431: ob1 = Kpop();
1432: ob2 = Kpop();
1433: switch(ob1.tag) {
1434: case Sclass:
1435: if (ob2.tag == Sdollar) {
1.4 takayama 1436: Kpush(KnewContext(ob1,KopString(ob2)));
1.1 maekawa 1437: }else errorStackmachine("Usage:newcontext");
1438: break;
1439: default:
1440: errorStackmachine("Usage:newcontext");
1441: break;
1442: }
1443: break;
1444:
1445: case Ssetcontext:
1446: ob1 = Kpop();
1447: switch(ob1.tag) {
1448: case Sclass:
1449: KsetContext(ob1);
1450: break;
1451: default:
1452: errorStackmachine("Usage:setcontext");
1453: break;
1454: }
1455: break;
1456:
1457: case Ssupercontext:
1458: ob1 = Kpop();
1459: switch(ob1.tag) {
1460: case Sclass:
1461: Kpush(getSuperContext(ob1));
1462: break;
1463: default:
1464: errorStackmachine("Usage:supercontext");
1465: break;
1466: }
1467: break;
1468:
1469: case Ssendmsg:
1470: /* ob2 { .........} sendmsg */
1471: /* cf. debug/kobj.sm1 */
1472: ob1 = Kpop();
1473: ob2 = Kpop();
1474: switch(ob1.tag) {
1475: case SexecutableArray: break;
1476: default: errorStackmachine("Usage:sendmsg");
1477: }
1478: ccflag = 0;
1479: if (ob2.tag == Sarray ) {
1480: if (getoaSize(ob2) >= 1) {
1.4 takayama 1481: ob3 = getoa(ob2,0);
1482: if (ectag(ob3) == CLASSNAME_CONTEXT) {
1483: contextControl(CCPUSH); ccflag = 1; /* push the current context. */
1484: CurrentContextp = (struct context *)ecbody(ob3);
1485: }
1.1 maekawa 1486: }
1487: }
1488: if (!ccflag) {
1489: contextControl(CCPUSH); ccflag = 1;
1490: CurrentContextp = PrimitiveContextp;
1491: }
1492: /* normal exec. */
1493: Kpush(ob2);
1.15 takayama 1494: status = executeExecutableArray(ob1,(char *)NULL,0);
1.13 takayama 1495:
1.1 maekawa 1496: if (ccflag) {
1497: contextControl(CCPOP); ccflag = 0; /* recover the Current context. */
1498: }
1.14 takayama 1499:
1.1 maekawa 1500: break;
1501: case Ssendmsg2:
1502: /* ob2 ob4 { .........} sendmsg2 */
1503: /* Context is determined by ob2 or ob1 */
1504: ob1 = Kpop();
1505: ob4 = Kpop();
1506: ob2 = Kpop();
1507: switch(ob1.tag) {
1508: case SexecutableArray: break;
1509: default: errorStackmachine("Usage:sendmsg2");
1510: }
1511: ccflag = 0;
1512: if (ob2.tag == Sarray ) {
1513: if (getoaSize(ob2) >= 1) {
1.4 takayama 1514: ob3 = getoa(ob2,0);
1515: if (ectag(ob3) == CLASSNAME_CONTEXT) {
1516: contextControl(CCPUSH); ccflag = 1; /* push the current context. */
1517: CurrentContextp = (struct context *)ecbody(ob3);
1518: }
1.1 maekawa 1519: }
1520: }
1521: if (!ccflag && ob4.tag == Sarray) {
1522: if (getoaSize(ob4) >= 1) {
1.4 takayama 1523: ob3 = getoa(ob4,0);
1524: if (ectag(ob3) == CLASSNAME_CONTEXT) {
1525: contextControl(CCPUSH); ccflag = 1; /* push the current context. */
1526: CurrentContextp = (struct context *)ecbody(ob3);
1527: }
1.1 maekawa 1528: }
1529: }
1530: if (!ccflag) {
1531: contextControl(CCPUSH); ccflag = 1;
1532: CurrentContextp = PrimitiveContextp;
1533: }
1534: /* normal exec. */
1535: Kpush(ob2); Kpush(ob4);
1.14 takayama 1536:
1537: /* We cannot use executeExecutableArray(ob1,(char *)NULL) because of
1538: the quote mode. Think about it later. */
1.1 maekawa 1539: tokenArray = ob1.lc.tokenArray;
1540: size = ob1.rc.ival;
1541: for (i=0; i<size; i++) {
1542: token = tokenArray[i];
1.10 takayama 1543: InSendmsg2 = 1;
1.1 maekawa 1544: status = executeToken(token);
1.10 takayama 1545: InSendmsg2 = 0;
1.13 takayama 1546:
1547: if (status & STATUS_INFIX) {
1548: if (status & DO_QUOTE) errorStackmachine("infix op with DO_QUOTE\n");
1549: if (i == size-1) errorStackmachine("infix operator at the end(sendmsg2).\n");
1550: infixOn = 1; infixToken = tokenArray[i];
1551: infixToken.tflag |= NO_DELAY; continue;
1552: }else if (infixOn) {
1553: infixOn = 0; status = executeToken(infixToken);
1554: if (status & STATUS_BREAK) break;
1555: }
1556:
1557: if (QuoteMode && (status & DO_QUOTE)) {
1.8 takayama 1558: /* generate tree object, for kan/k0 */
1559: struct object qob;
1560: struct object qattr;
1561: struct object qattr2;
1562: if (i==0) { Kpop(); Kpop();}
1563: qob = newObjectArray(3);
1564: qattr = newObjectArray(1);
1565: qattr2 = newObjectArray(2);
1566: /* Set the node name of the tree. */
1567: if (token.kind == ID) {
1568: putoa(qob,0,KpoString(token.token));
1569: }else{
1570: putoa(qob,0,KpoString("unknown"));
1571: }
1572: /* Set the attibute list; class=className */
1573: if (ob2.tag == Sdollar) {
1.11 takayama 1574: putoa(qattr2,0,KpoString("cd"));
1.8 takayama 1575: putoa(qattr2,1,ob2);
1576: }else{
1.11 takayama 1577: putoa(qattr2,0,KpoString("class"));
1.8 takayama 1578: putoa(qattr2,1,KpoString(CurrentContextp->contextName));
1579: }
1580: putoa(qattr,0,qattr2);
1581: putoa(qob,1,qattr);
1582: putoa(qob,2,ob4); /* Argument */
1583: qob = KpoTree(qob);
1584: Kpush(qob);
1.13 takayama 1585: } else if (status & STATUS_BREAK) break;
1586:
1.1 maekawa 1587: }
1588: if (ccflag) {
1589: contextControl(CCPOP); ccflag = 0;
1590: /* recover the Current context. */
1591: /* Note that it is not recovered in case of error. */
1592: }
1593:
1594: break;
1595: case Sprimmsg:
1596: /* { .........} primmsg */
1597: /* Context is PrimitiveContext. */
1598: ob1 = Kpop();
1599: switch(ob1.tag) {
1600: case SexecutableArray: break;
1601: default: errorStackmachine("Usage:primmsg");
1602: }
1603: contextControl(CCPUSH); ccflag = 1;
1604: CurrentContextp = PrimitiveContextp;
1605: /* normal exec. */
1.15 takayama 1606: status = executeExecutableArray(ob1,(char *)NULL,0);
1.1 maekawa 1607: contextControl(CCPOP); /* recover the Current context. */
1608: break;
1609:
1610: case Ssupmsg2:
1611: /* ob2 ob4 { .........} supmsg2 */
1612: /* Context is super class of ob2 */
1613: ob1 = Kpop();
1614: ob4 = Kpop();
1615: ob2 = Kpop();
1616: switch(ob1.tag) {
1617: case SexecutableArray: break;
1618: default: errorStackmachine("Usage:supmsg2");
1619: }
1620: ccflag = 0;
1621: if (ob2.tag == Sarray ) {
1622: if (getoaSize(ob2) >= 1) {
1.4 takayama 1623: ob3 = getoa(ob2,0);
1624: if (ectag(ob3) == CLASSNAME_CONTEXT) {
1625: if (((struct context *)ecbody(ob3))->super == NULL) {
1626: errorStackmachine("supmsg2: SuperClass is NIL.");
1627: }
1628: contextControl(CCPUSH); ccflag = 1; /* push the current context. */
1629: CurrentContextp = ((struct context *)ecbody(ob3))->super;
1630: }
1.1 maekawa 1631: }
1632: }
1633: if (!ccflag && (ob4.tag == Sarray) ) {
1634: if (getoaSize(ob4) >= 1) {
1.4 takayama 1635: ob3 = getoa(ob4,0);
1636: if (ectag(ob3) == CLASSNAME_CONTEXT) {
1637: if (((struct context *)ecbody(ob3))->super == NULL) {
1638: errorStackmachine("supmsg2: SuperClass is NIL.");
1639: }
1640: contextControl(CCPUSH); ccflag = 1; /* push the current context. */
1641: CurrentContextp = ((struct context *)ecbody(ob3))->super;
1642: }
1.1 maekawa 1643: }
1644: }
1645: if (!ccflag) {
1646: contextControl(CCPUSH); ccflag = 1;
1647: CurrentContextp = PrimitiveContextp;
1648: }
1649: /* normal exec. */
1650: Kpush(ob2); Kpush(ob4);
1.15 takayama 1651: status = executeExecutableArray(ob1,(char *)NULL,0);
1.1 maekawa 1652: if (ccflag) {
1653: contextControl(CCPOP); ccflag = 0; /* recover the Current context. */
1654: }
1655:
1656: break;
1657:
1658: case Serror:
1659: ob1 = peek(0);
1660: if (ob1.tag == Sdollar) {
1661: /* compose error message */
1662: ob = Kpop();
1663: str = (char *) sGC_malloc(sizeof(char)*(strlen("error operator : ")+
1.4 takayama 1664: strlen(KopString(ob1))+ 10));
1.1 maekawa 1665: if (str == NULL) errorStackmachine("No more memory.");
1666: strcpy(str,"error operator : ");
1667: strcat(str,KopString(ob1));
1668: errorStackmachine(str);
1669: }else{
1670: errorStackmachine("error operator.");
1671: }
1672: break;
1673: case Smpzext:
1674: ob1 = Kpop();
1675: Kpush(KmpzExtension(ob1));
1676: break;
1677:
1678: case Scclass:
1679: ob3 = Kpop();
1680: ob2 = Kpop();
1681: ob1 = Kpop();
1682: /* [class-tag super-obj] size [class-tag] cclass */
1683: Kpush(KcreateClassIncetance(ob1,ob2,ob3));
1684: break;
1685:
1686: case Stest:
1687: /* test is used for a test of a new function. */
1688: ob2 = Kpop();
1689: ob1 = Kpop();
1690: Kpush(hilberto(ob1,ob2));
1691: /*
1.4 takayama 1692: {
1693: ob1 = Kpop();
1694: Kpush(test(ob1));
1.1 maekawa 1695:
1.4 takayama 1696: }
1.1 maekawa 1697: */
1.9 takayama 1698: break;
1699:
1700: case Soxshell:
1701: ob1 = Kpop();
1702: Kpush(KoxShell(ob1));
1.1 maekawa 1703: break;
1.5 takayama 1704:
1705: case Stlimit:
1706: /* { } time tlimit */
1707: ob2 = Kpop();
1708: ob1 = Kpop();
1709: switch(ob2.tag) {
1710: case Sinteger: break;
1711: default: errorStackmachine("Usage:tlimit"); break;
1712: }
1713: switch(ob1.tag) {
1714: case SexecutableArray: break;
1715: default:
1716: errorStackmachine("Usage:tlimit");
1717: break;
1718: }
1719: n = ob2.lc.ival;
1720: if (n > 0) {
1721: signal(SIGALRM,ctrlC); alarm((unsigned int) n);
1.15 takayama 1722: status = executeExecutableArray(ob1,(char *)NULL,0);
1.5 takayama 1723: cancelAlarm();
1724: }else{
1725: before_real = time(&before_real);
1726: times(&before);
1.15 takayama 1727: status = executeExecutableArray(ob1,(char *)NULL,0);
1.5 takayama 1728: times(&after);
1729: after_real = time(&after_real);
1730: ob1 = newObjectArray(3);
1731: putoa(ob1,0,KpoInteger((int) after.tms_utime - before.tms_utime));
1732: putoa(ob1,1,KpoInteger((int) after.tms_stime - before.tms_stime));
1733: putoa(ob1,2,KpoInteger((int) (after_real-before_real)));
1734: Kpush(ob1);
1735: }
1736: break;
1.1 maekawa 1737:
1738:
1739: default:
1740: errorStackmachine("Unknown Soperator type. \n");
1741: }
1742: return(0); /* normal exit */
1743: }
1744:
1745:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to primitive.c CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM / src / kan96xx / Kan