From b66c116183f1de2ff3ffdbfd9d9568eec06b222a Mon Sep 17 00:00:00 2001
From: Alex Shinn <ashinn@users.noreply.github.com>
Date: Mon, 28 Dec 2009 19:13:09 +0900
Subject: [PATCH] adding srfi-95

---
 Makefile             |   2 +-
 lib/srfi/95.module   |   7 ++
 lib/srfi/95/qsort.c  | 167 +++++++++++++++++++++++++++++++++++++++++++
 lib/srfi/95/sort.scm |  67 +++++++++++++++++
 4 files changed, 242 insertions(+), 1 deletion(-)
 create mode 100644 lib/srfi/95.module
 create mode 100644 lib/srfi/95/qsort.c
 create mode 100644 lib/srfi/95/sort.scm

diff --git a/Makefile b/Makefile
index ebda90c0..85904625 100644
--- a/Makefile
+++ b/Makefile
@@ -81,7 +81,7 @@ endif
 all: chibi-scheme$(EXE) libs
 
 COMPILED_LIBS := lib/srfi/27/rand$(SO) lib/srfi/33/bit$(SO) \
-	lib/srfi/69/hash$(SO) lib/srfi/98/env$(SO) \
+	lib/srfi/69/hash$(SO) lib/srfi/95/qsort$(SO) lib/srfi/98/env$(SO) \
 	lib/chibi/ast$(SO) lib/chibi/net$(SO) lib/chibi/filesystem$(SO) \
 	lib/chibi/process$(SO) lib/chibi/time$(SO) lib/chibi/system$(SO) \
 	lib/chibi/heap-stats$(SO) lib/chibi/disasm$(SO)
