Annotation of OpenXM/src/kan96xx/Kan/primitive.c, Revision 1.17
1.17 ! takayama 1: /* $OpenXM: OpenXM/src/kan96xx/Kan/primitive.c,v 1.16 2004/09/12 10:58:28 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.1 maekawa 449:
1.13 takayama 450: infixOn = 0;
451:
1.1 maekawa 452: if (DebugStack >= 2) {
453: fprintf(Fstack,"In execute %d\n",ob.lc.ival); printOperandStack();
454: }
455:
456: if (GotoP) return(0);
457: switch (ob.lc.ival) {
458: /* Postscript primitives :stack */
459: case Sgoto:
460: ob1 = Kpop();
461: if (ob1.tag != Sstring) {
462: if (DebugStack>=2) printObject(ob1,0,Fstack);
463: errorStackmachine("Usage:goto");
464: }
465: GotoLabel = ob1.lc.str;
466: GotoP = 1;
467: break;
468: case Spop:
469: ob1 = Kpop();
470: break;
471:
472: case Sdup:
473: ob1 = Kpop();
474: Kpush(ob1); Kpush(ob1);
475: break;
476: case Scopy: /* copy values. cf. dup */
477: ob1 = Kpop();
478: switch(ob1.tag) {
479: case Sinteger: break;
480: default: errorStackmachine("Usage:copy");
481: }
482: size = ob1.lc.ival;
483: k = 0;
484: for (i=size-1; i>=0; i--) {
485: ob2 = peek(i+k);
486: switch(ob2.tag) {
487: case Sdollar: /* copy by value */
1.4 takayama 488: str = (char *)sGC_malloc(strlen(ob2.lc.str)+3);
489: if (str == (char *)NULL) errorStackmachine("No memory (copy)");
490: strcpy(str,ob2.lc.str);
491: Kpush(KpoString(str));
492: break;
1.1 maekawa 493: case Spoly:
1.4 takayama 494: errorStackmachine("no pCopy (copy)");
495: break;
1.1 maekawa 496: case Sarray:
1.4 takayama 497: n = ob2.lc.ival;
498: ob3 = newObjectArray(n);
499: for (j=0; j<n; j++) {
500: putoa(ob3,j,getoa(ob2,j));
501: }
502: Kpush(ob3);
503: break;
1.1 maekawa 504: default:
1.4 takayama 505: Kpush(ob2);
506: break;
1.1 maekawa 507: }
508: k++;
509: }
510: break;
511: case Sroll:
512: ob1 = Kpop();
513: ob2 = Kpop();
514: switch(ob1.tag) {
515: case Sinteger:
516: j = ob1.lc.ival;
517: break;
518: default: errorStackmachine("Usage:roll");
519: }
520: switch(ob2.tag) {
521: case Sinteger:
522: n = ob2.lc.ival;
523: break;
524: default: errorStackmachine("Usage:roll");
525: }
526: for (i=0; i<n; i++) {
527: if (i < OB_ARRAY_MAX) {
1.4 takayama 528: obArray[i] = Kpop();
1.1 maekawa 529: }else{
1.4 takayama 530: errorStackmachine("exceeded OB_ARRAY_MAX (roll)\n");
1.1 maekawa 531: }
532: }
533: for (i=0; i<n; i++) {
534: k = (j-1)%n;
535: k = (k>=0?k: k+n);
536: Kpush(obArray[k]);
537: j--;
538: }
539: break;
540: case Spstack:
541: printOperandStack();
542: break;
543:
544: /* Postscript primitives :arithmetic */
545: case Sadd:
1.16 takayama 546: ob1 = Kpop();
1.1 maekawa 547: ob2 = Kpop();
1.16 takayama 548: evalEA(ob1); evalEA(ob2);
1.1 maekawa 549: rob = KooAdd(ob1,ob2);
550: Kpush(rob);
551: break;
552: case Ssub:
553: ob2 = Kpop();
554: ob1 = Kpop();
1.16 takayama 555: evalEA(ob1); evalEA(ob2);
1.1 maekawa 556: rob = KooSub(ob1,ob2);
557: Kpush(rob);
558: break;
559: case Smult:
560: ob2 = Kpop();
561: ob1 = Kpop();
1.16 takayama 562: evalEA(ob1); evalEA(ob2);
1.1 maekawa 563: rob = KooMult(ob1,ob2);
564: Kpush(rob);
565: break;
566: case Sidiv:
567: ob2 = Kpop(); ob1 = Kpop();
1.16 takayama 568: evalEA(ob1); evalEA(ob2);
1.1 maekawa 569: rob = KooDiv(ob1,ob2);
570: Kpush(rob);
571: break;
572:
573: case Sdiv:
574: ob2 = Kpop(); ob1 = Kpop();
1.16 takayama 575: evalEA(ob1); evalEA(ob2);
1.1 maekawa 576: rob = KooDiv2(ob1,ob2);
577: Kpush(rob);
578: break;
579:
580: /* Postscript primitives :array */
581: case SleftBrace:
582: rob.tag = SleftBraceTag;
583: Kpush(rob);
584: break;
585:
586: case SrightBrace:
587: size = 0;
588: ob1 = peek(size);
589: while (!(Osp-size-1 < 0)) { /* while the stack is not underflow */
590: if (ob1.tag == SleftBraceTag) {
1.4 takayama 591: rob = newObjectArray(size);
592: for (i=0; i<size; i++) {
593: (rob.rc.op)[i] = peek(size-1-i);
594: }
595: for (i=0; i<size+1; i++) {
596: Kpop();
597: }
598: break;
1.1 maekawa 599: }
600: size++;
601: ob1 = peek(size);
602: }
603: Kpush(rob);
604: break;
605:
606: case Sget:
607: /* [a_0 ... a_{n-1}] i get a_i */
608: /* ob2 ob1 get */
609: ob1 = Kpop();
610: ob2 = Kpop();
1.12 takayama 611: Kpush(Kget(ob2,ob1));
1.1 maekawa 612: break;
613:
614: case Sput:
615: /* [a_0 ... a_{n-1}] index any put */
616: /* ob3 ob2 ob1 put */
617: /* Or; [[a_00 ....] [a_10 ....] ....] [1 0] any put. MultiIndex. */
618: ob1 = Kpop(); ob2 = Kpop(); ob3 = Kpop();
619: switch(ob2.tag) {
1.17 ! takayama 620: case SuniversalNumber:
! 621: ob2 = Kto_int32(ob2); /* do not break and go to Sinteger */
1.1 maekawa 622: case Sinteger:
623: switch(ob3.tag) {
624: case Sarray:
1.4 takayama 625: i = ob2.lc.ival;
626: size = getoaSize(ob3);
627: if ((0 <= i) && (i<size)) {
628: getoa(ob3,i) = ob1;
629: }else{
630: errorStackmachine("Index is out of bound. (put)\n");
631: }
632: break;
1.1 maekawa 633: case Sdollar:
1.4 takayama 634: i = ob2.lc.ival;
635: size = strlen(ob3.lc.str);
636: if ((0 <= i) && (i<size)) {
637: if (ob1.tag == Sdollar) {
638: (ob3.lc.str)[i] = (ob1.lc.str)[0];
639: }else{
640: (ob3.lc.str)[i] = ob1.lc.ival;
641: }
642: }else{
643: errorStackmachine("Index is out of bound. (put)\n");
644: }
645: break;
1.1 maekawa 646: default: errorStackmachine("Usage:put");
647: }
648: break;
649: case Sarray:
650: ob5 = ob3;
651: n = getoaSize(ob2);
652: for (i=0; i<n; i++) {
1.4 takayama 653: if (ob5.tag != Sarray)
654: errorStackmachine("Object pointed by the multi-index is not array (put)\n");
655: ob4 = getoa(ob2,i);
1.17 ! takayama 656: if (ob4.tag == SuniversalNumber) ob4 = Kto_int32(ob4);
1.4 takayama 657: if (ob4.tag != Sinteger)
658: errorStackmachine("Index has to be an integer. (put)\n");
659: k = ob4.lc.ival;
660: size = getoaSize(ob5);
661: if ((0 <= k) && (k<size)) {
662: if (i == n-1) {
663: getoa(ob5,k) = ob1;
664: }else{
665: ob5 = getoa(ob5,k);
666: }
667: }else{
668: errorStackmachine("Index is out of bound for the multi-index. (put)\n");
669: }
1.1 maekawa 670: }
671: break;
672: default: errorStackmachine("Usage:put");
673: }
674: break;
675:
676: case Sindex:
677: ob1 = Kpop();
678: switch(ob1.tag) {
679: case Sinteger: break;
680: default: errorStackmachine("Usage:index");
681: }
682: size = ob1.lc.ival;
683: Kpush(peek(size-1));
684: break;
685:
686: case Saload:
687: /* [a1 a2 ... an] aload a1 a2 ... an [a1 ... an] */
688: ob1 = Kpop();
689: switch(ob1.tag) {
690: case Sarray: break;
691: default:
692: errorStackmachine("Usage:aload");
693: }
694: size = getoaSize(ob1);
695: for (i=0; i<size; i++) {
696: Kpush(getoa(ob1,i));
697: }
698: Kpush(ob1);
699:
700: break;
701:
702: case Slength:
703: /* [a_0 ... a_{n-1}] length n */
704: /* ob1 length rob */
705: ob1 = Kpop();
706: switch(ob1.tag) {
707: case Sarray:
708: size = getoaSize(ob1);
709: Kpush(KpoInteger(size));
710: break;
711: case Sdollar:
712: Kpush(KpoInteger(strlen(ob1.lc.str)));
713: break;
714: case Spoly:
715: Kpush(KpoInteger(KpolyLength(KopPOLY(ob1))));
716: break;
717: default: errorStackmachine("Usage:length");
718: }
719: break;
720:
721: /* Postscript primitives :relation */
722: case Sequal:
723: /* obj1 obj2 == bool */
724: ob2 = Kpop();
725: ob1 = Kpop();
726: if(KooEqualQ(ob1,ob2)) {
727: Kpush(KpoInteger(1));
728: }else{
729: Kpush(KpoInteger(0));
730: }
731: break;
732:
733: case Sless:
734: /* obj1 obj2 < bool */
735: ob2 = Kpop();
736: ob1 = Kpop();
737: Kpush(KooLess(ob1,ob2));
738: break;
739:
740: case Sgreater:
741: /* obj1 obj2 < bool */
742: ob2 = Kpop();
743: ob1 = Kpop();
744: Kpush(KooGreater(ob1,ob2));
745: break;
746:
747:
748: /* Postscript primitives :controle */
749: case Sloop:
750: /* { .... exit .....} loop */
751: ob1 = Kpop();
752: switch(ob1.tag) {
753: case SexecutableArray: break;
754: default:
755: errorStackmachine("Usage:loop");
756: break;
757: }
758: while (1) {
1.15 takayama 759: status = executeExecutableArray(ob1,(char *)NULL,1);
1.13 takayama 760: if ((status & STATUS_BREAK) || GotoP) break;
1.1 maekawa 761: /* here, do not return 1. Do not propagate exit signal outside of the
1.4 takayama 762: loop. */
1.1 maekawa 763: }
764: break;
765:
766: case Sfor:
767: /* init inc limit { } for */
768: /* ob4 ob3 ob2 ob1 */
769: ob1 =Kpop(); ob2 = Kpop(); ob3 = Kpop(); ob4 = Kpop();
770: switch(ob1.tag) {
771: case SexecutableArray: break;
772: default: errorStackmachine("Usage:for");
773: }
774: switch(ob2.tag) {
775: case Sinteger: break;
776: default:
777: errorStackmachine("Usage:for The 3rd argument must be integer.");
778: }
779: switch(ob3.tag) {
780: case Sinteger: break;
781: default: errorStackmachine("Usage:for The 2nd argument must be integer.");
782: }
783: switch(ob4.tag) {
784: case Sinteger: break;
785: default: errorStackmachine("Usage:for The 1st argument must be integer.");
786: }
787: {
788: int i,lim,inc,j;
789: i = ob4.lc.ival;
790: lim = ob2.lc.ival;
791: inc = ob3.lc.ival;
792: if (inc > 0) {
793: /*
1.4 takayama 794: if (lim < i) errorStackmachine("The initial value must not be greater than limit value (for).\n");
1.1 maekawa 795: */
1.4 takayama 796: for ( ; i<=lim; i += inc) {
797: Kpush(KpoInteger(i));
1.15 takayama 798: status = executeExecutableArray(ob1,(char *)NULL,1);
1.14 takayama 799: if ((status & STATUS_BREAK) || GotoP) goto xyz;
1.13 takayama 800: }
1.1 maekawa 801: }else{
802: /*
1.4 takayama 803: if (lim > i) errorStackmachine("The initial value must not be less than limit value (for).\n");
1.1 maekawa 804: */
1.4 takayama 805: for ( ; i>=lim; i += inc) {
806: Kpush(KpoInteger(i));
1.15 takayama 807: status = executeExecutableArray(ob1,(char *)NULL,1);
1.14 takayama 808: if ((status & STATUS_BREAK) || GotoP) goto xyz;
1.4 takayama 809: }
1.1 maekawa 810: }
1.4 takayama 811: xyz: ;
1.1 maekawa 812: }
813: break;
814:
815: case Smap:
816: ob2 = Kpop(); ob1 = Kpop();
817: switch(ob1.tag) {
818: case Sarray: break;
819: default:
820: errorStackmachine("Usage:map The 1st argument must be an array.");
821: break;
822: }
823: switch(ob2.tag) {
824: case SexecutableArray: break;
825: default:
826: errorStackmachine("Usage:map The 2nd argument must be an executable array.");
827: break;
828: }
829: { int osize,size;
1.4 takayama 830: int i,j;
831: osize = getoaSize(ob1);
1.1 maekawa 832:
1.4 takayama 833: /*KSexecuteString("[");*/
834: rob.tag = SleftBraceTag;
835: Kpush(rob);
1.1 maekawa 836:
1.4 takayama 837: for (i=0; i<osize; i++) {
838: Kpush(getoa(ob1,i));
1.15 takayama 839: status = executeExecutableArray(ob2,(char *)NULL,0);
840: if (status & STATUS_BREAK) goto foor;
1.4 takayama 841: }
1.1 maekawa 842: foor: ;
1.4 takayama 843: /*KSexecuteString("]");*/
844: {
845: size = 0;
846: ob1 = peek(size);
847: while (!(Osp-size-1 < 0)) { /* while the stack is not underflow */
848: if (ob1.tag == SleftBraceTag) {
849: rob = newObjectArray(size);
850: for (i=0; i<size; i++) {
851: (rob.rc.op)[i] = peek(size-1-i);
852: }
853: for (i=0; i<size+1; i++) {
854: Kpop();
855: }
856: break;
857: }
858: size++;
859: ob1 = peek(size);
1.1 maekawa 860: }
1.4 takayama 861: Kpush(rob);
862: }
1.1 maekawa 863: }
864: break;
865:
866:
867: case Sifelse:
868: /* bool { } { } ifelse */
869: ob1 = Kpop();
870: ob2 = Kpop();
871: ob3 = Kpop();
872: switch (ob1.tag) {
873: case SexecutableArray: break;
874: default: errorStackmachine("Usage:ifelse");
875: }
876: switch (ob2.tag) {
877: case SexecutableArray: break;
878: default: errorStackmachine("Usage:ifelse");
879: }
880: switch (ob3.tag) {
881: case Sinteger: break;
882: default: errorStackmachine("Usage:ifelse");
883: }
884: if (ob3.lc.ival) {
885: /* execute ob2 */
886: ob1 = ob2;
887: }
888: /* execute ob1 */
1.15 takayama 889: status = executeExecutableArray(ob1,(char *)NULL,0);
1.14 takayama 890: if (status & STATUS_BREAK) return(status);
1.13 takayama 891:
1.1 maekawa 892: break;
893:
894: case Sexec:
895: /* { .........} exec */
896: ob1 = Kpop();
897: switch(ob1.tag) {
898: case SexecutableArray: break;
899: default: errorStackmachine("Usage:exec");
900: }
1.15 takayama 901: status = executeExecutableArray(ob1,(char *)NULL,0);
1.1 maekawa 902: break;
903:
1.4 takayama 904: /* Postscript primitives :dictionary */
1.1 maekawa 905: case Sdef:
906: ob2 = Kpop();
907: ob1 = Kpop();
908: /* type check */
909: switch(ob1.tag) {
910: case Sstring: break;
911: default:
912: errorStackmachine("Usage:def");
913: break;
914: }
915: k=putUserDictionary(ob1.lc.str,(ob1.rc.op->lc).ival,
1.4 takayama 916: (ob1.rc.op->rc).ival,ob2,
917: CurrentContextp->userDictionary);
1.1 maekawa 918: if (k < 0) {
919: str = (char *)sGC_malloc(sizeof(char)*(strlen(ob1.lc.str) + 256));
920: if (str == (char *)NULL) {
1.4 takayama 921: errorStackmachine("No memory.\n");
1.1 maekawa 922: }
923: if (k == -PROTECT) {
1.4 takayama 924: sprintf(str,"You rewrited the protected symbol %s.\n",ob1.lc.str);
925: /* cf. [(chattr) num sym] extension */
926: warningStackmachine(str);
1.1 maekawa 927: } else if (k == -ABSOLUTE_PROTECT) {
1.4 takayama 928: sprintf(str,"You cannot rewrite the protected symbol %s.\n",ob1.lc.str);
929: errorStackmachine(str);
1.1 maekawa 930: } else errorStackmachine("Unknown return value of putUserDictioanry\n");
931: }
932: break;
933:
934: case Sload:
935: ob1 = Kpop();
936: switch(ob1.tag) {
937: case Sstring: break;
938: default: errorStackmachine("Usage:load");
939: }
940: ob1 = findUserDictionary(ob1.lc.str,
1.4 takayama 941: (ob1.rc.op->lc).ival,
942: (ob1.rc.op->rc).ival,
943: CurrentContextp);
1.1 maekawa 944: if (ob1.tag == -1) Kpush(NullObject);
945: else Kpush(ob1);
946:
947: break;
948:
949: case Sset:
950: ob1 = Kpop();
951: ob2 = Kpop();
952: switch(ob1.tag) {
953: case Sstring: break;
954: default: errorStackmachine("Usage:set");
955: }
956: k= putUserDictionary(ob1.lc.str,(ob1.rc.op->lc).ival,
1.4 takayama 957: (ob1.rc.op->rc).ival,ob2,
958: CurrentContextp->userDictionary);
1.1 maekawa 959: if (k < 0) {
960: str = (char *)sGC_malloc(sizeof(char)*(strlen(ob1.lc.str) + 256));
961: if (str == (char *)NULL) {
1.4 takayama 962: errorStackmachine("No memory.\n");
1.1 maekawa 963: }
964: if (k == -PROTECT) {
1.4 takayama 965: sprintf(str,"You rewrited the protected symbol %s. \n",ob1.lc.str);
966: warningStackmachine(str);
1.1 maekawa 967: } else if (k == -ABSOLUTE_PROTECT) {
1.4 takayama 968: sprintf(str,"You cannot rewrite the protected symbol %s.\n",ob1.lc.str);
969: errorStackmachine(str);
1.1 maekawa 970: } else errorStackmachine("Unknown return value of putUserDictioanry\n");
971: }
972: break;
973:
974:
975: case Sshow_systemdictionary:
976: fprintf(Fstack,"------------- system dictionary -------------------\n");
977: showSystemDictionary(0);
978: break;
979:
980: case Sshow_user_dictionary:
981: showUserDictionary();
982: break;
983:
984:
985:
986: /* Postscript primitives : convert */
987: case Sdata_conversion:
988: ob2 = Kpop();
989: ob1 = Kpop();
990: switch(ob2.tag) {
991: case Sdollar:
992: if (ob1.tag != Sclass) {
1.4 takayama 993: rob = KdataConversion(ob1,ob2.lc.str);
1.1 maekawa 994: }else{
1.4 takayama 995: rob = KclassDataConversion(ob1,ob2);
1.1 maekawa 996: }
997: break;
998: case Sarray:
999: rob = KclassDataConversion(ob1,ob2); break;
1000: default: errorStackmachine("Usage:data_conversion");
1001: }
1002: Kpush(rob);
1003: break;
1004:
1005:
1006: /* Postscript ptimitives :file */
1007: case Srun:
1008: ob1 = Kpop();
1009: switch(ob1.tag) {
1010: case Sdollar: break;
1011: case Sstring: break;
1012: default:
1013: errorStackmachine("Usage:run");
1014: break;
1015: }
1016: getokenSM(OPEN,ob1.lc.str); /* open the file, $filename$ run */
1017: break;
1018:
1019: case Sprint:
1020: ob1 = Kpop();
1021: printObject(ob1,0,Fstack);
1022: break;
1023:
1024: case Sfileopen: /* filename mode file descripter */
1.4 takayama 1025: /* ob2 ob1 */
1.1 maekawa 1026: ob1 = Kpop();
1027: ob2 = Kpop();
1.4 takayama 1028: if (SecureMode) errorStackmachine("Security violation: you cannot open a file.");
1.1 maekawa 1029: switch(ob1.tag) {
1030: case Sdollar: break;
1031: default: errorStackmachine("Usage:file");
1032: }
1033: switch(ob2.tag) {
1034: case Sinteger: break;
1035: case Sdollar: break;
1036: default:errorStackmachine("Usage:file");
1037: }
1038: rob = NullObject;
1039: if (ob2.tag == Sdollar) {
1040: if (strcmp(ob2.lc.str,"%stdin") == 0) {
1.4 takayama 1041: rob.tag = Sfile; rob.lc.str="%stdin"; rob.rc.file = stdin;
1.1 maekawa 1042: }else if (strcmp(ob2.lc.str,"%stdout") == 0) {
1.4 takayama 1043: rob.tag = Sfile; rob.lc.str="%stdout"; rob.rc.file = stdout;
1.1 maekawa 1044: }else if (strcmp(ob2.lc.str,"%stderr") == 0) {
1.4 takayama 1045: rob.tag = Sfile; rob.lc.str="%stderr"; rob.rc.file = stderr;
1.1 maekawa 1046: }else if ( (rob.rc.file = fopen(ob2.lc.str,ob1.lc.str)) != (FILE *)NULL) {
1.4 takayama 1047: rob.tag = Sfile; rob.lc.str = ob2.lc.str;
1.1 maekawa 1048: }else {
1.4 takayama 1049: errorStackmachine("I cannot open the file.");
1.1 maekawa 1050: }
1051: }else {
1052: rob.rc.file = fdopen(ob2.lc.ival,ob1.lc.str);
1053: if ( rob.rc.file != (FILE *)NULL) {
1.4 takayama 1054: rob.tag = Sfile; rob.lc.ival = ob2.lc.ival;
1.1 maekawa 1055: }else{
1.4 takayama 1056: errorStackmachine("I cannot fdopen the given fd.");
1.1 maekawa 1057: }
1058: }
1059:
1060: Kpush(rob);
1061: break;
1062:
1063:
1064: case Swritestring:
1065: /* file string writestring
1066: ob2 ob1
1067: */
1068: ob1 = Kpop();
1069: ob2 = Kpop();
1070: switch(ob2.tag) {
1071: case Sfile: break;
1072: default: errorStackmachine("Usage:writestring");
1073: }
1074: switch(ob1.tag) {
1075: case Sdollar: break;
1076: default: errorStackmachine("Usage:writestring");
1077: }
1078: fprintf(ob2.rc.file,"%s",ob1.lc.str);
1079: break;
1080:
1081: case Sclosefile:
1082: ob1 = Kpop();
1083: switch(ob1.tag) {
1084: case Sfile: break;
1085: default: errorStackmachine("Usage:closefile");
1086: }
1087: if (fclose(ob1.rc.file) == EOF) {
1088: errorStackmachine("I couldn't close the file.\n");
1089: }
1090: break;
1091:
1092: case Spushfile: /* filename pushfile string */
1.4 takayama 1093: /* ob2 */
1.1 maekawa 1094: ob2 = Kpop();
1095: switch(ob2.tag) {
1096: case Sdollar: break;
1097: default:errorStackmachine("Usage:pushfile");
1098: }
1099: rob = NullObject;
1100: if (strcmp(ob2.lc.str,"%stdin") == 0) {
1101: ob1.tag = Sfile; ob1.lc.str="%stdin"; ob1.rc.file = stdin;
1102: }else if (strcmp(ob2.lc.str,"%stdout") == 0) {
1103: ob1.tag = Sfile; ob1.lc.str="%stdout"; ob1.rc.file = stdout;
1104: }else if (strcmp(ob2.lc.str,"%stderr") == 0) {
1105: ob1.tag = Sfile; ob1.lc.str="%stderr"; ob1.rc.file = stderr;
1106: }else if ( (ob1.rc.file = fopen(ob2.lc.str,"r")) != (FILE *)NULL) {
1107: ob1.tag = Sfile; ob1.lc.str = ob2.lc.str;
1108: }else {
1109: if (ob1.rc.file == (FILE *)NULL) {
1.4 takayama 1110: char fname2[1024];
1111: strcpy(fname2,getLOAD_SM1_PATH());
1112: strcat(fname2,ob2.lc.str);
1113: ob1.rc.file = fopen(fname2,"r");
1114: if (ob1.rc.file == (FILE *)NULL) {
1115: strcpy(fname2,LOAD_SM1_PATH);
1116: strcat(fname2,ob2.lc.str);
1117: ob1.rc.file = fopen(fname2,"r");
1118: if (ob1.rc.file == (FILE *)NULL) {
1119: 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);
1120: errorStackmachine("I cannot open the file.");
1121: }
1122: }
1.1 maekawa 1123: }
1124: }
1125:
1126: /* read the strings
1.4 takayama 1127: */
1.1 maekawa 1128: n = 256; j=0;
1129: rob.tag = Sdollar; rob.lc.str = (char *) sGC_malloc(sizeof(char)*n);
1130: if (rob.lc.str == (char *)NULL) errorStackmachine("No more memory.");
1131: while ((i = fgetc(ob1.rc.file)) != EOF) {
1132: if (j >= n-1) {
1.4 takayama 1133: n = 2*n;
1134: if (n <= 0) errorStackmachine("Too large file to put on the stack.");
1.1 maekawa 1135: str = (char *)sGC_malloc(sizeof(char)*n);
1.4 takayama 1136: if (str == (char *)NULL) errorStackmachine("No more memory.");
1137: for (k=0; k< n/2; k++) str[k] = (rob.lc.str)[k];
1138: rob.lc.str = str;
1.1 maekawa 1139: }
1140: (rob.lc.str)[j] = i; (rob.lc.str)[j+1] = '\0';
1141: j++;
1142: }
1143:
1144: fclose(ob1.rc.file);
1145: Kpush(rob);
1146: break;
1147:
1148: /* Postscript primitives :misc */
1149: case Squit:
1150: Kclose(); stackmachine_close();
1151: exit(0);
1152: break;
1153:
1154: case Ssystem:
1155: ob1 = Kpop();
1156: switch(ob1.tag) {
1157: case Sdollar: break;
1158: case Sstring: break;
1159: default: errorStackmachine("Usage:system");
1160: }
1.4 takayama 1161: if (SecureMode) errorStackmachine("Security violation.");
1.1 maekawa 1162: system( ob1.lc.str );
1163: break;
1164:
1165: case Scat_n:
1166: ob1 = Kpop();
1167: switch(ob1.tag) {
1168: case Sinteger: break;
1169: default: errorStackmachine("Usage:cat_n");
1170: }
1171: size = ob1.lc.ival;
1172: k = 0;
1173: for (i=size-1; i>=0; i--) {
1174: ob2 = peek(i);
1175: switch(ob2.tag) {
1176: case Sdollar: break;
1.4 takayama 1177: default: errorStackmachine("Usage:cat_n");
1.1 maekawa 1178: }
1179: k += strlen(ob2.lc.str);
1180: }
1181: ob1.tag = Sdollar;
1182: ob1.lc.str = (char *)sGC_malloc(sizeof(char)*(k+1));
1183: if (ob1.lc.str == (char *)NULL) {
1184: errorStackmachine("No more memory.\n");
1185: }
1186: /* concatnate */
1187: k = 0;
1188: for (i=size-1; i>=0; i--) {
1189: ob2 = peek(i);
1190: strcpy(&((ob1.lc.str)[k]),ob2.lc.str);
1191: k = strlen(ob1.lc.str);
1192: }
1193: /* clear the arguments */
1194: for (i=size-1; i>=0; i--) {
1195: ob2 = Kpop();
1196: }
1197: Kpush(ob1);
1198: break;
1199:
1200: case Sset_timer:
1201: /* 118p */
1202: if (timerStart) {
1203: before_real = time(&before_real);
1204: times(&before);
1205: timerStart = 0; TimerOn = 1;
1206: }else{
1207: times(&after);
1208: after_real = time(&after_real);
1209: if (TimerOn) {
1.4 takayama 1210: printf("User time: %f seconds, System time: %f seconds, Real time: %d s\n",
1211: ((double)(after.tms_utime - before.tms_utime)) /100.0,
1212: ((double)(after.tms_stime - before.tms_stime)) /100.0,
1213: (int) (after_real-before_real));
1214: /* In cases of Solaris and Linux, the unit of tms_utime seems to
1215: be given 0.01 seconds. */
1.1 maekawa 1216:
1217: }
1218: timerStart = 1; TimerOn = 0;
1219: }
1220: break;
1221:
1222: case Susage:
1223: ob1 = Kpop();
1224: Kusage(ob1);
1225: break;
1226:
1227: case Sto_records:
1228: ob1 = Kpop();
1229: switch(ob1.tag) {
1230: case Sdollar: break;
1231: default: errorStackmachine("Usage:to_records");
1232: }
1233: ob2 = KtoRecords(ob1);
1234: size = getoaSize(ob2);
1235: for (i=0; i<size; i++) {
1236: Kpush(getoa(ob2,i));
1237: }
1238: rob.tag = Sinteger;
1239: rob.lc.ival = size;
1240: Kpush(rob);
1241: break;
1242:
1243: case Ssystem_variable:
1244: ob1 = Kpop();
1245: switch(ob1.tag) {
1246: case Sarray: break;
1247: default: errorStackmachine("Usage:system_variable");
1248: }
1249: Kpush(KsystemVariable(ob1));
1250: break;
1251:
1252: /* kan primitives :kan :ring */
1253: case Sset_order_by_matrix:
1254: ob1 = Kpop();
1255: KsetOrderByObjArray(ob1);
1256: break;
1257: case Sset_up_ring:
1.7 takayama 1258: KresetDegreeShift();
1.1 maekawa 1259: ob5 = Kpop(); ob4=Kpop(); ob3=Kpop(); ob2=Kpop(); ob1=Kpop();
1260: KsetUpRing(ob1,ob2,ob3,ob4,ob5);
1261: break;
1262: case Sshow_ring:
1263: KshowRing(CurrentRingp);
1264: break;
1265: case Sswitch_function:
1266: ob1 = Kpop();
1267: ob2 = Kpop();
1268: ob3 = KswitchFunction(ob2,ob1);
1269: if (!isNullObject(ob3)) {
1270: Kpush(ob3);
1271: }
1272: break;
1273: case Sprint_switch_status:
1274: KprintSwitchStatus();
1275: break;
1276: case Sreplace:
1277: ob2 = Kpop();
1278: ob1 = Kpop();
1279: Kpush(KoReplace(ob1,ob2));
1280: break;
1281:
1282: case Scoefficients:
1283: ob2 = Kpop();
1284: ob1 = Kpop();
1285: Kpush(Kparts(ob1,ob2));
1286: break;
1287:
1288: case Scoeff2:
1289: ob2 = Kpop();
1290: ob1 = Kpop();
1291: Kpush(Kparts2(ob1,ob2));
1292: break;
1293:
1294: case Sdegree:
1295: ob2 = Kpop();
1296: ob1 = Kpop();
1297: Kpush(Kdegree(ob1,ob2));
1298: break;
1299: case Sspol:
1300: ob2 = Kpop();
1301: ob1 = Kpop();
1302: Kpush(Ksp(ob1,ob2));
1303: break;
1304:
1305: case Seval:
1306: ob1 = Kpop();
1307: Kpush(Keval(ob1));
1308: break;
1309:
1310: case Sreduction:
1311: ob2 = Kpop();
1312: ob1 = Kpop();
1313: Kpush(Kreduction(ob1,ob2));
1314: break;
1315:
1316: case Sgroebner :
1317: ob1 = Kpop();
1318: Kpush(Kgroebner(ob1));
1319: break;
1320:
1321: case Shomogenize :
1322: ob1 = Kpop();
1323: Kpush(homogenizeObject(ob1,&i));
1324: break;
1325:
1326: case Sprincipal :
1327: ob1 = Kpop();
1328: Kpush(oPrincipalPart(ob1));
1329: break;
1330:
1331: case Sinit:
1332: ob2 = Kpop();
1333: if (ob2.tag != Sarray) {
1334: Kpush(Khead(ob2));
1335: }else{
1.6 takayama 1336: if (getoaSize(ob2) > 0) {
1337: if (getoa(ob2,getoaSize(ob2)-1).tag == Spoly) {
1338: Kpush(oInitW(ob2,newObjectArray(0)));
1339: }else{
1340: ob1 = Kpop();
1341: Kpush(oInitW(ob1,ob2));
1342: }
1343: }else{
1344: ob1 = Kpop();
1345: Kpush(oInitW(ob1,ob2));
1346: }
1.1 maekawa 1347: }
1348: break;
1349:
1350: case Sextension:
1351: ob1 = Kpop();
1352: Kpush(Kextension(ob1));
1353: break;
1354:
1355: case Sgbext:
1356: ob1 = Kpop();
1357: Kpush(KgbExtension(ob1));
1358: break;
1359:
1360: case Snewstack:
1361: ob1 = Kpop();
1362: switch(ob1.tag) {
1363: case Sinteger:
1364: Kpush(newOperandStack(ob1.lc.ival));
1365: break;
1366: default:
1367: errorStackmachine("Usage:newstack");
1368: break;
1369: }
1370: break;
1371:
1372: case Ssetstack:
1373: ob1 = Kpop();
1374: switch(ob1.tag) {
1375: case Sclass:
1376: setOperandStack(ob1);
1377: break;
1378: default:
1379: errorStackmachine("Usage:setstack");
1380: break;
1381: }
1382: break;
1383:
1384: case Sstdstack:
1385: stdOperandStack();
1386: break;
1387:
1388: case Slc:
1389: ob1 = Kpop();
1390: switch (ob1.tag) {
1391: case Sclass:
1392: Kpush(KpoInteger(ob1.lc.ival));
1393: break;
1394: default:
1395: errorStackmachine("Usage:lc");
1396: break;
1397: }
1398: break;
1399:
1400: case Src:
1401: ob1 = Kpop();
1402: switch (ob1.tag) {
1403: case Sclass:
1404: if (ClassTypes[ob1.lc.ival] == CLASS_OBJ) {
1.4 takayama 1405: Kpush(*(ob1.rc.op));
1.1 maekawa 1406: }else{
1.4 takayama 1407: warningStackmachine("<<obj rc >> works only for a class object with CLASS_OBJ attribute.\n");
1408: Kpush(ob1);
1.1 maekawa 1409: }
1410: break;
1411: default:
1412: errorStackmachine("Usage:rc");
1413: break;
1414: }
1415: break;
1416:
1417: case Snewcontext:
1418: ob1 = Kpop();
1419: ob2 = Kpop();
1420: switch(ob1.tag) {
1421: case Sclass:
1422: if (ob2.tag == Sdollar) {
1.4 takayama 1423: Kpush(KnewContext(ob1,KopString(ob2)));
1.1 maekawa 1424: }else errorStackmachine("Usage:newcontext");
1425: break;
1426: default:
1427: errorStackmachine("Usage:newcontext");
1428: break;
1429: }
1430: break;
1431:
1432: case Ssetcontext:
1433: ob1 = Kpop();
1434: switch(ob1.tag) {
1435: case Sclass:
1436: KsetContext(ob1);
1437: break;
1438: default:
1439: errorStackmachine("Usage:setcontext");
1440: break;
1441: }
1442: break;
1443:
1444: case Ssupercontext:
1445: ob1 = Kpop();
1446: switch(ob1.tag) {
1447: case Sclass:
1448: Kpush(getSuperContext(ob1));
1449: break;
1450: default:
1451: errorStackmachine("Usage:supercontext");
1452: break;
1453: }
1454: break;
1455:
1456: case Ssendmsg:
1457: /* ob2 { .........} sendmsg */
1458: /* cf. debug/kobj.sm1 */
1459: ob1 = Kpop();
1460: ob2 = Kpop();
1461: switch(ob1.tag) {
1462: case SexecutableArray: break;
1463: default: errorStackmachine("Usage:sendmsg");
1464: }
1465: ccflag = 0;
1466: if (ob2.tag == Sarray ) {
1467: if (getoaSize(ob2) >= 1) {
1.4 takayama 1468: ob3 = getoa(ob2,0);
1469: if (ectag(ob3) == CLASSNAME_CONTEXT) {
1470: contextControl(CCPUSH); ccflag = 1; /* push the current context. */
1471: CurrentContextp = (struct context *)ecbody(ob3);
1472: }
1.1 maekawa 1473: }
1474: }
1475: if (!ccflag) {
1476: contextControl(CCPUSH); ccflag = 1;
1477: CurrentContextp = PrimitiveContextp;
1478: }
1479: /* normal exec. */
1480: Kpush(ob2);
1.15 takayama 1481: status = executeExecutableArray(ob1,(char *)NULL,0);
1.13 takayama 1482:
1.1 maekawa 1483: if (ccflag) {
1484: contextControl(CCPOP); ccflag = 0; /* recover the Current context. */
1485: }
1.14 takayama 1486:
1.1 maekawa 1487: break;
1488: case Ssendmsg2:
1489: /* ob2 ob4 { .........} sendmsg2 */
1490: /* Context is determined by ob2 or ob1 */
1491: ob1 = Kpop();
1492: ob4 = Kpop();
1493: ob2 = Kpop();
1494: switch(ob1.tag) {
1495: case SexecutableArray: break;
1496: default: errorStackmachine("Usage:sendmsg2");
1497: }
1498: ccflag = 0;
1499: if (ob2.tag == Sarray ) {
1500: if (getoaSize(ob2) >= 1) {
1.4 takayama 1501: ob3 = getoa(ob2,0);
1502: if (ectag(ob3) == CLASSNAME_CONTEXT) {
1503: contextControl(CCPUSH); ccflag = 1; /* push the current context. */
1504: CurrentContextp = (struct context *)ecbody(ob3);
1505: }
1.1 maekawa 1506: }
1507: }
1508: if (!ccflag && ob4.tag == Sarray) {
1509: if (getoaSize(ob4) >= 1) {
1.4 takayama 1510: ob3 = getoa(ob4,0);
1511: if (ectag(ob3) == CLASSNAME_CONTEXT) {
1512: contextControl(CCPUSH); ccflag = 1; /* push the current context. */
1513: CurrentContextp = (struct context *)ecbody(ob3);
1514: }
1.1 maekawa 1515: }
1516: }
1517: if (!ccflag) {
1518: contextControl(CCPUSH); ccflag = 1;
1519: CurrentContextp = PrimitiveContextp;
1520: }
1521: /* normal exec. */
1522: Kpush(ob2); Kpush(ob4);
1.14 takayama 1523:
1524: /* We cannot use executeExecutableArray(ob1,(char *)NULL) because of
1525: the quote mode. Think about it later. */
1.1 maekawa 1526: tokenArray = ob1.lc.tokenArray;
1527: size = ob1.rc.ival;
1528: for (i=0; i<size; i++) {
1529: token = tokenArray[i];
1.10 takayama 1530: InSendmsg2 = 1;
1.1 maekawa 1531: status = executeToken(token);
1.10 takayama 1532: InSendmsg2 = 0;
1.13 takayama 1533:
1534: if (status & STATUS_INFIX) {
1535: if (status & DO_QUOTE) errorStackmachine("infix op with DO_QUOTE\n");
1536: if (i == size-1) errorStackmachine("infix operator at the end(sendmsg2).\n");
1537: infixOn = 1; infixToken = tokenArray[i];
1538: infixToken.tflag |= NO_DELAY; continue;
1539: }else if (infixOn) {
1540: infixOn = 0; status = executeToken(infixToken);
1541: if (status & STATUS_BREAK) break;
1542: }
1543:
1544: if (QuoteMode && (status & DO_QUOTE)) {
1.8 takayama 1545: /* generate tree object, for kan/k0 */
1546: struct object qob;
1547: struct object qattr;
1548: struct object qattr2;
1549: if (i==0) { Kpop(); Kpop();}
1550: qob = newObjectArray(3);
1551: qattr = newObjectArray(1);
1552: qattr2 = newObjectArray(2);
1553: /* Set the node name of the tree. */
1554: if (token.kind == ID) {
1555: putoa(qob,0,KpoString(token.token));
1556: }else{
1557: putoa(qob,0,KpoString("unknown"));
1558: }
1559: /* Set the attibute list; class=className */
1560: if (ob2.tag == Sdollar) {
1.11 takayama 1561: putoa(qattr2,0,KpoString("cd"));
1.8 takayama 1562: putoa(qattr2,1,ob2);
1563: }else{
1.11 takayama 1564: putoa(qattr2,0,KpoString("class"));
1.8 takayama 1565: putoa(qattr2,1,KpoString(CurrentContextp->contextName));
1566: }
1567: putoa(qattr,0,qattr2);
1568: putoa(qob,1,qattr);
1569: putoa(qob,2,ob4); /* Argument */
1570: qob = KpoTree(qob);
1571: Kpush(qob);
1.13 takayama 1572: } else if (status & STATUS_BREAK) break;
1573:
1.1 maekawa 1574: }
1575: if (ccflag) {
1576: contextControl(CCPOP); ccflag = 0;
1577: /* recover the Current context. */
1578: /* Note that it is not recovered in case of error. */
1579: }
1580:
1581: break;
1582: case Sprimmsg:
1583: /* { .........} primmsg */
1584: /* Context is PrimitiveContext. */
1585: ob1 = Kpop();
1586: switch(ob1.tag) {
1587: case SexecutableArray: break;
1588: default: errorStackmachine("Usage:primmsg");
1589: }
1590: contextControl(CCPUSH); ccflag = 1;
1591: CurrentContextp = PrimitiveContextp;
1592: /* normal exec. */
1.15 takayama 1593: status = executeExecutableArray(ob1,(char *)NULL,0);
1.1 maekawa 1594: contextControl(CCPOP); /* recover the Current context. */
1595: break;
1596:
1597: case Ssupmsg2:
1598: /* ob2 ob4 { .........} supmsg2 */
1599: /* Context is super class of ob2 */
1600: ob1 = Kpop();
1601: ob4 = Kpop();
1602: ob2 = Kpop();
1603: switch(ob1.tag) {
1604: case SexecutableArray: break;
1605: default: errorStackmachine("Usage:supmsg2");
1606: }
1607: ccflag = 0;
1608: if (ob2.tag == Sarray ) {
1609: if (getoaSize(ob2) >= 1) {
1.4 takayama 1610: ob3 = getoa(ob2,0);
1611: if (ectag(ob3) == CLASSNAME_CONTEXT) {
1612: if (((struct context *)ecbody(ob3))->super == NULL) {
1613: errorStackmachine("supmsg2: SuperClass is NIL.");
1614: }
1615: contextControl(CCPUSH); ccflag = 1; /* push the current context. */
1616: CurrentContextp = ((struct context *)ecbody(ob3))->super;
1617: }
1.1 maekawa 1618: }
1619: }
1620: if (!ccflag && (ob4.tag == Sarray) ) {
1621: if (getoaSize(ob4) >= 1) {
1.4 takayama 1622: ob3 = getoa(ob4,0);
1623: if (ectag(ob3) == CLASSNAME_CONTEXT) {
1624: if (((struct context *)ecbody(ob3))->super == NULL) {
1625: errorStackmachine("supmsg2: SuperClass is NIL.");
1626: }
1627: contextControl(CCPUSH); ccflag = 1; /* push the current context. */
1628: CurrentContextp = ((struct context *)ecbody(ob3))->super;
1629: }
1.1 maekawa 1630: }
1631: }
1632: if (!ccflag) {
1633: contextControl(CCPUSH); ccflag = 1;
1634: CurrentContextp = PrimitiveContextp;
1635: }
1636: /* normal exec. */
1637: Kpush(ob2); Kpush(ob4);
1.15 takayama 1638: status = executeExecutableArray(ob1,(char *)NULL,0);
1.1 maekawa 1639: if (ccflag) {
1640: contextControl(CCPOP); ccflag = 0; /* recover the Current context. */
1641: }
1642:
1643: break;
1644:
1645: case Serror:
1646: ob1 = peek(0);
1647: if (ob1.tag == Sdollar) {
1648: /* compose error message */
1649: ob = Kpop();
1650: str = (char *) sGC_malloc(sizeof(char)*(strlen("error operator : ")+
1.4 takayama 1651: strlen(KopString(ob1))+ 10));
1.1 maekawa 1652: if (str == NULL) errorStackmachine("No more memory.");
1653: strcpy(str,"error operator : ");
1654: strcat(str,KopString(ob1));
1655: errorStackmachine(str);
1656: }else{
1657: errorStackmachine("error operator.");
1658: }
1659: break;
1660: case Smpzext:
1661: ob1 = Kpop();
1662: Kpush(KmpzExtension(ob1));
1663: break;
1664:
1665: case Scclass:
1666: ob3 = Kpop();
1667: ob2 = Kpop();
1668: ob1 = Kpop();
1669: /* [class-tag super-obj] size [class-tag] cclass */
1670: Kpush(KcreateClassIncetance(ob1,ob2,ob3));
1671: break;
1672:
1673: case Stest:
1674: /* test is used for a test of a new function. */
1675: ob2 = Kpop();
1676: ob1 = Kpop();
1677: Kpush(hilberto(ob1,ob2));
1678: /*
1.4 takayama 1679: {
1680: ob1 = Kpop();
1681: Kpush(test(ob1));
1.1 maekawa 1682:
1.4 takayama 1683: }
1.1 maekawa 1684: */
1.9 takayama 1685: break;
1686:
1687: case Soxshell:
1688: ob1 = Kpop();
1689: Kpush(KoxShell(ob1));
1.1 maekawa 1690: break;
1.5 takayama 1691:
1692: case Stlimit:
1693: /* { } time tlimit */
1694: ob2 = Kpop();
1695: ob1 = Kpop();
1696: switch(ob2.tag) {
1697: case Sinteger: break;
1698: default: errorStackmachine("Usage:tlimit"); break;
1699: }
1700: switch(ob1.tag) {
1701: case SexecutableArray: break;
1702: default:
1703: errorStackmachine("Usage:tlimit");
1704: break;
1705: }
1706: n = ob2.lc.ival;
1707: if (n > 0) {
1708: signal(SIGALRM,ctrlC); alarm((unsigned int) n);
1.15 takayama 1709: status = executeExecutableArray(ob1,(char *)NULL,0);
1.5 takayama 1710: cancelAlarm();
1711: }else{
1712: before_real = time(&before_real);
1713: times(&before);
1.15 takayama 1714: status = executeExecutableArray(ob1,(char *)NULL,0);
1.5 takayama 1715: times(&after);
1716: after_real = time(&after_real);
1717: ob1 = newObjectArray(3);
1718: putoa(ob1,0,KpoInteger((int) after.tms_utime - before.tms_utime));
1719: putoa(ob1,1,KpoInteger((int) after.tms_stime - before.tms_stime));
1720: putoa(ob1,2,KpoInteger((int) (after_real-before_real)));
1721: Kpush(ob1);
1722: }
1723: break;
1.1 maekawa 1724:
1725:
1726: default:
1727: errorStackmachine("Unknown Soperator type. \n");
1728: }
1729: return(0); /* normal exit */
1730: }
1731:
1732:
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