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