From fcfaa3cc6441ff10df83e56993f8141fdf932336 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Wed, 2 Apr 2008 00:07:45 +0000
Subject: [PATCH] use sort.ss in kw.ss too

svn: r9129
---
 collects/scheme/private/kw.ss   | 34 +++++----------------------------
 collects/scheme/private/sort.ss | 24 ++++++++++++-----------
 2 files changed, 18 insertions(+), 40 deletions(-)

diff --git a/collects/scheme/private/kw.ss b/collects/scheme/private/kw.ss
index ce23b17ef7..ffbd397b5b 100644
--- a/collects/scheme/private/kw.ss
+++ b/collects/scheme/private/kw.ss
@@ -1,6 +1,6 @@
 (module kw '#%kernel
-  (#%require "define.ss" 
-             "small-scheme.ss" 
+  (#%require "define.ss"
+             "small-scheme.ss"
              "more-scheme.ss"
              (for-syntax '#%kernel
                          "stx.ss"
@@ -8,7 +8,8 @@
                          "stxcase-scheme.ss"
                          "name.ss"
                          "norm-define.ss"
-                         "qqstx.ss"))
+                         "qqstx.ss"
+                         "sort.ss"))
 
   (#%provide new-lambda new-λ
              new-define
@@ -128,7 +129,7 @@
           [(null? (cdr ks)) (void)]
           [(or (not (pair? (cdr ks)))
                (not (keyword? (cadr ks))))
-           (loop (cdr ks))]        
+           (loop (cdr ks))]
           [(keyword<? (car ks) (cadr ks))
            (loop (cdr ks))]
           [else (type-error "sorted list of keywords" 1)]))
@@ -171,31 +172,6 @@
      [else (raise-type-error 'procedure-keywords
                              "procedure"
                              p)]))
-  
-  ;; ----------------------------------------
-  ;; Sorting keywords.
-  
-  ;; The sort in "list.ss" should be moved into it's own library, 
-  ;; so we can use it here without requiring lots of other stuff.)
-  
-  (define-for-syntax (sort l <?)
-    (cond
-      [(null? l) null]
-      [(null? (cdr l)) l]
-      [else (let loop ([l l]
-                       [a null]
-                       [b null])
-              (cond
-                [(null? l) (let loop ([a (sort a <?)]
-                                      [b (sort b <?)])
-                             (cond
-                               [(null? a) b]
-                               [(null? b) a]
-                               [(<? (car a) (car b))
-                                (cons (car a) (loop (cdr a) b))]
-                               [else
-                                (cons (car b) (loop a (cdr b)))]))]
-                [else (loop (cdr l) (cons (car l) b) a)]))]))
 
   ;; ----------------------------------------
   ;; `lambda' with optional and keyword arguments
diff --git a/collects/scheme/private/sort.ss b/collects/scheme/private/sort.ss
index 462870fb2e..9564d1f504 100644
--- a/collects/scheme/private/sort.ss
+++ b/collects/scheme/private/sort.ss
@@ -1,9 +1,8 @@
-(module sort "pre-base.ss"
+(module sort '#%kernel
 
-(provide sort)
+(#%require "small-scheme.ss" "define.ss" (for-syntax "stxcase-scheme.ss"))
 
-(#%require (for-syntax "stxcase-scheme.ss")
-           (for-syntax "pre-base.ss"))
+(#%provide sort)
 
 ;; This is a destructive stable merge-sort, adapted from slib and improved by
 ;; Eli Barzilay.
@@ -25,6 +24,11 @@
 
 (define sort (let ()
 
+(define-syntax define-syntax-rule
+  (syntax-rules ()
+    [(dr (foo . pattern) template)
+     (define-syntax foo (syntax-rules () [(_ . pattern) template]))]))
+
 (define-syntax-rule (sort-internal-body lst *less? n has-getkey? getkey)
   (begin
     (define-syntax-rule (less? x y)
@@ -95,13 +99,11 @@
 
 (define sort-internals (make-hash-table))
 (define _
-  (let-syntax ([precomp
-                (syntax-rules ()
-                  [(_ less? more ...)
-                   (let ([proc (lambda (lst n)
-                                 (sort-internal-body lst less? n #f #f))])
-                     (hash-table-put! sort-internals less? proc)
-                     (hash-table-put! sort-internals more proc) ...)])])
+  (let ()
+    (define-syntax-rule (precomp less? more ...)
+      (let ([proc (lambda (lst n) (sort-internal-body lst less? n #f #f))])
+        (hash-table-put! sort-internals less? proc)
+        (hash-table-put! sort-internals more proc) ...))
     (precomp < <=)
     (precomp > >=)
     (precomp string<? string<=?)