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