[pure-lang-svn] SF.net SVN: pure-lang: [293] pure/trunk

[<ag...@us...>]

Revision: 293
          http://pure-lang.svn.sourceforge.net/pure-lang/?rev=293&view=rev
Author:   agraef
Date:     2008-06-24 01:56:30 -0700 (Tue, 24 Jun 2008)

Log Message:
-----------
Clean up the public API and implement most operations.

Modified Paths:
--------------
    pure/trunk/runtime.cc
    pure/trunk/runtime.h

Modified: pure/trunk/runtime.cc
===================================================================
--- pure/trunk/runtime.cc	2008-06-24 00:31:37 UTC (rev 292)
+++ pure/trunk/runtime.cc	2008-06-24 08:56:30 UTC (rev 293)
@@ -300,62 +300,82 @@
 
 /* PUBLIC API. **************************************************************/
 
-// XXXTODO
+extern "C"
+int32_t pure_sym(const char *s)
+{
+  assert(s);
+  interpreter& interp = *interpreter::g_interp;
+  const symbol& sym = interp.symtab.sym(s);
+  return sym.f;
+}
 
-int32_t pure_sym(const char *s);
-int32_t pure_getsym(const char *s);
-const char *pure_sym_pname(int32_t sym);
-int8_t pure_sym_nprec(int32_t sym);
+extern "C"
+int32_t pure_getsym(const char *s)
+{
+  assert(s);
+  interpreter& interp = *interpreter::g_interp;
+  const symbol* sym = interp.symtab.lookup(s);
+  if (sym)
+    return sym->f;
+  else
+    return 0;
+}
 
-pure_expr *pure_symbol(int32_t sym);
-
 extern "C"
-pure_expr *pure_int(int32_t i)
+const char *pure_sym_pname(int32_t tag)
 {
-  pure_expr *x = new_expr();
-  x->tag = EXPR::INT;
-  x->data.i = i;
-  MEMDEBUG_NEW(x)
-  return x;
+  assert(tag>0);
+  interpreter& interp = *interpreter::g_interp;
+  const symbol& sym = interp.symtab.sym(tag);
+  return sym.s.c_str();
 }
 
 extern "C"
-pure_expr *pure_long(int64_t l)
+int8_t pure_sym_nprec(int32_t tag)
 {
-  int sgn = (l>0)?1:(l<0)?-1:0;
-  uint64_t v = (uint64_t)(l>=0?l:-l);
-  if (sizeof(mp_limb_t) == 8) {
-    // 8 byte limbs, value fits in a single limb.
-    limb_t u[1] = { v };
-    return pure_bigint(sgn, u);
-  } else {
-    // 4 byte limbs, put least significant word in the first limb.
-    limb_t u[2] = { (uint32_t)v, (uint32_t)(v>>32) };
-    return pure_bigint(sgn+sgn, u);
-  }
+  assert(tag>0);
+  interpreter& interp = *interpreter::g_interp;
+  const symbol& sym = interp.symtab.sym(tag);
+  return nprec(sym.prec, sym.fix);
 }
 
-static void make_bigint(mpz_t z, int32_t size, const limb_t *limbs)
+extern "C"
+pure_expr *pure_symbol(int32_t tag)
 {
-  // FIXME: For efficiency, we poke directly into the mpz struct here, this
-  // might need to be reviewed for future GMP revisions.
-  int sz = size>=0?size:-size, sgn = size>0?1:size<0?-1:0, sz0 = 0;
-  // normalize: the most significant limb should be nonzero
-  for (int i = 0; i < sz; i++) if (limbs[i] != 0) sz0 = i+1;
-  sz = sz0; size = sgn*sz;
-  mpz_init(z);
-  if (sz > 0) _mpz_realloc(z, sz);
-  assert(sz == 0 || z->_mp_d);
-  for (int i = 0; i < sz; i++) z->_mp_d[i] = limbs[i];
-  z->_mp_size = size;
+  assert(tag>0);
+  interpreter& interp = *interpreter::g_interp;
+  const symbol& sym = interp.symtab.sym(tag);
+  // Check for an existing global variable for this symbol.
+  GlobalVar& v = interp.globalvars[tag];
+  if (!v.v) {
+    // The variable doesn't exist yet (we have a new symbol), create it.
+    string lab;
+    // Create a name for the variable (cf. interpreter::mkvarlabel).
+    if (sym.prec < 10 || sym.fix == nullary)
+      lab = "$("+sym.s+")";
+    else
+      lab = "$"+sym.s;
+    // Create a global variable bound to the symbol for now.
+    v.v = new llvm::GlobalVariable
+      (interp.ExprPtrTy, false, llvm::GlobalVariable::InternalLinkage, 0,
+       lab.c_str(), interp.module);
+    interp.JIT->addGlobalMapping(v.v, &v.x);
+    v.x = pure_new(pure_const(tag));
+    // Since we just created this variable, it doesn't have any closure bound
+    // to it yet, so it's safe to just return the symbol as is.
+    return v.x;
+  } else
+    // The symbol already exists, so there might be a parameterless closure
+    // bound to it and thus we need to evaluate it.
+    return pure_call(v.x);
 }
 
 extern "C"
