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