suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

use sort.ss in kw.ss too

Browse Source 
svn: r9129
This commit is contained in:
Eli Barzilay 2008-04-02 00:07:45 +00:00
parent bfc990e3c5
commit fcfaa3cc64
2 changed files with 18 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
collects/scheme/private/kw.ss
View File

@ -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

24
collects/scheme/private/sort.ss
View File

@ -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<=?)