diff --git a/lib/srfi/95.module b/lib/srfi/95.module
new file mode 100644
index 00000000..25e0d3ff
--- /dev/null
+++ b/lib/srfi/95.module
@@ -0,0 +1,7 @@
+
+(define-module (srfi 95)
+  (export sorted? merge merge! sort sort!)
+  (import-immutable (scheme))
+  (include-shared "95/qsort")
+  (include "95/sort.scm"))
+
diff --git a/lib/srfi/95/qsort.c b/lib/srfi/95/qsort.c
new file mode 100644
index 00000000..ca2bb017
--- /dev/null
+++ b/lib/srfi/95/qsort.c
@@ -0,0 +1,167 @@
+
+#include "chibi/eval.h"
+
+#define swap(tmp_var, a, b) (tmp_var=a, a=b, b=tmp_var)
+
+static sexp sexp_vector_copy_to_list (sexp ctx, sexp vec, sexp seq) {
+  sexp_sint_t i;
+  sexp ls, *data=sexp_vector_data(vec);
+  for (i=0, ls=seq; sexp_pairp(ls); i++, ls=sexp_cdr(ls))
+    sexp_car(ls) = data[i];
+  return seq;
+}
+
+static sexp sexp_vector_nreverse (sexp ctx, sexp vec) {
+  int i, j;
+  sexp tmp, *data=sexp_vector_data(vec);
+  for (i=0, j=sexp_vector_length(vec)-1; i<j; i++, j--)
+    swap(tmp, data[i], data[j]);
+  return vec;
+}
+
+static int sexp_basic_comparator (sexp op) {
+  if (sexp_not(op))
+    return 1;
+  if (! sexp_opcodep(op))
+    return 0;
+  if (sexp_opcode_class(op) == SEXP_OPC_ARITHMETIC_CMP)
+    return 1;
+  return 0;
+}
+
+static int sexp_object_compare (sexp ctx, sexp a, sexp b) {
+  int res;
+  if (sexp_pointerp(a)) {
+    if (sexp_pointerp(b)) {
+      if (sexp_pointer_tag(a) != sexp_pointer_tag(b)) {
+        res = sexp_pointer_tag(a) - sexp_pointer_tag(b);
+      } else {
+        switch (sexp_pointer_tag(a)) {
+        case SEXP_FLONUM:
+          res = sexp_flonum_value(a) - sexp_flonum_value(b);
+          break;
+        case SEXP_BIGNUM:
+          res = sexp_bignum_compare(a, b);
+          break;
+        case SEXP_STRING:
+          res = strcmp(sexp_string_data(a), sexp_string_data(b));
+          break;
+        default:
+          res = 0;
+          break;
+        }
+      }
+    } else {
+      res = 1;
+    }
+  } else if (sexp_pointerp(b)) {
+    res = -1;
+  } else {
+    res = (sexp_sint_t)a - (sexp_sint_t)b;
+  }
+  return res;
+}
+
+static void sexp_qsort (sexp ctx, sexp *vec, sexp_sint_t lo, sexp_sint_t hi) {
+  sexp_sint_t mid, i, j;
+  sexp tmp, tmp2;
+ loop:
+  if (lo < hi) {
+    mid = lo + (hi-lo)/2;
+    swap(tmp, vec[mid], vec[hi]);
+    for (i=j=lo; i < hi; i++)
+      if (sexp_object_compare(ctx, vec[i], tmp) < 0)
+        swap(tmp2, vec[i], vec[j]), j++;
+    swap(tmp, vec[j], vec[hi]);
+    if ((hi-lo) > 2) {
+      sexp_qsort(ctx, vec, lo, j-1);
+      lo = j+1;
+      goto loop;
+    }
+  }
+}
+
+static sexp sexp_qsort_less (sexp ctx, sexp *vec,
+                             sexp_sint_t lo, sexp_sint_t hi,
+                             sexp less, sexp key) {
+  sexp_sint_t mid, i, j;
+  sexp tmp, res, args1;
+  sexp_gc_var3(a, b, args2);
+  sexp_gc_preserve3(ctx, a, b, args2);
+  args2 = sexp_list2(ctx, SEXP_VOID, SEXP_VOID);
+  args1 = sexp_cdr(args2);
+ loop:
+  if (lo >= hi) {
+    res = SEXP_VOID;
+  } else {
+    mid = lo + (hi-lo)/2;
+    swap(tmp, vec[mid], vec[hi]);
+    sexp_car(args1) = tmp;
+    b = sexp_apply(ctx, key, args1);
+    for (i=j=lo; i < hi; i++) {
+      sexp_car(args1) = vec[i];
+      a = sexp_apply(ctx, key, args1);
+      sexp_car(args2) = a;
+      sexp_car(args1) = b;
+      res = sexp_apply(ctx, less, args2);
+      if (sexp_exceptionp(res))
+        goto done;
+      else if (sexp_truep(res))
+        swap(res, vec[i], vec[j]), j++;
+    }
+    swap(tmp, vec[j], vec[hi]);
+    if ((hi-lo) > 2) {
+      res = sexp_qsort_less(ctx, vec, lo, j-1, less, key);
+      if (sexp_exceptionp(res))
+        goto done;
+      lo = j+1;
+      goto loop;
+    }
+  }
+ done:
+  sexp_gc_release3(ctx);
+  return res;
+}
+
+static sexp sexp_sort_x (sexp ctx, sexp seq, sexp less, sexp key) {
+  sexp_sint_t len;
+  sexp res, *data;
+  sexp_gc_var1(vec);
+
+  if (sexp_nullp(seq)) return seq;
+
+  sexp_gc_preserve1(ctx, vec);
+
+  vec = (sexp_truep(sexp_listp(ctx, seq)) ? sexp_list_to_vector(ctx, seq) : seq);
+
+  if (! sexp_vectorp(vec)) {
+    res = sexp_type_exception(ctx, "sort: not a vector", vec);
+  } else {
+    data = sexp_vector_data(vec);
+    len = sexp_vector_length(vec);
+    if (sexp_not(key) && sexp_basic_comparator(less)) {
+      sexp_qsort(ctx, data, 0, len-1);
+      if (sexp_opcodep(less) && sexp_opcode_inverse(less))
+        sexp_vector_nreverse(ctx, vec);
+    } else if (! (sexp_procedurep(less) || sexp_opcodep(less))) {
+      res = sexp_type_exception(ctx, "sort: not a procedure", less);
+    } else if (! (sexp_procedurep(key) || sexp_opcodep(key) || sexp_not(key))) {
+      res = sexp_type_exception(ctx, "sort: not a procedure", less);
+    } else {
+      res = sexp_qsort_less(ctx, data, 0, len-1, less, key);
+    }
+  }
+
+  if (sexp_pairp(seq))
+    res = sexp_vector_copy_to_list(ctx, vec, seq);
+  else if (! sexp_exceptionp(res))
+    res = vec;
+
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+sexp sexp_init_library (sexp ctx, sexp env) {
+  sexp_define_foreign_opt(ctx, env, "sort!", 3, sexp_sort_x, SEXP_FALSE);
+  return SEXP_VOID;
+}
diff --git a/lib/srfi/95/sort.scm b/lib/srfi/95/sort.scm
new file mode 100644
index 00000000..0659c3c9
--- /dev/null
+++ b/lib/srfi/95/sort.scm
@@ -0,0 +1,67 @@
+
+(define (copy seq)
+  (if (vector? seq)
+      (let* ((len (vector-length seq))
+             (res (make-vector len)))
+        (do ((i (- len 1) (- i 1)))
+            ((< i 0) res)
+          (vector-set! res i (vector-ref seq i))))
+      (map (lambda (x) x) seq)))
+
+(define (sort seq . o)
+  (let ((less (and (pair? o) (car o)))
+        (key (and (pair? o) (pair? (cdr o)) (car (cdr o)))))
+    (sort! (copy seq) less key)))
+
+(define (sorted? seq less . o)
+  (let ((key (if (pair? o) (car o) (lambda (x) x))))
+    (cond
+     ((vector? seq)
+      (let ((len (- (vector-length seq) 1)))
+        (let lp ((i 0))
+          (cond
+           ((>= i len) #t)
+           ((less (key (vector-ref seq (+ i 1))) (key (vector-ref seq i))) #f)
+           (else (lp (+ i 1)))))))
+     ((null? seq)
+      #f)
+     (else
+      (let lp ((ls1 seq) (ls2 (cdr seq)))
+        (cond ((null? ls2) #t)
+              ((less (key (car ls2)) (key (car ls1))) #f)
+              (else (lp ls2 (cdr ls2)))))))))
+
+(define (merge! ls1 ls2 less . o)
+  (let ((key (if (pair? o) (car o) (lambda (x) x))))
+    (define (lp prev ls1 ls2 a b less key)
+      (cond
+       ((less a b)
+        (if (null? (cdr ls1))
+            (set-cdr! ls1 ls2)
+            (lp ls1 (cdr ls1) ls2 (key (car (cdr ls1))) b less key)))
+       (else
+        (set-cdr! prev ls2)
+        (if (null? (cdr ls2))
+            (set-cdr! ls2 ls1)
+            (lp ls2 (cdr ls2) ls1 (key (car (cdr ls2))) a less key)))))
+    (cond
+     ((null? ls1) ls2)
+     ((null? ls2) ls1)
+     (else
+      (let ((a (key (car ls1)))
+            (b (key (car ls2))))
+        (cond
+         ((less a b)
+          (if (null? (cdr ls1))
+              (set-cdr! ls1 ls2)
+              (lp ls1 (cdr ls1) ls2 (key (car (cdr ls1))) b less key))
+          ls1)
+         (else
+          (if (null? (cdr ls2))
+              (set-cdr! ls2 ls1)
+              (lp ls2 (cdr ls2) ls1 (key (car (cdr ls2))) a less key))
+          ls2)))))))
+
+(define (merge ls1 ls2 less . o)
+  (let ((key (if (pair? o) (car o) (lambda (x) x))))
+    (merge! (copy ls1) (copy ls2) less key)))