===================================================================
RCS file: /home/cvs/OpenXM/src/kan96xx/Kan/stackmachine.c,v
retrieving revision 1.1
retrieving revision 1.35
diff -u -p -r1.1 -r1.35
--- OpenXM/src/kan96xx/Kan/stackmachine.c	1999/10/08 02:12:01	1.1
+++ OpenXM/src/kan96xx/Kan/stackmachine.c	2006/02/02 04:16:49	1.35
@@ -1,6 +1,9 @@
+/* $OpenXM: OpenXM/src/kan96xx/Kan/stackmachine.c,v 1.34 2006/02/01 00:30:05 takayama Exp $ */
 /*   stackmachin.c */
 
 #include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
 #include "datatype.h"
 #include "stackm.h"
 #include "extern.h"
@@ -13,7 +16,8 @@
 /* #define OPERAND_STACK_SIZE  2000 */
 #define OPERAND_STACK_SIZE 30000 
 #define SYSTEM_DICTIONARY_SIZE 200
-#define USER_DICTIONARY_SIZE   1223
+/* #define USER_DICTIONARY_SIZE   1223, 3581, 27449 */
+#define USER_DICTIONARY_SIZE  59359
 /* The value of USER_DICTIONARY_SIZE must be prime number, because of hashing
    method */
 #define ARGV_WORK_MAX  (AGLIMIT+100)
@@ -50,8 +54,10 @@ struct context *CurrentContextp = &StandardContext;
 struct context *PrimitiveContextp = &StandardContext;
 
 
-static struct object ObjTmp; /* for poor compiler */
+static struct object ObjTmp = OINIT; /* for poor compiler */
 
+int Calling_ctrlC_hook = 0;
+
 int StandardMacros = 1;
 int StartAFile = 0;
 char *StartFile;
@@ -70,14 +76,23 @@ static strToInteger(char *);
 static power(int s,int i);
 static void pstack(void);
 static struct object executableStringToExecutableArray(char *str);
+static int isThereExecutableArrayOnStack(int n);
 
 extern int SerialCurrent;
+extern int QuoteMode;
 
 int SGClock = 0;
 int UserCtrlC = 0;
 int OXlock = 0;
 int OXlockSaved = 0;
 
+char *UD_str;
+int  UD_attr;
+
+struct object *MsgStackTraceInArrayp = NULL;
+char *MsgStackTrace = NULL;
+char *MsgSourceTrace = NULL;
+
 struct object * newObject() 
 {
   struct object *r;
@@ -86,13 +101,14 @@ struct object * newObject() 
   r->tag = 0;
   (r->lc).ival = 0;
   (r->rc).ival = 0;
+  r->attr = NULL;
   return(r);
 }
 
 struct object newObjectArray(size) 
