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