[BACK]Return to primitive.c CVS log [TXT][DIR] Up to [local] / OpenXM / src / kan96xx / Kan

Annotation of OpenXM/src/kan96xx/Kan/primitive.c, Revision 1.7

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

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>