Annotation of OpenXM/src/kan96xx/Kan/primitive.c, Revision 1.5
1.5 ! takayama 1: /* $OpenXM: OpenXM/src/kan96xx/Kan/primitive.c,v 1.4 2001/05/04 01:06:25 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:
1286: ob5 = Kpop(); ob4=Kpop(); ob3=Kpop(); ob2=Kpop(); ob1=Kpop();
1287: KsetUpRing(ob1,ob2,ob3,ob4,ob5);
1288: break;
1289: case Sshow_ring:
1290: KshowRing(CurrentRingp);
1291: break;
1292: case Sswitch_function:
1293: ob1 = Kpop();
1294: ob2 = Kpop();
1295: ob3 = KswitchFunction(ob2,ob1);
1296: if (!isNullObject(ob3)) {
1297: Kpush(ob3);
1298: }
1299: break;
1300: case Sprint_switch_status:
1301: KprintSwitchStatus();
1302: break;
1303: case Sreplace:
1304: ob2 = Kpop();
1305: ob1 = Kpop();
1306: Kpush(KoReplace(ob1,ob2));
1307: break;
1308:
1309: case Scoefficients:
1310: ob2 = Kpop();
1311: ob1 = Kpop();
1312: Kpush(Kparts(ob1,ob2));
1313: break;
1314:
1315: case Scoeff2:
1316: ob2 = Kpop();
1317: ob1 = Kpop();
1318: Kpush(Kparts2(ob1,ob2));
1319: break;
1320:
1321: case Sdegree:
1322: ob2 = Kpop();
1323: ob1 = Kpop();
1324: Kpush(Kdegree(ob1,ob2));
1325: break;
1326: case Sspol:
1327: ob2 = Kpop();
1328: ob1 = Kpop();
1329: Kpush(Ksp(ob1,ob2));
1330: break;
1331:
1332: case Seval:
1333: ob1 = Kpop();
1334: Kpush(Keval(ob1));
1335: break;
1336:
1337: case Sreduction:
1338: ob2 = Kpop();
1339: ob1 = Kpop();
1340: Kpush(Kreduction(ob1,ob2));
1341: break;
1342:
1343: case Sgroebner :
1344: ob1 = Kpop();
1345: Kpush(Kgroebner(ob1));
1346: break;
1347:
1348: case Shomogenize :
1349: ob1 = Kpop();
1350: Kpush(homogenizeObject(ob1,&i));
1351: break;
1352:
1353: case Sprincipal :
1354: ob1 = Kpop();
1355: Kpush(oPrincipalPart(ob1));
1356: break;
1357:
1358: case Sinit:
1359: ob2 = Kpop();
1360: if (ob2.tag != Sarray) {
1361: Kpush(Khead(ob2));
1362: }else{
1363: ob1 = Kpop();
1364: Kpush(oInitW(ob1,ob2));
1365: }
1366: break;
1367:
1368: case Sextension:
1369: ob1 = Kpop();
1370: Kpush(Kextension(ob1));
1371: break;
1372:
1373: case Sgbext:
1374: ob1 = Kpop();
1375: Kpush(KgbExtension(ob1));
1376: break;
1377:
1378: case Snewstack:
1379: ob1 = Kpop();
1380: switch(ob1.tag) {
1381: case Sinteger:
1382: Kpush(newOperandStack(ob1.lc.ival));
1383: break;
1384: default:
1385: errorStackmachine("Usage:newstack");
1386: break;
1387: }
1388: break;
1389:
1390: case Ssetstack:
1391: ob1 = Kpop();
1392: switch(ob1.tag) {
1393: case Sclass:
1394: setOperandStack(ob1);
1395: break;
1396: default:
1397: errorStackmachine("Usage:setstack");
1398: break;
1399: }
1400: break;
1401:
1402: case Sstdstack:
1403: stdOperandStack();
1404: break;
1405:
1406: case Slc:
1407: ob1 = Kpop();
1408: switch (ob1.tag) {
1409: case Sclass:
1410: Kpush(KpoInteger(ob1.lc.ival));
1411: break;
1412: default:
1413: errorStackmachine("Usage:lc");
1414: break;
1415: }
1416: break;
1417:
1418: case Src:
1419: ob1 = Kpop();
1420: switch (ob1.tag) {
1421: case Sclass:
1422: if (ClassTypes[ob1.lc.ival] == CLASS_OBJ) {
1.4 takayama 1423: Kpush(*(ob1.rc.op));
1.1 maekawa 1424: }else{
1.4 takayama 1425: warningStackmachine("<<obj rc >> works only for a class object with CLASS_OBJ attribute.\n");
1426: Kpush(ob1);
1.1 maekawa 1427: }
1428: break;
1429: default:
1430: errorStackmachine("Usage:rc");
1431: break;
1432: }
1433: break;
1434:
1435: case Snewcontext:
1436: ob1 = Kpop();
1437: ob2 = Kpop();
1438: switch(ob1.tag) {
1439: case Sclass:
1440: if (ob2.tag == Sdollar) {
1.4 takayama 1441: Kpush(KnewContext(ob1,KopString(ob2)));
1.1 maekawa 1442: }else errorStackmachine("Usage:newcontext");
1443: break;
1444: default:
1445: errorStackmachine("Usage:newcontext");
1446: break;
1447: }
1448: break;
1449:
1450: case Ssetcontext:
1451: ob1 = Kpop();
1452: switch(ob1.tag) {
1453: case Sclass:
1454: KsetContext(ob1);
1455: break;
1456: default:
1457: errorStackmachine("Usage:setcontext");
1458: break;
1459: }
1460: break;
1461:
1462: case Ssupercontext:
1463: ob1 = Kpop();
1464: switch(ob1.tag) {
1465: case Sclass:
1466: Kpush(getSuperContext(ob1));
1467: break;
1468: default:
1469: errorStackmachine("Usage:supercontext");
1470: break;
1471: }
1472: break;
1473:
1474: case Ssendmsg:
1475: /* ob2 { .........} sendmsg */
1476: /* cf. debug/kobj.sm1 */
1477: ob1 = Kpop();
1478: ob2 = Kpop();
1479: switch(ob1.tag) {
1480: case SexecutableArray: break;
1481: default: errorStackmachine("Usage:sendmsg");
1482: }
1483: ccflag = 0;
1484: if (ob2.tag == Sarray ) {
1485: if (getoaSize(ob2) >= 1) {
1.4 takayama 1486: ob3 = getoa(ob2,0);
1487: if (ectag(ob3) == CLASSNAME_CONTEXT) {
1488: contextControl(CCPUSH); ccflag = 1; /* push the current context. */
1489: CurrentContextp = (struct context *)ecbody(ob3);
1490: }
1.1 maekawa 1491: }
1492: }
1493: if (!ccflag) {
1494: contextControl(CCPUSH); ccflag = 1;
1495: CurrentContextp = PrimitiveContextp;
1496: }
1497: /* normal exec. */
1498: Kpush(ob2);
1499: tokenArray = ob1.lc.tokenArray;
1500: size = ob1.rc.ival;
1501: for (i=0; i<size; i++) {
1502: token = tokenArray[i];
1503: status = executeToken(token);
1504: if (status != 0) break;
1505: }
1506: if (ccflag) {
1507: contextControl(CCPOP); ccflag = 0; /* recover the Current context. */
1508: }
1509:
1510: break;
1511: case Ssendmsg2:
1512: /* ob2 ob4 { .........} sendmsg2 */
1513: /* Context is determined by ob2 or ob1 */
1514: ob1 = Kpop();
1515: ob4 = Kpop();
1516: ob2 = Kpop();
1517: switch(ob1.tag) {
1518: case SexecutableArray: break;
1519: default: errorStackmachine("Usage:sendmsg2");
1520: }
1521: ccflag = 0;
1522: if (ob2.tag == Sarray ) {
1523: if (getoaSize(ob2) >= 1) {
1.4 takayama 1524: ob3 = getoa(ob2,0);
1525: if (ectag(ob3) == CLASSNAME_CONTEXT) {
1526: contextControl(CCPUSH); ccflag = 1; /* push the current context. */
1527: CurrentContextp = (struct context *)ecbody(ob3);
1528: }
1.1 maekawa 1529: }
1530: }
1531: if (!ccflag && ob4.tag == Sarray) {
1532: if (getoaSize(ob4) >= 1) {
1.4 takayama 1533: ob3 = getoa(ob4,0);
1534: if (ectag(ob3) == CLASSNAME_CONTEXT) {
1535: contextControl(CCPUSH); ccflag = 1; /* push the current context. */
1536: CurrentContextp = (struct context *)ecbody(ob3);
1537: }
1.1 maekawa 1538: }
1539: }
1540: if (!ccflag) {
1541: contextControl(CCPUSH); ccflag = 1;
1542: CurrentContextp = PrimitiveContextp;
1543: }
1544: /* normal exec. */
1545: Kpush(ob2); Kpush(ob4);
1546: tokenArray = ob1.lc.tokenArray;
1547: size = ob1.rc.ival;
1548: for (i=0; i<size; i++) {
1549: token = tokenArray[i];
1550: status = executeToken(token);
1551: if (status != 0) break;
1552: }
1553: if (ccflag) {
1554: contextControl(CCPOP); ccflag = 0;
1555: /* recover the Current context. */
1556: /* Note that it is not recovered in case of error. */
1557: }
1558:
1559: break;
1560: case Sprimmsg:
1561: /* { .........} primmsg */
1562: /* Context is PrimitiveContext. */
1563: ob1 = Kpop();
1564: switch(ob1.tag) {
1565: case SexecutableArray: break;
1566: default: errorStackmachine("Usage:primmsg");
1567: }
1568: contextControl(CCPUSH); ccflag = 1;
1569: CurrentContextp = PrimitiveContextp;
1570: /* normal exec. */
1571: tokenArray = ob1.lc.tokenArray;
1572: size = ob1.rc.ival;
1573: for (i=0; i<size; i++) {
1574: token = tokenArray[i];
1575: status = executeToken(token);
1576: if (status != 0) break;
1577: }
1578:
1579: contextControl(CCPOP); /* recover the Current context. */
1580: break;
1581:
1582: case Ssupmsg2:
1583: /* ob2 ob4 { .........} supmsg2 */
1584: /* Context is super class of ob2 */
1585: ob1 = Kpop();
1586: ob4 = Kpop();
1587: ob2 = Kpop();
1588: switch(ob1.tag) {
1589: case SexecutableArray: break;
1590: default: errorStackmachine("Usage:supmsg2");
1591: }
1592: ccflag = 0;
1593: if (ob2.tag == Sarray ) {
1594: if (getoaSize(ob2) >= 1) {
1.4 takayama 1595: ob3 = getoa(ob2,0);
1596: if (ectag(ob3) == CLASSNAME_CONTEXT) {
1597: if (((struct context *)ecbody(ob3))->super == NULL) {
1598: errorStackmachine("supmsg2: SuperClass is NIL.");
1599: }
1600: contextControl(CCPUSH); ccflag = 1; /* push the current context. */
1601: CurrentContextp = ((struct context *)ecbody(ob3))->super;
1602: }
1.1 maekawa 1603: }
1604: }
1605: if (!ccflag && (ob4.tag == Sarray) ) {
1606: if (getoaSize(ob4) >= 1) {
1.4 takayama 1607: ob3 = getoa(ob4,0);
1608: if (ectag(ob3) == CLASSNAME_CONTEXT) {
1609: if (((struct context *)ecbody(ob3))->super == NULL) {
1610: errorStackmachine("supmsg2: SuperClass is NIL.");
1611: }
1612: contextControl(CCPUSH); ccflag = 1; /* push the current context. */
1613: CurrentContextp = ((struct context *)ecbody(ob3))->super;
1614: }
1.1 maekawa 1615: }
1616: }
1617: if (!ccflag) {
1618: contextControl(CCPUSH); ccflag = 1;
1619: CurrentContextp = PrimitiveContextp;
1620: }
1621: /* normal exec. */
1622: Kpush(ob2); Kpush(ob4);
1623: tokenArray = ob1.lc.tokenArray;
1624: size = ob1.rc.ival;
1625: for (i=0; i<size; i++) {
1626: token = tokenArray[i];
1627: status = executeToken(token);
1628: if (status != 0) break;
1629: }
1630: if (ccflag) {
1631: contextControl(CCPOP); ccflag = 0; /* recover the Current context. */
1632: }
1633:
1634: break;
1635:
1636: case Serror:
1637: ob1 = peek(0);
1638: if (ob1.tag == Sdollar) {
1639: /* compose error message */
1640: ob = Kpop();
1641: str = (char *) sGC_malloc(sizeof(char)*(strlen("error operator : ")+
1.4 takayama 1642: strlen(KopString(ob1))+ 10));
1.1 maekawa 1643: if (str == NULL) errorStackmachine("No more memory.");
1644: strcpy(str,"error operator : ");
1645: strcat(str,KopString(ob1));
1646: errorStackmachine(str);
1647: }else{
1648: errorStackmachine("error operator.");
1649: }
1650: break;
1651: case Smpzext:
1652: ob1 = Kpop();
1653: Kpush(KmpzExtension(ob1));
1654: break;
1655:
1656: case Scclass:
1657: ob3 = Kpop();
1658: ob2 = Kpop();
1659: ob1 = Kpop();
1660: /* [class-tag super-obj] size [class-tag] cclass */
1661: Kpush(KcreateClassIncetance(ob1,ob2,ob3));
1662: break;
1663:
1664: case Stest:
1665: /* test is used for a test of a new function. */
1666: ob2 = Kpop();
1667: ob1 = Kpop();
1668: Kpush(hilberto(ob1,ob2));
1669: /*
1.4 takayama 1670: {
1671: ob1 = Kpop();
1672: Kpush(test(ob1));
1.1 maekawa 1673:
1.4 takayama 1674: }
1.1 maekawa 1675: */
1676: break;
1.5 ! takayama 1677:
! 1678: case Stlimit:
! 1679: /* { } time tlimit */
! 1680: ob2 = Kpop();
! 1681: ob1 = Kpop();
! 1682: switch(ob2.tag) {
! 1683: case Sinteger: break;
! 1684: default: errorStackmachine("Usage:tlimit"); break;
! 1685: }
! 1686: switch(ob1.tag) {
! 1687: case SexecutableArray: break;
! 1688: default:
! 1689: errorStackmachine("Usage:tlimit");
! 1690: break;
! 1691: }
! 1692: tokenArray = ob1.lc.tokenArray;
! 1693: size = ob1.rc.ival;
! 1694: n = ob2.lc.ival;
! 1695: i = 0;
! 1696: if (n > 0) {
! 1697: signal(SIGALRM,ctrlC); alarm((unsigned int) n);
! 1698: for (i=0; i<size; i++) {
! 1699: token = tokenArray[i];
! 1700: status = executeToken(token);
! 1701: }
! 1702: cancelAlarm();
! 1703: }else{
! 1704: before_real = time(&before_real);
! 1705: times(&before);
! 1706: for (i=0; i<size; i++) {
! 1707: token = tokenArray[i];
! 1708: status = executeToken(token);
! 1709: }
! 1710: times(&after);
! 1711: after_real = time(&after_real);
! 1712: ob1 = newObjectArray(3);
! 1713: putoa(ob1,0,KpoInteger((int) after.tms_utime - before.tms_utime));
! 1714: putoa(ob1,1,KpoInteger((int) after.tms_stime - before.tms_stime));
! 1715: putoa(ob1,2,KpoInteger((int) (after_real-before_real)));
! 1716: Kpush(ob1);
! 1717: }
! 1718: break;
1.1 maekawa 1719:
1720:
1721: default:
1722: errorStackmachine("Unknown Soperator type. \n");
1723: }
1724: return(0); /* normal exit */
1725: }
1726:
1727:
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