eplace format

packages/PLStream/pl-error.c

@@ -373,7 +373,27 @@ X_API int PL_error(const char *pred, int arity, const char *msg, int id, ...)
 			   PL_TERM, stream);
       break;
     }
-      
+    case ERR_FORMAT:
+    { const char *s = va_arg(args, const char*);
+      int rc;
+
+      rc = PL_unify_term(formal,
+			 PL_FUNCTOR_CHARS, "format", 1,
+			   PL_CHARS, s);
+      break;
+    }
+    case ERR_FORMAT_ARG:
+    { const char *s = va_arg(args, const char*);
+      term_t arg = va_arg(args, term_t);
+      int rc;
+
+      rc = PL_unify_term(formal,
+			 PL_FUNCTOR_CHARS, "format_argument_type", 2,
+			   PL_CHARS, s,
+			   PL_TERM, arg);
+      break;
+    }
+
   default:
     fprintf(stderr, "unimplemented SWI error %d\n",id);
     goto err_instantiation;

packages/PLStream/pl-file.c

@@ -4675,6 +4675,7 @@ static const PL_extension foreigns[] = {
   FRG("writeq",			1, pl_writeq,		      ISO),
   FRG("print",			1, pl_print,			0),
   FRG("nl",			1, pl_nl1,		      ISO),
+  FRG("format",			2, pl_format,		     META),
 
   FRG("write",			2, pl_write2,		      ISO),
   FRG("writeq",			2, pl_writeq2,		      ISO),

packages/PLStream/pl-fmt.c

@@ -320,12 +320,29 @@ word
 pl_format3(term_t out, term_t format, term_t args)
 { redir_context ctx;
   word rc;
+#if __YAP_PROLOG__
+  /*
+    YAP allows the last argument to format to be of the form
+    module:[]
+  */
+  YAP_Term mod;
+#endif    
 
-  if ( (rc=setupOutputRedirect(out, &ctx, FALSE)) )
-  { if ( (rc = format_impl(ctx.stream, format, args)) )
-      rc = closeOutputRedirect(&ctx);
-    else
+  if ( (rc=setupOutputRedirect(out, &ctx, FALSE)) ) {
+#if __YAP_PROLOG__
+    /* module processing */
+    {
+      args = Yap_fetch_module_for_format(args, &mod);
+    }
+#endif    
+    { if ( (rc = format_impl(ctx.stream, format, args)) )
+	rc = closeOutputRedirect(&ctx);
+      else
       discardOutputRedirect(&ctx);
+    }
+#if __YAP_PROLOG__
+    YAP_SetCurrentModule(mod);
+#endif    
   }
 
   return rc;

packages/PLStream/pl-incl.h

@@ -50,6 +50,25 @@ typedef struct
 	} value;
 } number, *Number;
 
+#define TOINT_CONVERT_FLOAT     0x1     /* toIntegerNumber() */
+#define TOINT_TRUNCATE          0x2
+
+#ifdef O_GMP
+#define intNumber(n)    ((n)->type <=  V_MPZ)
+#else
+#define intNumber(n)    ((n)->type <  V_FLOAT)
+#endif
+#define floatNumber(n)  ((n)->type >= V_FLOAT)
+
+typedef enum
+{ NUM_ERROR = FALSE,                    /* Syntax error */
+  NUM_OK    = TRUE,                     /* Ok */
+  NUM_FUNDERFLOW = -1,                  /* Float underflow */
+  NUM_FOVERFLOW = -2,                   /* Float overflow */
+  NUM_IOVERFLOW = -3                    /* Integer overflow */
+} strnumstat;
+
+
 #define Arg(N)  (PL__t0+((n)-1))
 #define A1      (PL__t0)
 #define A2      (PL__t0+1)

packages/PLStream/pl-yap.c

@@ -147,9 +147,39 @@ callProlog(module_t module, term_t goal, int flags, term_t *ex)
   }
 }
 
+extern YAP_Term Yap_InnerEval(YAP_Term t);
+
+inline static YAP_Term
+Yap_Eval(YAP_Term t)
+{
+  if (t == 0L || ( !YAP_IsVarTerm(t) && (YAP_IsIntTerm(t) || YAP_IsFloatTerm(t)) ))
+    return t;
+  return Yap_InnerEval(t);
+}
+
+
 int
 valueExpression(term_t t, Number r ARG_LD)
-{ //return YAP__expression(t, r, 0 PASS_LD);
+{
+  YAP_Term t0 = Yap_Eval(YAP_GetFromSlot(t));
+  if (YAP_IsIntTerm(t0)) {
+    r->type = V_INTEGER;
+    r->value.i = YAP_IntOfTerm(t0);
+    return 1;
+  }
+  if (YAP_IsFloatTerm(t0)) {
+    r->type = V_FLOAT;
+    r->value.f = YAP_FloatOfTerm(t0);
+    return 1;
+  }
+#ifdef O_GMP
+  if (YAP_IsBigNumTerm(t0)) {
+    r->type = V_MPZ;
+    mpz_init(&r->value.mpz);
+    YAP_BigNumOfTerm(t0, &r->value.mpz);
+    return 1;
+  }
+#endif
   return 0;
 }
 
@@ -166,10 +196,21 @@ Note that if a double is  out  of   range  for  int64_t,  it never has a
 fractional part.
 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
+static int
+double_in_int64_range(double x)
+{ int k;
+  double y = frexp(x, &k);
+
+  if ( k < 8*(int)sizeof(int64_t) ||
+       (y == -0.5 && k == 8*(int)sizeof(int64_t)) )
+    return TRUE;
+
+  return FALSE;
+}
+
 int
 toIntegerNumber(Number n, int flags)
 { 
-#if SWI_PROLOG
 switch(n->type)
   { case V_INTEGER:
       succeed;
@@ -185,7 +226,7 @@ switch(n->type)
       }
       fail;
 #endif
-    case V_REAL:
+    case V_FLOAT:
       if ( (flags & TOINT_CONVERT_FLOAT) )
       { if ( double_in_int64_range(n->value.f) )
 	{ int64_t l = (int64_t)n->value.f;
@@ -209,7 +250,6 @@ switch(n->type)
       }
       return FALSE;
   }
-#endif
   assert(0);
   fail;
 } 
@@ -826,6 +866,17 @@ PL_utf8_strlen(const char *s, size_t len)
 { return utf8_strlen(s, len);
 }
 
+term_t
+Yap_fetch_module_for_format(term_t args, YAP_Term *modp) {
+  YAP_Term nmod;
+  YAP_Term nt = YAP_StripModule(YAP_GetFromSlot(args), &nmod);
+  *modp = YAP_SetCurrentModule(nmod);
+  if (!nt) {
+    return args;
+  }
+  return YAP_InitSlot(nt);
+}
+
 #define COUNT_MUTEX_INITIALIZER(name) \
  { PTHREAD_MUTEX_INITIALIZER, \
    name, \