Bill Allombert on Thu, 01 Oct 2009 13:49:08 +0200


[Date Prev] [Date Next] [Thread Prev] [Thread Next] [Date Index] [Thread Index]

Re: experimental patch for iferr


On Thu, Oct 01, 2009 at 12:39:48PM +0200, Lorenz Minder wrote:
> Hi,
> 
> BA:
> > On Thu, Oct 01, 2009 at 07:55:42AM +0200, Lorenz Minder wrote:
> > > Hi,
> > > 
> > > 2) I'd prefer if the second argument was a reference, i.e., one would
> > write
> > > 
> > >    iferr(whatever, &E, seq1, seq2)
> > > 
> > > Right now it seems that this is the only function in GP that
> > > modifies an argument that was (syntactically) passed by value.  I have
> > > no idea if this is difficult to do.  (I've no time for studying
> > > source code ATM, unfortunately.)
> > 
> > This is a misunderstanding: E is not modified! E is actually a local
> > parameter
> > that only exist in the 'err' branch, as in the following expressions:
> 
> Yes, right. I only realized this after experimenting a bit more with it.
> So it's fine as is, of course.
> 
> On an unrelated note, I found another failing instance, possibly the
> same bug as before.
> 
> ? iferr(1/0, E, ["fail", E], "ok")
>   ***   at top-level: iferr(1/0,E,["fail",E],"ok")
>   ***                             ^----------------
>   ***   the PARI stack overflows !

Yes, I forgot to gcopy the error data. Please find a fixed patch.
Thanks a lot for your experimentations!

Cheers,
Bill.
diff --git a/src/functions/programming/iferr b/src/functions/programming/iferr
new file mode 100644
index 0000000..1035f87
--- /dev/null
+++ b/src/functions/programming/iferr
@@ -0,0 +1,14 @@
+Function: iferr
+Section: programming/control
+C-Name: iferrpari
+Prototype: EVDEDE
+Help: iferr(seq1,E,{seq2},{seq3}): evaluates the expression sequence seq1. if
+ an error occurs, seq2 is evaluated with the formal parameter E set to the
+ error data, otherwise seq3 is evaluated. The arguments seq2 and seq3 are
+ optional, and if seq3 is omitted, the preceding comma can be omitted also.
+Doc: evaluates the expression sequence \var{seq1}. if an error occurs,
+ \var{seq2} is evaluated with the formal parameter \var{E} set to the error
+ data, otherwise \var{seq3} is evaluated. The arguments \var{seq2} and
+ \var{seq3} are optional, and if \var{seq3} is omitted, the preceding comma can
+ be omitted also.
+
diff --git a/src/headers/paripriv.h b/src/headers/paripriv.h
index 0f1a4a4..8ef158a 100644
--- a/src/headers/paripriv.h
+++ b/src/headers/paripriv.h
@@ -49,6 +49,7 @@ GEN resetloop(GEN a, GEN b);
 GEN setloop(GEN a);
 
 /* parser */
+GEN iferrpari(GEN a, GEN b, GEN c);
 void forpari(GEN a, GEN b, GEN node);
 void untilpari(GEN a, GEN b);
 void whilepari(GEN a, GEN b);
diff --git a/src/language/compile.c b/src/language/compile.c
index e95b6ba..28e6a06 100644
--- a/src/language/compile.c
+++ b/src/language/compile.c
@@ -1105,6 +1105,7 @@ compilefunc(entree *ep, long n, int mode)
               }
               checkdups(varg,vep);
               frame_push(vep);
+              lev=0;
             }
             if (tree[a].f==Fnoarg)
               compilecast(a,Gvoid,type);
@@ -1194,10 +1195,11 @@ compilefunc(entree *ep, long n, int mode)
         j++;
         switch(c)
         {
-        case 'G':
-        case '&':
         case 'E':
         case 'I':
+          lev=0; /*FALL THROUGH*/
+        case 'G':
+        case '&':
           op_push(OCpushlong,0,n);
           break;
         case 'n':
diff --git a/src/language/es.c b/src/language/es.c
index 72777d2..ca8357e 100644
--- a/src/language/es.c
+++ b/src/language/es.c
@@ -4023,7 +4023,11 @@ void print   (GEN g) { print0(g, f_RAW);       pari_putc('\n'); pari_flush(); }
 void printtex(GEN g) { print0(g, f_TEX);       pari_putc('\n'); pari_flush(); }
 void print1  (GEN g) { print0(g, f_RAW);       pari_flush(); }
 
-void error0(GEN g) { pari_err(user, g); }
+void error0(GEN g)
+{
+  if (lg(g)==2 && typ(gel(g,1))==t_VEC) pari_err(0, gel(g,1));
+  else pari_err(user, g);
+}
 void warning0(GEN g) { pari_warn(user, g); }
 
 static char *
diff --git a/src/language/init.c b/src/language/init.c
index 5cba082..a660cfa 100644
--- a/src/language/init.c
+++ b/src/language/init.c
@@ -817,9 +817,13 @@ err_seek(long n)
   return NULL;
 }
 
