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