quipu

Fork

[Quipu-dev] quipu/quipu: Add the 'nsort' interface & minor cleanup

scmno****@osdn***** scmno****@osdn*****
Wed Jan 17 07:06:43 JST 2018

• Previous message: [Quipu-dev] quipu/quipu: Fix disassembly output
• Next message: [Quipu-dev] quipu/quipu: Minor fixes here and there
• Messages sorted by: [ date ] [ thread ] [ subject ] [ author ]

changeset 6bd1b426ff1a in quipu/quipu
details: http://hg.osdn.jp/view/quipu/quipu?cmd=changeset;node=6bd1b426ff1a
user: Agustina Arzille <avarz****@riseu*****>
date: Tue Jan 16 19:06:25 2018 -0300
description: Add the 'nsort' interface & minor cleanup

diffstat:

 array.cpp    |  61 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-
 array.h      |   3 ++
 builtins.cpp |  26 +++++++++++++++++++++++-
 cons.cpp     |  28 +++++++++++++++++++++++++++
 cons.h       |   4 +++
 interp.cpp   |  30 ++++++++++++++++++----------
 6 files changed, 137 insertions(+), 15 deletions(-)

diffs (242 lines):

diff -r 41c9adc9a5f7 -r 6bd1b426ff1a array.cpp
--- a/array.cpp	Tue Jan 16 12:14:25 2018 -0300
+++ b/array.cpp	Tue Jan 16 19:06:25 2018 -0300
@@ -169,8 +169,7 @@
   if (ap->len == 0)
     qp_return (obj);
   else if (ap->flags & FLAGS_CONST)
-    interp->raise2 ("const-error", "nreverse:array: attempting "
-      "to modify read-only object");
+    interp->raise2 ("const-error", "nreverse:array: object is read-only");
 
   for (int i = 0, j = ap->len - 1; i < j; ++i, --j)
     {
@@ -196,6 +195,64 @@
   qp_return (ret);
 }
 
+object nsort_a (interpreter *interp, object obj)
+{
+  array *ap = as_array (obj);
+  if (ap->len <= 1)
+    qp_return (obj);
+  else if (ap->flags & FLAGS_CONST)
+    interp->raise2 ("arg-error", "nsort:array: object is read-only");
+
+  stackref v1 (interp, intobj (0)), v2 (interp, intobj (0));
+  object *wp = ap->data - 1;
+
+  for (int r = ap->len / 2; r > 0; --r)
+    for (int i = r ; ; )
+      {
+        int j = i + i;
+        if (j > ap->len)
+          break;
+        else if (j != ap->len && xcmp (interp,
+            *v1 = wp[j], *v2 = wp[j + 1]) < 0)
+          ++j;
+
+        if (xcmp (interp, *v1 = wp[i], *v2 = wp[j]) < 0)
+          {
+            interp->aux = wp[i];
+            wp[i] = wp[j], wp[j] = interp->aux;
+          }
+
+        i = j;
+      }
+
+  for (int s = ap->len - 1; s > 0; --s)
+    {
+      interp->aux = *ap->data;
+      *ap->data = ap->data[s];
+      ap->data[s] = interp->aux;
+
+      for (int i = 1 ; ; )
+        {
+          int j = i + i;
+          if (j > s)
+            break;
+          else if (j != s && xcmp (interp,
+              *v1 = wp[j], *v2 = wp[j + 1]) < 0)
+            ++j;
+
+          if (xcmp (interp, *v1 = wp[i], *v2 = wp[j]) < 0)
+            {
+              interp->aux = wp[i];
+              wp[i] = wp[j], wp[j] = interp->aux;
+            }
+
+          i = j;
+        }
+    }
+
+  qp_return (obj);
+}
+
 int write_a (interpreter *interp, stream *strm, object obj, io_info& info)
 {
   int ret = 0;
diff -r 41c9adc9a5f7 -r 6bd1b426ff1a array.h
--- a/array.h	Tue Jan 16 12:14:25 2018 -0300
+++ b/array.h	Tue Jan 16 19:06:25 2018 -0300
@@ -70,6 +70,9 @@
 // Destructively reverse an array.
 QP_EXPORT object nreverse_a (interpreter *__interp, object __obj);
 
+// Destructively sort an array.
+QP_EXPORT object nsort_a (interpreter *__interp, object __obj);
+
 // Write an array to a stream.
 QP_EXPORT int write_a (interpreter *__interp,
   stream *__strm, object __obj, io_info& __info);
diff -r 41c9adc9a5f7 -r 6bd1b426ff1a builtins.cpp
--- a/builtins.cpp	Tue Jan 16 12:14:25 2018 -0300
+++ b/builtins.cpp	Tue Jan 16 19:06:25 2018 -0300
@@ -1029,6 +1029,25 @@
   qp_return (strm->err_p () ? NIL : QP_S(t));
 }
 
+// XXX: Custom comparators.
+DEFBUILTIN (nsort_fct)
+{
+  if (argc != 1)
+    interp->raise_nargs ("nsort", 1, 1, argc);
+
+  switch (itype (*argv))
+    {
+      case typecode::CONS:
+        return (nsort_L (interp, *argv));
+      case typecode::ARRAY:
+        return (nsort_a (interp, *argv));
+      case typecode::TREE:
+        qp_return (*argv);
+      default:
+        interp->raise2 ("arg-error", "nsort: argument cannot be sorted");
+    }
+}
+
 // Names for the builtins.
 static const char BUILTIN_NAMES[] =
   "%make-exception\0"