+
+extern jmp_buf *iferr_env;
+
 void
 err_recover(long numerr)
 {
+  iferr_env=NULL;
   initout(0);
   dbg_release();
   killallfiles(0);
@@ -911,6 +915,118 @@ pari_sigint(const char *s)
   err_recover(talker);
 }
 
+GEN
+pari_err_GEN(int numerr, va_list ap)
+{
+  switch (numerr)
+  {
+  case talker: case alarmer:
+    {
+      const char *ch1 = va_arg(ap, char*);
+      char *s = pari_vsprintf(ch1,ap);
+      GEN res = mkvec3(stoi(numerr),strtoGENstr(ch1),strtoGENstr(s));
+      free(s);
+      return res;
+    }
+  case user:
+  case invmoder:
+  case notfuncer:
+    return mkvec2(stoi(numerr),va_arg(ap, GEN));
+  case openfiler:
+  case overflower:
+  case impl:
+  case typeer: case mattype1: case negexper:
+  case constpoler: case notpoler: case redpoler:
+  case zeropoler: case consister: case flagerr: case precer:
+  case bugparier:
+    return mkvec2(stoi(numerr),strtoGENstr(va_arg(ap, char*)));
+  case operi: case operf:
+    {
+      const char *op = va_arg(ap, const char*);
+      GEN x = va_arg(ap, GEN);
+      GEN y = va_arg(ap, GEN);
+      return mkvec4(stoi(numerr),strtoGENstr(op),x,y);
+    }
+  case primer1:
+    return mkvec2(stoi(numerr),utoi(va_arg(ap, ulong)));
+  default:
+    return mkvecs(numerr);
+  }
+}
+
+void
+pari_err_display(GEN err)
+{
+  long numerr=itos(gel(err,1));
+  err_init_msg(numerr); pari_puts(errmessage[numerr]);
+  switch (numerr)
+  {
+  case talker: case alarmer:
+    pari_printf("%Ps.",gel(err,3));
+    break;
+  case user:
+    pari_puts("user error: ");
+    print0(gel(err,2), f_RAW);
+    break;
+  case invmoder:
+    pari_printf("impossible inverse modulo: %Ps.", gel(err,2));
+    break;
+  case openfiler:
+    pari_printf("error opening %Ps file: `%Ps'.", gel(err,2), gel(err,3));
+    break;
+  case overflower:
+    pari_printf("overflow in %Ps.", gel(err,2));
+    break;
+  case notfuncer:
+    {
+      GEN fun = gel(err,2);
+      if (gcmpX(fun))
+      {
+        entree *ep = varentries[varn(fun)];
+        const char *s = ep->name;
+        if (cb_pari_whatnow) cb_pari_whatnow(s,1);
+      }
+      break;
+    }
+  case impl:
+    pari_printf("sorry, %Ps is not yet implemented.", gel(err,2));
+    break;
+  case typeer: case mattype1: case negexper:
+  case constpoler: case notpoler: case redpoler:
+  case zeropoler: case consister: case flagerr: case precer:
+    pari_printf(" in %Ps.", gel(err,2)); break;
+  case bugparier:
+    pari_printf("bug in %Ps, please report",gel(err,2)); break;
+  case operi: case operf:
+    {
+      const char *f, *op = GSTR(gel(err,2));
+      GEN x = gel(err,3);
+      GEN y = gel(err,4);
+      pari_puts(numerr == operi? "impossible": "forbidden");
+        switch(*op)
+        {
+          case '+': f = "addition"; break;
+          case '-':
+            pari_printf(" negation - %s.",type_name(typ(x)));
+            f = NULL; break;
+          case '*': f = "multiplication"; break;
+          case '/': case '%': case '\\': f = "division"; break;
+          case 'g': op = ","; f = "gcd"; break;
+          default: op = "-->"; f = "assignment"; break;
+        }
+        if (f)
+          pari_printf(" %s %s %s %s.",f,type_name(typ(x)),op,type_name(typ(y)));
+        break;
+      }
+  case primer1:
+    {
+      ulong c = itou(gel(err,2));
+      if (c) pari_printf(", need primelimit ~ %u.", c);
+      break;
+    }
+  }
+}
+
 void
 pari_err(int numerr, ...)
 {
@@ -937,89 +1053,22 @@ pari_err(int numerr, ...)
       longjmp(*(trapped->penv), numerr);
     }
   }