-pure_expr *pure_bigint(int32_t size, const limb_t *limbs)
+pure_expr *pure_int(int32_t i)
 {
   pure_expr *x = new_expr();
-  x->tag = EXPR::BIGINT;
-  make_bigint(x->data.z, size, limbs);
+  x->tag = EXPR::INT;
+  x->data.i = i;
   MEMDEBUG_NEW(x)
   return x;
 }
@@ -432,29 +452,112 @@
   return x;
 }
 
+extern "C"
+pure_expr *pure_app(pure_expr *fun, pure_expr *arg)
+{
+  return pure_apply2(fun, arg);
+}
+
 // XXXTODO
 
-pure_expr *pure_app(pure_expr *fun, pure_expr *arg);
-
 pure_expr *pure_listl(size_t size, ...);
 pure_expr *pure_listv(size_t size, pure_expr **elems);
 pure_expr *pure_tuplel(size_t size, ...);
 pure_expr *pure_tuplev(size_t size, pure_expr **elems);
 
-bool pure_is_symbol(const pure_expr *x, int32_t *sym);
-bool pure_is_int(const pure_expr *x, int32_t *i);
-bool pure_is_long(const pure_expr *x, int64_t *l);
-bool pure_is_bigint(const pure_expr *x, int32_t *size, limb_t **limbs);
-bool pure_is_mpz(const pure_expr *x, mpz_t *z);
-bool pure_is_double(const pure_expr *x, double *d);
-bool pure_is_pointer(const pure_expr *x, void **p);
+bool pure_is_symbol(const pure_expr *x, int32_t *sym)
+{
+  assert(x);
+  if (x->tag >= 0) {
+    if (sym) *sym = x->tag;
+    return true;
+  } else
+    return false;
+}
 
-bool pure_is_string(const pure_expr *x, const char **sym);
-bool pure_is_string_dup(const pure_expr *x, char **sym);
-bool pure_is_cstring_dup(const pure_expr *x, char **sym);
+bool pure_is_int(const pure_expr *x, int32_t *i)
+{
+  assert(x);
+  if (x->tag == EXPR::INT) {
+    if (i) *i = x->data.i;
+    return true;
+  } else
+    return false;
+}
 
-bool pure_is_app(const pure_expr *x, pure_expr **fun, pure_expr **arg);
+bool pure_is_mpz(const pure_expr *x, mpz_t *z)
+{
+  assert(x);
+  if (x->tag == EXPR::BIGINT) {
+    if (z) mpz_init_set(*z, x->data.z);
+    return true;
+  } else
+    return false;
+}
 
+bool pure_is_double(const pure_expr *x, double *d)
+{
+  assert(x);
+  if (x->tag == EXPR::DBL) {
+    if (d) *d = x->data.d;
+    return true;
+  } else
+    return false;
+}
+
+bool pure_is_pointer(const pure_expr *x, void **p)
+{
+  assert(x);
+  if (x->tag == EXPR::PTR) {
+    if (p) *p = x->data.p;
+    return true;
+  } else
+    return false;
+}
+
+bool pure_is_string(const pure_expr *x, const char **s)
+{
+  assert(x);
+  if (x->tag == EXPR::STR) {
+    if (s) *s = x->data.s;
+    return true;
+  } else
+    return false;
+}
+
+bool pure_is_string_dup(const pure_expr *x, char **s)
+{
+  assert(x);
+  if (x->tag == EXPR::STR) {
+    if (s) *s = strdup(x->data.s);
+    return true;
+  } else
+    return false;
+}
+
+bool pure_is_cstring_dup(const pure_expr *x, char **s)
+{
+  assert(x);
+  if (x->tag == EXPR::STR) {
+    if (s) *s = fromutf8(x->data.s);
+    return true;
+  } else
+    return false;
+}
+
+bool pure_is_app(const pure_expr *x, pure_expr **fun, pure_expr **arg)
+{
+  assert(x);
+  if (x->tag == EXPR::APP) {
+    if (fun) *fun = x->data.x[0];
+    if (arg) *arg = x->data.x[1];
+    return true;
+  } else
+    return false;
+}
+
+// XXXTODO
+
 bool pure_is_listv(const pure_expr *x, size_t *size, pure_expr ***elems);
 bool pure_is_tuplev(const pure_expr *x, size_t *size, pure_expr ***elems);
 
