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