@@ -1057,7 +1076,9 @@
   "not\0"
   "len\0"
   "%fmt-str\0"
-  "puts\0";
+  "puts\0"
+  "nsort\0"
+;
 
 // List of builtins.
 static const native_function::fn_type BUILTINS[] =
@@ -1092,7 +1113,8 @@
   not_fct,
   len_fct,
   p_fmt_str,
-  puts_fct
+  puts_fct,
+  nsort_fct
 };
 
 static native_function global_builtins[QP_NELEM (BUILTINS)];
diff -r 41c9adc9a5f7 -r 6bd1b426ff1a cons.cpp
--- a/cons.cpp	Tue Jan 16 12:14:25 2018 -0300
+++ b/cons.cpp	Tue Jan 16 19:06:25 2018 -0300
@@ -194,6 +194,34 @@
   qp_return (*tail);
 }
 
+object nsort_L (interpreter *interp, object obj)
+{
+  stackref start (interp, obj), tmp (interp, NIL), nm (interp, NIL);
+  while (xcdr (*start) != NIL)
+    {
+      *nm = *start;
+      for (*tmp = xcdr (*start); *tmp != NIL; *tmp = xcdr (*tmp))
+        if (!xcons_p (*tmp))
+          interp->raise2 ("arg-error", "nsort:cons: "
+            "argument must be a proper list");
+        else if (xcmp (interp, xcar (*nm), xcar (*tmp)) > 0)
+          *nm = *tmp;
+
+      if (*start != *nm)
+        {
+          interp->aux = xcar (*start);
+          xcar(*start) = xcar (*nm);
+          xcar(*nm) = interp->aux;
+        }
+
+      if (!xcons_p (*start = xcdr (*start)))
+        interp->raise2 ("arg-error", "nsort:cons: "
+          "argument must be a proper list");
+    }
+
+  qp_return (obj);
+}
+
 int write_L (interpreter *interp, stream *strm, object obj, io_info& info)
 {
   if (obj == NIL)
diff -r 41c9adc9a5f7 -r 6bd1b426ff1a cons.h
--- a/cons.h	Tue Jan 16 12:14:25 2018 -0300
+++ b/cons.h	Tue Jan 16 19:06:25 2018 -0300
@@ -125,6 +125,10 @@
 
 QP_EXPORT object nreverse_L (interpreter *__interp, object __obj);
 
+QP_EXPORT object nsort_L (interpreter *__interp, object __obj);
+
+QP_EXPORT object sort_L (interpreter *__interp, object __obj);
+
 extern bool init_cons (interpreter *__interp);
 
 QP_DECLS_END
diff -r 41c9adc9a5f7 -r 6bd1b426ff1a interp.cpp
--- a/interp.cpp	Tue Jan 16 12:14:25 2018 -0300
+++ b/interp.cpp	Tue Jan 16 19:06:25 2018 -0300
@@ -331,9 +331,10 @@
   if ((unsigned int)--signo >= QP_NSIG)
     return;
 
-  atomic_or (&this->sigpend_mask[signo / ATOMIC_BITS],
-    (intptr_t)1 << (signo % ATOMIC_BITS));
-  atomic_add (&this->nsigpend, 1);
+  atomic_t bit = (atomic_t)1 << (signo % ATOMIC_BITS);
+  atomic_t prev = atomic_or (&this->sigpend_mask[signo / ATOMIC_BITS], bit);
+  if ((prev & bit) == 0)
+    atomic_add (&this->nsigpend, 1);
 }
 
 static void
@@ -346,16 +347,23 @@
 
 void interpreter::handle_intrs ()
 {
-  while (this->nsigpend)
-    for (int i = 0; i < QP_NSIG; ++i)
-      if (this->sigpend_mask[i / ATOMIC_BITS] &
-          ((intptr_t)1 << (i % ATOMIC_BITS)))
+  if (qp_likely (!this->nsigpend))
+    return;
+
+  do
+    {
+      for (int i = 0; i < QP_NSIG; ++i)
         {
-          atomic_and (&this->sigpend_mask[i / ATOMIC_BITS],
-            ~((intptr_t)1 << (i % ATOMIC_BITS)));
-          atomic_add (&this->nsigpend, -1);
-          handle_sig (this, i + 1);
+          atomic_t bit = (atomic_t)1 << (i % ATOMIC_BITS);
+          if (this->sigpend_mask[i / ATOMIC_BITS] & bit)
+            {
+              atomic_and (&this->sigpend_mask[i / ATOMIC_BITS], ~bit);
+              atomic_add (&this->nsigpend, -1);
+              handle_sig (this, i + 1);
+            }
         }
+    }
+  while (this->nsigpend > 0);
 }
 
 QP_DECLS_END

• Previous message: [Quipu-dev] quipu/quipu: Fix disassembly output
• Next message: [Quipu-dev] quipu/quipu: Minor fixes here and there
• Messages sorted by: [ date ] [ thread ] [ subject ] [ author ]