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