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