-  err_init();
   if (numerr == talker2)
   {
     const char *msg = va_arg(ap, char*);
     const char *s = va_arg(ap,char *);
+    err_init();
     print_errcontext(msg,s,va_arg(ap,char *));
   }
   else
   {
+    GEN err=numerr?pari_err_GEN(numerr,ap):va_arg(ap,GEN);
+    global_err_data=err;
+    if (*iferr_env)
+      longjmp(*iferr_env, numerr);
+    err_init();
     closure_err();
-    err_init_msg(numerr); pari_puts(errmessage[numerr]);
-    switch (numerr)
-    {
-      case talker: case alarmer: {
-        const char *ch1 = va_arg(ap, char*);
-        pari_vprintf(ch1,ap); pari_putc('.'); break;
-      }
-      case user:
-        pari_puts("user error: ");
-        print0(va_arg(ap, GEN), f_RAW);
-        break;
-      case invmoder:
-        pari_printf("impossible inverse modulo: %Ps.", va_arg(ap, GEN));
-        break;
-      case openfiler: {
-        const char *type = va_arg(ap, char*);
-        pari_printf("error opening %s file: `%s'.", type, va_arg(ap,char*));
-        break;
-      }
-      case overflower:
-        pari_printf("overflow in %s.", va_arg(ap, char*));
-        break;
-      case notfuncer:
-      {
-        GEN fun = va_arg(ap, GEN);
-        if (gcmpX(fun))
-        {
-          entree *ep = varentries[varn(fun)];
-          const char *s = ep->name;
-          if (cb_pari_whatnow) cb_pari_whatnow(s,1);
-        }
-        break;
-      }
-
-      case impl:
-        pari_printf("sorry, %s is not yet implemented.", va_arg(ap, char*));
-        break;
-      case typeer: case mattype1: case negexper:
-      case constpoler: case notpoler: case redpoler:
-      case zeropoler: case consister: case flagerr: case precer:
-        pari_printf(" in %s.",va_arg(ap, char*)); break;
-
-      case bugparier:
-        pari_printf("bug in %s, please report",va_arg(ap, char*)); break;
-
-      case operi: case operf:
-      {
-        const char *f, *op = va_arg(ap, const char*);
-        GEN x = va_arg(ap, GEN);
-        GEN y = va_arg(ap, GEN);
-        pari_puts(numerr == operi? "impossible": "forbidden");
-        switch(*op)
-        {
-          case '+': f = "addition"; break;
-          case '-':
-            pari_printf(" negation - %s.",type_name(typ(x)));
-            f = NULL; break;
-          case '*': f = "multiplication"; break;
-          case '/': case '%': case '\\': f = "division"; break;
-          case 'g': op = ","; f = "gcd"; break;
-          default: op = "-->"; f = "assignment"; break;
-        }
-        if (f)
-          pari_printf(" %s %s %s %s.",f,type_name(typ(x)),op,type_name(typ(y)));
-        break;
-      }
-
-      case primer1: {
-        ulong c = va_arg(ap, ulong);
-        if (c) pari_printf(", need primelimit ~ %lu.", c);
-        break;
-      }
-    }
+    pari_err_display(err);
   }
   term_color(c_NONE); va_end(ap);
   if (numerr==errpile)
diff --git a/src/language/sumiter.c b/src/language/sumiter.c
index f56a693..6289e07 100644
--- a/src/language/sumiter.c
+++ b/src/language/sumiter.c
@@ -16,6 +16,33 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */
 #include "pari.h"
 #include "paripriv.h"
 #include "anal.h"
+
+jmp_buf *iferr_env=NULL;
+
+GEN
+iferrpari(GEN a, GEN b, GEN c)
+{
+  GEN res;
+  jmp_buf *iferr_old=iferr_env;
+  jmp_buf env;
+  struct pari_evalstate state;
+  evalstate_save(&state);
+  iferr_env = &env;
+  if (setjmp(*iferr_env))
+  {
+    iferr_env = iferr_old;
+    evalstate_restore(&state);
+    if (!b) return gnil;
+    push_lex(gcopy(global_err_data),b);
+    res = closure_evalgen(b);
+    pop_lex(1);
+    return res;
+  }
+  res = closure_evalgen(a);
+  iferr_env = iferr_old;
+  return c?closure_evalgen(c):res;
+}
+
 /********************************************************************/
 /**                                                                **/
 /**                        ITERATIONS                              **/