-int size;
+     int size;
 {
-  struct object rob;
+  struct object rob = OINIT;
   struct object *op;
   if (size < 0) return(NullObject);
   if (size > 0) {
@@ -108,15 +124,15 @@ int size;
 }
 
 isNullObject(obj)
-struct object obj;
+     struct object obj;
 {
   if (obj.tag == 0) return(1);
   else return(0);
 }
 
 int putSystemDictionary(str,ob)
-char *str;   /* key */
-struct object ob; /* value */
+     char *str;   /* key */
+     struct object ob; /* value */
 {
   int i;
   int j;
@@ -126,8 +142,8 @@ struct object ob; /* value */
     /*printf("Add %d %s\n",i,str);*/
     if (strcmp(str,(SystemDictionary[i]).key) > 0) {
       for (j=Sdp-1; j>=i+1; j--) {
-	(SystemDictionary[j+1]).key = (SystemDictionary[j]).key;
-	(SystemDictionary[j+1]).obj = (SystemDictionary[j]).obj;
+        (SystemDictionary[j+1]).key = (SystemDictionary[j]).key;
+        (SystemDictionary[j+1]).obj = (SystemDictionary[j]).obj;
       }
       (SystemDictionary[i+1]).key = str;
       (SystemDictionary[i+1]).obj = ob;
@@ -167,15 +183,15 @@ int findSystemDictionary(str)   
       return(0);
     } else if (first == last) {
       if (strcmp(str,(SystemDictionary[first]).key) == 0) {
-	return((SystemDictionary[first]).obj.lc.ival);
+        return((SystemDictionary[first]).obj.lc.ival);
       }else {
-	return(0);
+        return(0);
       }
     } else if (last - first == 1) { /* This case is necessary */
       if (strcmp(str,(SystemDictionary[first]).key) == 0) {
-	return((SystemDictionary[first]).obj.lc.ival);
+        return((SystemDictionary[first]).obj.lc.ival);
       }else if (strcmp(str,(SystemDictionary[last]).key) == 0) {
-	return((SystemDictionary[last]).obj.lc.ival);
+        return((SystemDictionary[last]).obj.lc.ival);
       }else return(0);
     }
 
@@ -192,10 +208,10 @@ int findSystemDictionary(str)   
 }
 
 int putUserDictionary(str,h0,h1,ob,dic)
-char *str;   /* key */
-int h0,h1;   /* Hash values of the key */
-struct object ob; /* value */
-struct dictionary *dic;
+     char *str;   /* key */
+     int h0,h1;   /* Hash values of the key */
+     struct object ob; /* value */
+     struct dictionary *dic;
 {
   int x,r;
   extern int Strict2;
@@ -213,7 +229,7 @@ struct dictionary *dic;
   }
   r = x;
   if (Strict2) {
-    switch((dic[x]).attr) {
+    switch(((dic[x]).attr) & (PROTECT | ABSOLUTE_PROTECT)) {
     case PROTECT:
       r = -PROTECT;   /* Protected, but we rewrite it. */
       break;
@@ -221,7 +237,7 @@ struct dictionary *dic;
       r = -ABSOLUTE_PROTECT;  /* Protected and we do not rewrite it. */
       return(r);
     default:
-      (dic[x]).attr = 0;
+      /* (dic[x]).attr = 0; */ /* It is not necesarry, I think. */
       break;
     }
   }
@@ -240,18 +256,23 @@ struct object KputUserDictionary(char *str,struct obje
 }
 
 struct object findUserDictionary(str,h0,h1,cp)   
-/* returns NoObject, if there is no item. */
-char *str;    /* key */
-int h0,h1;    /* The hashing values of the key. */
-struct context *cp;
+     /* returns NoObject, if there is no item. */
+     char *str;    /* key */
+     int h0,h1;    /* The hashing values of the key. */
+     struct context *cp;
+	 /* Set char *UD_str, int UD_attr (attributes) */
 {
   int x;
   struct dictionary *dic;
+  extern char *UD_str;
+  extern int UD_attr;
+  UD_str = NULL; UD_attr = -1;
   dic = cp->userDictionary;
   x = h0;
   while (1) {
     if ((dic[x]).key == EMPTY) { break; }
     if (strcmp((dic[x]).key,str) == 0) {
+	  UD_str = (dic[x]).key; UD_attr = (dic[x]).attr;
       return( (dic[x]).obj );
     }
     x = (x+h1) % USER_DICTIONARY_SIZE;
@@ -269,10 +290,10 @@ struct object KfindUserDictionary(char *str) {
 }
 
 int putUserDictionary2(str,h0,h1,attr,dic)
-char *str;   /* key */
-int h0,h1;   /* Hash values of the key */
-int attr;    /* attribute field */
-struct dictionary *dic;
+     char *str;   /* key */
+     int h0,h1;   /* Hash values of the key */
+     int attr;    /* attribute field */
+     struct dictionary *dic;
 {
   int x;
   int i;
@@ -282,6 +303,12 @@ struct dictionary *dic;
     }
     return(0);
   }
+  if (OR_ATTR_FOR_ALL_WORDS & attr) {
+    for (i=0; i<USER_DICTIONARY_SIZE; i++) {
+      if ((dic[i]).key !=EMPTY) (dic[i]).attr |= attr&(~OR_ATTR_FOR_ALL_WORDS);
+    }
+    return(0);
+  }
   x = h0;
   if (str[0] == '\0') {
     errorKan1("%s\n","putUserDictionary2(): You are defining a value with the null key.");
@@ -300,17 +327,17 @@ struct dictionary *dic;
 
 
 int putPrimitiveFunction(str,number)
-char *str;
-int number;
+     char *str;
+     int number;
 {
-  struct object ob;
+  struct object ob = OINIT;
   ob.tag = Soperator;
   ob.lc.ival = number;
   return(putSystemDictionary(str,ob));
 }
 
 struct tokens lookupTokens(t)
-struct tokens t;
+     struct tokens t;
 {
   struct object *left;
   struct object *right;
@@ -326,7 +353,7 @@ struct tokens t;
 }
   
 struct object lookupLiteralString(s)
-char *s; /* s must be a literal string */
+     char *s; /* s must be a literal string */
 {
   struct object ob;
   ob.tag = Slist;
@@ -340,20 +367,20 @@ char *s; /* s must be a literal string */
 
 
 int hash0(str)
-char *str;
+     char *str;
 {
   int h=0;
   while (*str != '\0') {
-    h = ((h*128)+(*str)) % USER_DICTIONARY_SIZE;
+    h = ((h*128)+((unsigned char)(*str))) % USER_DICTIONARY_SIZE;
     str++;
   }
   return(h);
 }
 
 int hash1(str)
-char *str;
+     char *str;
 {
-  return(8-(str[0]%8));
+  return(8-((unsigned char)(str[0])%8));
 }
 
 void hashInitialize(struct dictionary *dic)
@@ -365,7 +392,7 @@ void hashInitialize(struct dictionary *dic)
 }
 
 static isInteger(str)
-char *str;
+     char *str;
 {
   int i;
   int n;
@@ -386,7 +413,7 @@ char *str;
 }
 
 static strToInteger(str)
-char *str;
+     char *str;
 {
   int i;
   int n;
@@ -407,15 +434,15 @@ char *str;
 }
 
 static power(s,i)
-int s;
-int i;
+     int s;
+     int i;
 {
   if (i == 0) return 1;
   else return( s*power(s,i-1) );
 }
 
 int Kpush(ob)
-struct object ob;     
+     struct object ob;     
 {
   OperandStack[Osp++] = ob;
   if (Osp >= OspMax) {
@@ -436,7 +463,7 @@ struct object Kpop()
 }
 
 struct object peek(k)
-int k;
+     int k;
 {
   if ((Osp-k-1) < 0) {
     return( NullObject );
@@ -445,11 +472,37 @@ int k;
   }
 }
 
+static int isThereExecutableArray(struct object ob) {
+  int n,i;
+  struct object otmp = OINIT;
+  if (ob.tag == SexecutableArray) return(1);
+  if (ob.tag == Sarray) {
+    n = getoaSize(ob);
+    for (i=0; i<n; i++) {
+      otmp = getoa(ob,i);
+      if (isThereExecutableArray(otmp)) return(1);
+    }
+    return(0);
+  }
+  /* Class and list is not checked, since there is no parser
+     to directory translte these objects. */
+  return(0);
+}
+static int isThereExecutableArrayOnStack(int n) {
+  int i;
+  struct object ob = OINIT;
+  for (i=0; i<n; i++) {
+    if (Osp-i-1 < 0) return(0);
+    ob = peek(i);
+    if (isThereExecutableArray(ob)) return(1); 
+  }
+  return(0);
+}
 
 struct object newOperandStack(int size)
 {
   struct operandStack *os ;
-  struct object ob;
+  struct object ob = OINIT;
   os = (struct operandStack *)sGC_malloc(sizeof(struct operandStack));
   if (os == (void *)NULL) errorStackmachine("No more memory.");
   if (size <= 0) errorStackmachine("Size of stack must be more than 1.");
@@ -530,7 +583,7 @@ void KsetContext(struct object contextObj)  {
 
 
 struct object getSuperContext(struct object contextObj) {
-  struct object rob;
+  struct object rob = OINIT;
   struct context *cp;
   if (contextObj.tag != Sclass) {
     errorStackmachine("Usage:supercontext");
@@ -585,7 +638,7 @@ void contextControl(actionOfContextControl ctl) {
     
 
 int isLiteral(str)
-char *str;
+     char *str;
 {
   if (strlen(str) <2) return(0);
   else {
@@ -596,7 +649,7 @@ char *str;
 
 void printOperandStack() {
   int i;
-  struct object ob;
+  struct object ob = OINIT;
   int vs;
   vs = VerboseStack; VerboseStack = 2;
   for (i=Osp-1; i>=0; i--) {
@@ -610,7 +663,7 @@ void printOperandStack() {
     
 
 static initSystemDictionary()
- {
+{
   StandardStack.ostack = StandardStackA;
   StandardStack.sp = StandardStackP;
   StandardStack.size = OPERAND_STACK_SIZE;
@@ -625,14 +678,14 @@ static initSystemDictionary()
 
   KdefinePrimitiveFunctions();
 
- }
+}
 
 struct object showSystemDictionary(int f) {
   int i;
   int maxl;
   char format[1000];
   int nl;
-  struct object rob;
+  struct object rob = OINIT;
   rob = NullObject;
   if (f != 0) {
     rob = newObjectArray(Sdp);
@@ -676,7 +729,7 @@ int showUserDictionary() 
   for (i=0; i<USER_DICTIONARY_SIZE; i++) {
     if ((dic[i]).key != EMPTY) {
       if (strlen((dic[i]).key) >maxl)
-	maxl = strlen((dic[i]).key);
+        maxl = strlen((dic[i]).key);
     }
   }
   maxl += 3;
@@ -687,12 +740,12 @@ int showUserDictionary() 
     if ((dic[i]).key != EMPTY) {
       fprintf(Fstack,format,(dic[i]).key);
       /*{ char *sss; int ii,h0,h1;
-	sss = dic[i].key;
-	h0 = dic[i].h0;
-	h1 = dic[i].h1;
-	for (ii=0; ii<strlen(sss); ii++) fprintf(Fstack,"%x ",sss[ii]);
-	fprintf(Fstack,": h0=%d, h1=%d, %d\n",h0,h1,i);
-      }*/
+        sss = dic[i].key;
+        h0 = dic[i].h0;
+        h1 = dic[i].h1;
+        for (ii=0; ii<strlen(sss); ii++) fprintf(Fstack,"%x ",sss[ii]);
+        fprintf(Fstack,": h0=%d, h1=%d, %d\n",h0,h1,i);
+        }*/
       if (j % nl == nl-1) fprintf(Fstack,"\n");
       j++;
     }
@@ -702,10 +755,10 @@ int showUserDictionary() 
   
 
 static struct object executableStringToExecutableArray(s)
-char *s;
+     char *s;
 {
   struct tokens *tokenArray;
-  struct object ob;
+  struct object ob = OINIT;
   int i;
   int size;
   tokenArray = decomposeToTokens(s,&size);
@@ -716,7 +769,7 @@ char *s;
     if ( ((ob.lc.tokenArray)[i]).kind == EXECUTABLE_STRING) {
       ((ob.lc.tokenArray)[i]).kind = EXECUTABLE_ARRAY;
       ((ob.lc.tokenArray)[i]).object =
-	executableStringToExecutableArray(((ob.lc.tokenArray)[i]).token);
+        executableStringToExecutableArray(((ob.lc.tokenArray)[i]).token);
     }
   }
   return(ob);
@@ -724,17 +777,25 @@ char *s;
 /****************  stack machine **************************/
 void scanner() {
   struct tokens token;
-  struct object ob;
+  struct object ob = OINIT;
   extern int Quiet;
   extern void ctrlC();
-  int tmp;
+  int tmp, status;
   char *tmp2;
   extern int ErrorMessageMode;
   int jval;
+  extern int InSendmsg2;
+  int infixOn = 0;
+  struct tokens infixToken;
+  extern int RestrictedMode, RestrictedMode_saved;
   getokenSM(INIT);
   initSystemDictionary();
 
+#if defined(__CYGWIN__)
+  if (sigsetjmp(EnvOfStackMachine,1)) {
+#else
   if (setjmp(EnvOfStackMachine)) {
+#endif
     /* do nothing in the case of error */
     fprintf(stderr,"An error or interrupt in reading macros, files and command strings.\n");
     exit(10);
@@ -744,14 +805,14 @@ void scanner() {
   }
   
   /* setup quiet mode or not */
-  token.kind = EXECUTABLE_STRING;
+  token.kind = EXECUTABLE_STRING; token.tflag = 0;
   if (Quiet) {
     token.token = " /@@@.quiet 1 def ";
   }else {
     token.token = " /@@@.quiet 0 def ";
   }
   executeToken(token); /* execute startup commands */
-  token.kind = ID;
+  token.kind = ID; token.tflag = 0;
   token.token = "exec";
   token = lookupTokens(token); /* set hashing values */
   tmp = findSystemDictionary(token.token);
@@ -765,72 +826,98 @@ void scanner() {
   if (StartAFile) {
     tmp2 = StartFile;
     StartFile = (char *)sGC_malloc(sizeof(char)*(strlen(StartFile)+
-						40));
+                                                 40));
     sprintf(StartFile,"$%s$ run\n",tmp2);
-    token.kind = EXECUTABLE_STRING;
+    token.kind = EXECUTABLE_STRING; token.tflag = 0;
     token.token = StartFile;
-    executeToken(token);	/* execute startup commands */
-    token.kind = ID;
+    executeToken(token);    /* execute startup commands */
+    token.kind = ID; token.tflag = 0;
     token.token = "exec";
     token = lookupTokens(token); /* set hashing values */
     tmp = findSystemDictionary(token.token);
     ob.tag = Soperator;
     ob.lc.ival = tmp;
-    executePrimitive(ob);	/* exec */
+    executePrimitive(ob);   /* exec */
   }
   
   if (StartAString) {
-    token.kind = EXECUTABLE_STRING;
+    token.kind = EXECUTABLE_STRING;  token.tflag = 0;
     token.token = StartString;
-    executeToken(token);	/* execute startup commands */
-    token.kind = ID;
+    executeToken(token);    /* execute startup commands */
+    token.kind = ID; token.tflag = 0;
     token.token = "exec";
     token = lookupTokens(token); /* set hashing values */
     tmp = findSystemDictionary(token.token);
     ob.tag = Soperator;
     ob.lc.ival = tmp;
-    executePrimitive(ob);	/* exec */
+    executePrimitive(ob);   /* exec */
   }
   
   
   for (;;) {
+#if defined(__CYGWIN__)
+    if (jval=sigsetjmp(EnvOfStackMachine,1)) {
+#else
     if (jval=setjmp(EnvOfStackMachine)) {
+#endif
       /* ***  The following does not work properly.  ****
-      if (jval == 2) {
-	if (ErrorMessageMode == 1 || ErrorMessageMode == 2) {
-	  pushErrorStack(KnewErrorPacket(SerialCurrent,-1,"User interrupt by ctrl-C."));
-	}
-      }
-      **** */
+         if (jval == 2) {
+         if (ErrorMessageMode == 1 || ErrorMessageMode == 2) {
+         pushErrorStack(KnewErrorPacket(SerialCurrent,-1,"User interrupt by ctrl-C."));
+         }
+         }
+         **** */
       if (DebugStack >= 1) {
-	fprintf(Fstack,"\nscanner> ");
+        fprintf(Fstack,"\nscanner> ");
       }
-      KSexecuteString(" ctrlC-hook "); /* Execute User Defined functions. */
+      if (!Calling_ctrlC_hook) { /* to avoid recursive call of ctrlC-hook. */
+        Calling_ctrlC_hook = 1; RestrictedMode = 0;
+        KSexecuteString(" ctrlC-hook "); /* Execute User Defined functions. */
+        RestrictedMode = RestrictedMode_saved;
+      }
+      Calling_ctrlC_hook = 0;  
+      KSexecuteString(" (Computation is interrupted.) "); /* move to ctrlC-hook? */
+      InSendmsg2 = 0;
+      infixOn = 0;
+      continue ;
     } else {  }
     if (DebugStack >= 1) { printOperandStack(); }
-    token = getokenSM(GET);
-    if ((tmp=executeToken(token)) < 0) break;
-    /***if (tmp == 1) fprintf(stderr," --- exit --- \n");*/
+    token = getokenSM(GET); 
+    if ((status=executeToken(token)) < 0) break;
+    /***if (status == 1) fprintf(stderr," --- exit --- \n");*/
+    /* fprintf(stderr,"token.token=%s, status=%d, infixOn=%d\n",token.token,status,infixOn); */
+    if (status & STATUS_INFIX) {
+      infixOn = 1;  infixToken = token; infixToken.tflag |= NO_DELAY;
+    }else if (infixOn) {
+      infixOn = 0;
+      if ((status=executeToken(infixToken)) < 0) break;
+    }
   }
 }
 
 
 void ctrlC(sig)
-int sig;
+     int sig;
 {
   extern void ctrlC();
   extern int ErrorMessageMode;
   extern int SGClock;
   extern int UserCtrlC;
   extern int OXlock;
-  
+  extern int RestrictedMode, RestrictedMode_saved;
+
   signal(sig,SIG_IGN);
   /* see 133p */
+  RestrictedMode = RestrictedMode_saved;
+  cancelAlarm();
+  if (sig == SIGALRM) {
+    fprintf(stderr,"ctrlC by SIGALRM\n");
+  }
 
   if (SGClock) {
     UserCtrlC = 1;
     fprintf(stderr,"ctrl-c is locked because of gc.\n");
-    signal(SIGINT,ctrlC);
+    signal(sig,ctrlC);  if (sig == SIGALRM) alarm((unsigned int)10);
     return;
   }
   if (OXlock) {
@@ -843,13 +930,15 @@ int sig;
       unlockCtrlCForOx();
     }
     fprintf(stderr,"ctrl-c is locked because of ox lock %d.\n",UserCtrlC);
-    signal(SIGINT,ctrlC);
+    signal(sig,ctrlC);  if (sig == SIGALRM) alarm((unsigned int)10);
     return;
   }
   if (ErrorMessageMode != 1) {
+    (void *) traceShowStack();
     fprintf(Fstack,"User interruption by ctrl-C. We are in the top-level.\n");
     fprintf(Fstack,"Type in quit in order to exit sm1.\n");
   }
+  traceClearStack();
   if (GotoP) {
     fprintf(Fstack,"The interpreter was looking for the label <<%s>>. It is also aborted.\n",GotoLabel);
     GotoP = 0;
@@ -864,26 +953,33 @@ int sig;
   */
   getokenSM(INIT); /* It might fix the bug above. 1992/11/14 */
   signal(SIGINT,ctrlC);
+#if defined(__CYGWIN__)
+  siglongjmp(EnvOfStackMachine,2);
+#else
   longjmp(EnvOfStackMachine,2); /* returns 2 for ctrl-C */
+#endif
 }
 
 int executeToken(token)
-struct tokens token;
+     struct tokens token;
 {      
-  struct object ob;
+  struct object ob = OINIT;
   int primitive;
   int size;
   int status;
-  struct tokens *tokenArray;
   int i,h0,h1;
   extern int WarningMessageMode;
   extern int Strict;
+  extern int InSendmsg2;
+  extern int RestrictedMode, RestrictedMode_saved;
+  int localRestrictedMode_saved;
 
+  localRestrictedMode_saved = 0;
   if (GotoP) { /* for goto */
     if (token.kind == ID && isLiteral(token.token)) {
       if (strcmp(&((token.token)[1]),GotoLabel) == 0) {
-	GotoP = 0;
-	return(0); /* normal exit */
+        GotoP = 0;
+        return(0); /* normal exit */
       }
     }
     return(0);  /* normal exit */
@@ -905,8 +1001,8 @@ struct tokens token;
       strcpy(ob.lc.str, &((token.token)[1]));
 
       if (token.object.tag != Slist) {
-	fprintf(Fstack,"\n%%Warning: The hashing values for the <<%s>> are not set.\n",token.token);
-	token.object = lookupLiteralString(token.token);
+        fprintf(Fstack,"\n%%Warning: The hashing values for the <<%s>> are not set.\n",token.token);
+        token.object = lookupLiteralString(token.token);
       }
       ob.rc.op = token.object.lc.op;
       Kpush(ob);
@@ -917,46 +1013,75 @@ struct tokens token;
       Kpush(ob);
     } else {
       if (token.object.tag != Slist) {
-	fprintf(Fstack,"\n%%Warning: The hashing values for the <<%s>> are not set.\n",token.token);
-	token = lookupTokens(token);
+        fprintf(Fstack,"\n%%Warning: The hashing values for the <<%s>> are not set.\n",token.token);
+        token = lookupTokens(token);
       }
       h0 = ((token.object.lc.op)->lc).ival;
       h1 = ((token.object.lc.op)->rc).ival;
       ob=findUserDictionary(token.token,h0,h1,CurrentContextp);
       primitive = ((token.object.rc.op)->lc).ival;
+      if (!(token.tflag & NO_DELAY)) {
+        if ((ob.tag >= 0) && (UD_attr & ATTR_INFIX)) {
+          return STATUS_INFIX; 
+        }
+      }
       if (ob.tag >= 0) {
-	/* there is a definition in the user dictionary */
-	if (ob.tag == SexecutableArray) {
-	  tokenArray = ob.lc.tokenArray;
-	  size = ob.rc.ival;
-	  for (i=0; i<size; i++) {
-	    status = executeToken(tokenArray[i]);
-	    if (status != 0) return(status);
-	  }
-	}else {
-	  Kpush(ob);
-	}
+        /* there is a definition in the user dictionary */
+        if (ob.tag == SexecutableArray) {
+          if (RestrictedMode) {
+            if (UD_attr & ATTR_EXPORT) {
+              localRestrictedMode_saved = RestrictedMode; RestrictedMode = 0;
+              if (isThereExecutableArrayOnStack(5)) {
+				int i;
+                for (i=0; i<5; i++) { (void) Kpop(); }
+                errorStackmachine("Executable array is on the argument stack (restricted mode). They are automatically removed.\n");
+			  }
+            }else{
+              tracePushName(token.token);
+              errorStackmachine("You cannot execute this function in restricted mode.\n");
+            }
+          }
+
+          status = executeExecutableArray(ob,token.token,0);
+
+          if (localRestrictedMode_saved) RestrictedMode = localRestrictedMode_saved;
+          if ((status & STATUS_BREAK) || (status < 0)) return status;
+        }else {
+          Kpush(ob);
+        }
       } else if (primitive) { 
-	/* system operator */
-	ob.tag = Soperator;
-	ob.lc.ival = primitive;
-	return(executePrimitive(ob));
+        tracePushName(token.token);
+        /* system operator */
+        ob.tag = Soperator;
+        ob.lc.ival = primitive;
+        status = executePrimitive(ob);
+        tracePopName(); 
+        return(status);
       } else {
-	if (WarningMessageMode == 1 || WarningMessageMode == 2) {
-	  char tmpc[1024];
-	  if (strlen(token.token) < 900) {
-	    sprintf(tmpc,"\n%%Warning: The identifier <<%s>> is not in the system dictionary\n%%   nor in the user dictionaries. Push NullObject.\n",token.token);
-	  }else {strcpy(tmpc,"Warning: identifier is not in the dictionaries.");}
-	  pushErrorStack(KnewErrorPacket(SerialCurrent,-1,tmpc));
-	}
-	if (WarningMessageMode != 1) {
-	  fprintf(Fstack,"\n%%Warning: The identifier <<%s>> is not in the system dictionary\n%%   nor in the user dictionaries. Push NullObject.\n",token.token);
-	/*fprintf(Fstack,"(%d,%d)\n",h0,h1);*/
-	}
-	if (Strict) {
-	  errorStackmachine("Warning: identifier is not in the dictionaries");
-	}
-	Kpush(NullObject); 
+        if (QuoteMode) {
+          if (InSendmsg2) return(DO_QUOTE);
+          else {
+            Kpush(KpoString(token.token));
+            return(0); /* normal exit.*/
+          }
+		}
+        {    
+          char tmpc[1024];
+          if (strlen(token.token) < 900) {
+            sprintf(tmpc,"\n%%Warning: The identifier <<%s>> is not in the system dictionary\n%%   nor in the user dictionaries. Push NullObject.\n",token.token);
+          }else {strcpy(tmpc,"\n%%Warning: identifier is not in the dictionaries.\n");}
+          if (WarningMessageMode == 1 || WarningMessageMode == 2) {
+            pushErrorStack(KnewErrorPacket(SerialCurrent,-1,tmpc));
+          }
+          if (WarningMessageMode != 1) {
+            fprintf(Fstack,"%s",tmpc);
+            /*fprintf(Fstack,"(%d,%d)\n",h0,h1);*/
+          }
+          if (Strict) {
+            errorStackmachine(tmpc);
+          }
+          Kpush(NullObject); 
+        }
       }
     }
   } else if (token.kind == EXECUTABLE_STRING) {
@@ -982,13 +1107,18 @@ struct tokens token;
       
 
 errorStackmachine(str)
-char *str;
+     char *str;
 {
   int i,j,k;
   static char *u="Usage:";
   char message0[1024];
   char *message;
   extern int ErrorMessageMode;
+  extern int RestrictedMode, RestrictedMode_saved;
+  RestrictedMode = RestrictedMode_saved;
+  cancelAlarm();
+  MsgStackTrace = NULL;
+  MsgSourceTrace = NULL;
   if (ErrorMessageMode == 1 || ErrorMessageMode == 2) {
     pushErrorStack(KnewErrorPacket(SerialCurrent,-1,str));
   }
@@ -1002,27 +1132,31 @@ char *str;
     if (i==6) {
       fprintf(stderr,"ERROR(sm): \n");
       while (str[i] != '\0' && str[i] != ' ') {
-	i++;
+        i++;
       }
       if (str[i] == ' ') {
-	fprintf(stderr,"  %s\n",&(str[i+1]));
-	k = 0;
-	if (i-6 > 1022) message = (char *)sGC_malloc(sizeof(char)*i);
-	for (j=6; j<i ; j++) {
-	  message[k] = str[j];
-	  message[k+1] = '\0';
-	  k++;
-	}
-	Kusage2(stderr,message);
+        fprintf(stderr,"  %s\n",&(str[i+1]));
+        k = 0;
+        if (i-6 > 1022) message = (char *)sGC_malloc(sizeof(char)*i);
+        for (j=6; j<i ; j++) {
+          message[k] = str[j];
+          message[k+1] = '\0';
+          k++;
+        }
+        Kusage2(stderr,message);
       }else{
-	Kusage2(stderr,&(str[6]));
+        Kusage2(stderr,&(str[6]));
       }
     }else {
       fprintf(stderr,"ERROR(sm): ");
       fprintf(stderr,str);
     }
     fprintf(stderr,"\n");
+	MsgStackTraceInArrayp = traceNameStackToArrayp();
+    MsgStackTrace = traceShowStack(); 
+    MsgSourceTrace = traceShowScannerBuf();
   }
+  traceClearStack();
   if (GotoP) {
     fprintf(Fstack,"The interpreter was looking for the label <<%s>>. It is also aborted.\n",GotoLabel);
     GotoP = 0;
@@ -1034,7 +1168,7 @@ char *str;
 }
 
 warningStackmachine(str)
-char *str;
+     char *str;
 {
   extern int WarningMessageMode;
   extern int Strict;
@@ -1055,10 +1189,10 @@ char *str;
    you have to reset the jump buffer by setjmp(EnvOfStackMachine).
    cf. kxx/memo1.txt, kxx/stdserver00.c 1998, 2/6 */
 KSexecuteString(s)
-char *s;
+     char *s;
 {
   struct tokens token;
-  struct object ob;
+  struct object ob = OINIT;
   int tmp;
   extern int CatchCtrlC;
   int jval;
@@ -1068,6 +1202,7 @@ char *s;
   jmp_buf saved_EnvOfStackMachine;
   void (*sigfunc)();
   int localCatchCtrlC ;
+  extern int RestrictedMode, RestrictedMode_saved;
 
   localCatchCtrlC = CatchCtrlC;
   /* If CatchCtrlC is rewrited in this program,
@@ -1080,37 +1215,60 @@ char *s;
 
   if (KSPushEnvMode) {
     *saved_EnvOfStackMachine = *EnvOfStackMachine;
+#if defined(__CYGWIN__)
+    if (jval = sigsetjmp(EnvOfStackMachine,1)) {
+#else
     if (jval = setjmp(EnvOfStackMachine)) {
+#endif
       *EnvOfStackMachine = *saved_EnvOfStackMachine;
       if (jval == 2) {
-	if (ErrorMessageMode == 1 || ErrorMessageMode == 2) {
-	  pushErrorStack(KnewErrorPacket(SerialCurrent,-1,"User interrupt by ctrl-C."));
-	}
+        if (ErrorMessageMode == 1 || ErrorMessageMode == 2) {
+          pushErrorStack(KnewErrorPacket(SerialCurrent,-1,"User interrupt by ctrl-C."));
+        }
       }
       recursive--;
       if (localCatchCtrlC) { signal(SIGINT, sigfunc); }
+      if (!Calling_ctrlC_hook) {
+        Calling_ctrlC_hook = 1; RestrictedMode = 0;
+        KSexecuteString(" ctrlC-hook "); /* Execute User Defined functions. */
+        RestrictedMode_saved;
+      }
+      Calling_ctrlC_hook = 0;
+      KSexecuteString(" (Computation is interrupted.) "); /* move to ctrlC-hook?*/
       return(-1);
     }else{ }
   }else{
     if (recursive == 0) {
+#if defined(__CYGWIN__)
+      if (jval=sigsetjmp(EnvOfStackMachine,1)) { 
+#else
       if (jval=setjmp(EnvOfStackMachine)) { 
-	if (jval == 2) {
-	  if (ErrorMessageMode == 1 || ErrorMessageMode == 2) {
-	    pushErrorStack(KnewErrorPacket(SerialCurrent,-1,"User interrupt by ctrl-C."));
-	  }
-	}
-	recursive = 0;
-	if (localCatchCtrlC) { signal(SIGINT, sigfunc); }
-	return(-1);
+#endif
+        if (jval == 2) {
+          if (ErrorMessageMode == 1 || ErrorMessageMode == 2) {
+            pushErrorStack(KnewErrorPacket(SerialCurrent,-1,"User interrupt by ctrl-C."));
+          }
+        }
+        recursive = 0;
+        if (localCatchCtrlC) { signal(SIGINT, sigfunc); }
+        if (!Calling_ctrlC_hook) {
+          Calling_ctrlC_hook = 1; RestrictedMode = 0;
+          KSexecuteString(" ctrlC-hook "); /* Execute User Defined functions. */
+          RestrictedMode = RestrictedMode_saved;
+        }
+        Calling_ctrlC_hook = 0;
+        Calling_ctrlC_hook = 0;
+		KSexecuteString(" (Computation is interrupted.) ");
+        return(-1);
       }else { }
     }
   }
 
   recursive++;
   token.token = s;
-  token.kind = EXECUTABLE_STRING;
+  token.kind = EXECUTABLE_STRING; token.tflag = 0;
   executeToken(token);
-  token.kind = ID;
+  token.kind = ID; token.tflag = 0;
   token.token = "exec";
   token = lookupTokens(token); /* no use */
   tmp = findSystemDictionary(token.token);
@@ -1126,19 +1284,19 @@ char *s;
 KSdefineMacros() {
   struct tokens token;
   int tmp;
-  struct object ob;
+  struct object ob = OINIT;
 
   if (StandardMacros && (strlen(SMacros))) {
-    token.kind = EXECUTABLE_STRING;
+    token.kind = EXECUTABLE_STRING; token.tflag = 0;
     token.token = SMacros;
-    executeToken(token);	/* execute startup commands */
-    token.kind = ID;
+    executeToken(token);    /* execute startup commands */
+    token.kind = ID; token.tflag = 0;
     token.token = "exec";
     token = lookupTokens(token); /* no use */
     tmp = findSystemDictionary(token.token);
     ob.tag = Soperator;
     ob.lc.ival = tmp;
-    executePrimitive(ob);	/* exec */
+    executePrimitive(ob);   /* exec */
   }
   return(0);
 
@@ -1147,7 +1305,7 @@ KSdefineMacros() {
 void KSstart() {
   struct tokens token;
   int tmp;
-  struct object ob;
+  struct object ob = OINIT;
   extern int Quiet;
 
   stackmachine_init(); KinitKan();
@@ -1156,20 +1314,20 @@ void KSstart() {
   /* The following line may cause a core dump, if you do not setjmp properly
      after calling KSstart().*/
   /*
-  if (setjmp(EnvOfStackMachine)) {
+    if (setjmp(EnvOfStackMachine)) {
     fprintf(stderr,"KSstart(): An error or interrupt in reading macros, files and command strings.\n");
     exit(10);
-  } else {  }  */
+    } else {  }  */
 
   /* setup quiet mode or not */
-  token.kind = EXECUTABLE_STRING;
+  token.kind = EXECUTABLE_STRING; token.tflag = 0;
   if (Quiet) {
     token.token = " /@@@.quiet 1 def ";
   }else {
     token.token = " /@@@.quiet 0 def ";
   }
   executeToken(token); /* execute startup commands */
-  token.kind = ID;
+  token.kind = ID; token.tflag = 0;
   token.token = "exec";
   token = lookupTokens(token); /* set hashing values */
   tmp = findSystemDictionary(token.token);
@@ -1190,14 +1348,18 @@ struct object KSpop() {
 }
 
 void KSpush(ob)
-struct object ob;
+     struct object ob;
 {
   Kpush(ob);
 }
 
+struct object KSpeek(k) {
+  return(peek(k));
+}
+
 char *KSstringPop() {
   /* pop a string */
-  struct object rob;
+  struct object rob = OINIT;
   rob = Kpop();
   if (rob.tag == Sdollar) {
     return(rob.lc.str);
@@ -1237,6 +1399,10 @@ char *KSpopBinary(int *size) {
   return((char *)NULL);
 }
 
+struct object KSnewObjectArray(int k) {
+   return newObjectArray(k);
+}
+
 int pushErrorStack(struct object obj)
 {
   if (CurrentOperandStack == &ErrorStack) {
@@ -1267,8 +1433,8 @@ struct object popErrorStack(void) {
 }
 
 char *popErrorStackByString(void) {
-  struct object obj;
-  struct object eobj;
+  struct object obj = OINIT;
+  struct object eobj = OINIT;
   eobj = popErrorStack();
   if (ectag(eobj) != CLASSNAME_ERROR_PACKET) {
     return(NULL);
@@ -1297,7 +1463,7 @@ int KScheckErrorStack(void)
 
 struct object KnewErrorPacket(int serial,int no,char *message)
 {
-  struct object obj;
+  struct object obj = OINIT;
   struct object *myop;
   char *s;
   /* Set extended tag. */
@@ -1319,7 +1485,7 @@ struct object KnewErrorPacket(int serial,int no,char *
 
 struct object KnewErrorPacketObj(struct object ob1)
 {
-  struct object obj;
+  struct object obj = OINIT;
   struct object *myop;
   char *s;
   /* Set extended tag. */
@@ -1418,8 +1584,8 @@ int KSstackPointer() {
 }
 
 struct object KSdupErrors() {
-  struct object rob;
-  struct object ob;
+  struct object rob = OINIT;
+  struct object ob = OINIT;
   int i;
   int n;
   int m;
@@ -1443,4 +1609,116 @@ struct object KSdupErrors() {
   }
   return(rob);
 }
+
+void cancelAlarm() {
+  alarm((unsigned int) 0);
+  signal(SIGALRM,SIG_DFL);
+}
+
+/* back-trace */
+#define TraceNameStackSize 3000
+char *TraceNameStack[TraceNameStackSize];
+int TraceNameStackp = 0;
+void tracePushName(char *s) {
+  char *t;
+  /*
+  t = (char *)sGC_malloc(strlen(s)+1);
+  if (t == NULL) {
+    fprintf(stderr,"No more memory.\n"); return;
+  }
+  strcpy(t,s);
+  */
+  t = s;
+  TraceNameStack[TraceNameStackp++] = t;
+  if (TraceNameStackp >= TraceNameStackSize) {
+    fprintf(stderr,"Warning: TraceNameStack overflow. Clearing the stack.\n");
+    TraceNameStackp = 0;
+  }
+}
+void traceClearStack(void) {
+  TraceNameStackp = 0;
+}
+char *tracePopName(void) {
+  if (TraceNameStackp <= 0) return (char *) NULL;
+  return TraceNameStack[--TraceNameStackp];
+}
+struct object *traceNameStackToArrayp(void) {
+  int n,i;
+  struct object *op;
+  op = sGC_malloc(sizeof(struct object));
+  n = TraceNameStackp; if (n < 0) n = 0;
+  *op = newObjectArray(n);
+  for (i=0; i<n; i++) {
+	putoa((*op),i, KpoString(TraceNameStack[i]));
+  }
+  return op;
+}
+#define TRACE_MSG_SIZE 320
+char *traceShowStack(void) {
+  char *s;
+  char *t;
+  int p;
+  s = (char *) sGC_malloc(TRACE_MSG_SIZE);
+  if (s == NULL) {
+    fprintf(stderr,"No more memory.\n"); return NULL;
+  }
+  sprintf(s,"Trace: ");
+  p = strlen(s);
+  do {
+    t = tracePopName();
+    if (t == NULL) {
+      s[p] = ';'; s[p+1] = 0;
+      break;
+    }else if ((strlen(t) + p) > (TRACE_MSG_SIZE-10)) {
+	  /* fprintf(stderr,"p=%d, TraceNameStackp=%d, strlen(t)=%d, t=%s\n",p,TraceNameStackp,strlen(t),t); */
+      strcpy(&(s[p])," ...");
+      break;
+    }
+    strcpy(&(s[p]),t); p += strlen(t);
+    strcpy(&(s[p]),"<-"); p += 2;
+  } while (t != (char *)NULL);
+  fprintf(stderr,"%s\n",s);
+  return s;
+}
+
+/*
+  if (fname != NULL) fname is pushed to the trace stack.
+ */ 
+int executeExecutableArray(struct object ob,char *fname,int withGotoP) {
+  struct tokens *tokenArray;
+  int size,i;
+  int status;
+  int infixOn;
+  struct tokens infixToken;
+  extern int GotoP;
   
+  infixOn = 0;
+  if (ob.tag != SexecutableArray) errorStackmachine("Error (executeTokenArray): the argument is not a token array.");
+
+  if (fname != NULL) tracePushName(fname);
+  tokenArray = ob.lc.tokenArray;
+  size = ob.rc.ival;
+  for (i=0; i<size; i++) {
+    status = executeToken(tokenArray[i]);
+    if ((status & STATUS_BREAK) || (status < 0) || (withGotoP && GotoP)) {
+      if (fname != NULL) tracePopName();
+      return(status);
+    }
+    
+    if (status & STATUS_INFIX) {
+      if (i == size-1) errorStackmachine("Infix operator at the end of an executable array.");
+      infixOn = 1; infixToken = tokenArray[i]; 
+      infixToken.tflag |= NO_DELAY;
+      continue;
+    }else if (infixOn) {
+      infixOn = 0;
+      status = executeToken(infixToken);
+      if ((status & STATUS_BREAK) || (status < 0) || (withGotoP && GotoP)) {
+        if (fname != NULL) tracePopName();
+        return(status);
+      }
+    }
+  }
+  if (fname != NULL) tracePopName();
+  return(0); /* normal exit */
+}