@@ -537,6 +640,47 @@
 }
 
 extern "C"
+pure_expr *pure_long(int64_t l)
+{
+  int sgn = (l>0)?1:(l<0)?-1:0;
+  uint64_t v = (uint64_t)(l>=0?l:-l);
+  if (sizeof(mp_limb_t) == 8) {
+    // 8 byte limbs, value fits in a single limb.
+    limb_t u[1] = { v };
+    return pure_bigint(sgn, u);
+  } else {
+    // 4 byte limbs, put least significant word in the first limb.
+    limb_t u[2] = { (uint32_t)v, (uint32_t)(v>>32) };
+    return pure_bigint(sgn+sgn, u);
+  }
+}
+
+static void make_bigint(mpz_t z, int32_t size, const limb_t *limbs)
+{
+  // FIXME: For efficiency, we poke directly into the mpz struct here, this
+  // might need to be reviewed for future GMP revisions.
+  int sz = size>=0?size:-size, sgn = size>0?1:size<0?-1:0, sz0 = 0;
+  // normalize: the most significant limb should be nonzero
+  for (int i = 0; i < sz; i++) if (limbs[i] != 0) sz0 = i+1;
+  sz = sz0; size = sgn*sz;
+  mpz_init(z);
+  if (sz > 0) _mpz_realloc(z, sz);
+  assert(sz == 0 || z->_mp_d);
+  for (int i = 0; i < sz; i++) z->_mp_d[i] = limbs[i];
+  z->_mp_size = size;
+}
+
+extern "C"
+pure_expr *pure_bigint(int32_t size, const limb_t *limbs)
+{
+  pure_expr *x = new_expr();
+  x->tag = EXPR::BIGINT;
+  make_bigint(x->data.z, size, limbs);
+  MEMDEBUG_NEW(x)
+  return x;
+}
+
+extern "C"
 int32_t pure_cmp_bigint(pure_expr *x, int32_t size, const limb_t *limbs)
 {
   assert(x && x->tag == EXPR::BIGINT);

Modified: pure/trunk/runtime.h
===================================================================
--- pure/trunk/runtime.h	2008-06-24 00:31:37 UTC (rev 292)
+++ pure/trunk/runtime.h	2008-06-24 08:56:30 UTC (rev 293)
@@ -83,33 +83,16 @@
 const char *pure_sym_pname(int32_t sym);
 int8_t pure_sym_nprec(int32_t sym);
 
-/* Expression constructors. Atomic objects are constructed with the following
-   routines:
+/* Expression constructors. pure_symbol takes the integer code of a symbol and
+   returns that symbol as a Pure value. If the symbol is a global variable
+   bound to a value then that value is returned, if it's a parameterless
+   function then it is evaluated, giving the return value of the function as
+   the result. pure_int, pure_mpz, pure_double and pure_pointer construct a
+   Pure machine int, bigint, floating point value and pointer from a 32 bit
+   integer, (copy of a) GMP mpz_t, double and C pointer, respectively. */
 
-   - pure_symbol: Takes the integer code of a symbol and returns that symbol
-     as a Pure value. If the symbol is a global variable or parameterless
-     function then it is evaluated, giving the value of the variable or the
-     return value of the function as the result.
-
-   - pure_int: Constructs a Pure machine int from a 32 bit integer value.
-
-   - pure_long: Constructs a Pure bigint from a 64 bit integer value.
-
-   - pure_bigint: Constructs a Pure bigint from a vector of limbs. The size
-     argument may be negative to denote a negative number, its absolute value
-     is the number of elements in the limbs vector (the vector is owned by the
-     caller and won't be be freed).
-
-   - pure_mpz: Constructs a Pure bigint from a (copy of a) GMP mpz_t.
-
-   - pure_double: Constructs a Pure floating point number from a double value.
-
-   - pure_pointer: Constructs a Pure pointer from a C pointer (void*). */
-
 pure_expr *pure_symbol(int32_t sym);
 pure_expr *pure_int(int32_t i);
-pure_expr *pure_long(int64_t l);
-pure_expr *pure_bigint(int32_t size, const limb_t *limbs);
 pure_expr *pure_mpz(const mpz_t z);
 pure_expr *pure_double(double d);
 pure_expr *pure_pointer(void *p);
@@ -144,40 +127,40 @@
 pure_expr *pure_tuplel(size_t size, ...);
 pure_expr *pure_tuplev(size_t size, pure_expr **elems);
 
-/* Expression deconstructors for all the expression types above. These all
+/* Expression deconstructors for all of the expression types above. These
    return a bool value indicating whether the given expression is of the
-   corresponding type and, if so, set the remaining parameter pointers to the
+   corresponding type and, if so, set the remaining pointers to the
    corresponding values. Parameter pointers may be NULL in which case they are
-   not set and only the result of the type check is returned.
+   not set.
 
-   NOTES: pure_is_symbol will return true not only for constant and unbound
-   variable symbols, but also for arbitrary closures including local and
-   anonymous functions. In the case of an anonymous closure, the returned
-   symbol will be 0. You can check whether an expression actually represents a
-   named or anonymous closure using the funp and lambdap predicates from the
-   library API (see below).
+   Notes:
 
-   pure_is_long checks whether the result actually fits into a 64 bit integer.
-   pure_is_bigint mallocs the returned limb vector (if limbs!=NULL); the
-   caller is responsible for freeing it. */
+   - pure_is_mpz takes a pointer to an uninitialized mpz_t and initializes it
+     with a copy of the Pure bigint.
 
+   - pure_is_symbol will return true not only for (constant and unbound
+     variable) symbols, but also for arbitrary closures including local and
+     anonymous functions. In the case of an anonymous closure, the returned
+     symbol will be 0. You can check whether an expression actually represents
+     a named or anonymous closure using the funp and lambdap predicates from
+     the library API (see below). */
+
 bool pure_is_symbol(const pure_expr *x, int32_t *sym);
 bool pure_is_int(const pure_expr *x, int32_t *i);
-bool pure_is_long(const pure_expr *x, int64_t *l);
-bool pure_is_bigint(const pure_expr *x, int32_t *size, limb_t **limbs);
 bool pure_is_mpz(const pure_expr *x, mpz_t *z);
 bool pure_is_double(const pure_expr *x, double *d);
 bool pure_is_pointer(const pure_expr *x, void **p);
 
-/* String results are copied with the _dup routines (it is then the caller's
-   responsibility to free them when appropriate). pure_is_cstring_dup also
-   converts the string to the system encoding. The string value returned by
-   pure_is_string points directly to the string data in the Pure expression
-   and must not be changed by the caller. */
+/* String deconstructors. Here the string results are copied if using the _dup
+   routines (it is then the caller's responsibility to free them when
+   appropriate). pure_is_cstring_dup also converts the string to the system
+   encoding. The string value returned by pure_is_string points directly to
+   the string data in the Pure expression and must not be changed by the
+   caller. */
 
-bool pure_is_string(const pure_expr *x, const char **sym);
-bool pure_is_string_dup(const pure_expr *x, char **sym);
-bool pure_is_cstring_dup(const pure_expr *x, char **sym);
+bool pure_is_string(const pure_expr *x, const char **s);
+bool pure_is_string_dup(const pure_expr *x, char **s);
+bool pure_is_cstring_dup(const pure_expr *x, char **s);
 
 /* Deconstruct literal applications. */
 
@@ -228,6 +211,11 @@
 pure_expr *pure_clos(bool local, bool thunked, int32_t tag, uint32_t n,
 		     void *f, void *e, uint32_t m, /* m x pure_expr* */ ...);
 
+/* Additional bigint constructors. */
+
+pure_expr *pure_long(int64_t l);
+pure_expr *pure_bigint(int32_t size, const limb_t *limbs);
+
 /* Compare a bigint or string expression against a constant value. This is
    used by the pattern matching code. */
 


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.