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