use sort.ss in kw.ss too
svn: r9129
This commit is contained in:
parent
bfc990e3c5
commit
fcfaa3cc64
|
@ -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
|
||||
|
|
|
@ -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<=?)
|
||||
|
|
Loading…
Reference in New Issue
Block a user