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