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