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