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