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