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

removed spidey.ss

Browse Source 
svn: r3132
This commit is contained in:
Eli Barzilay 2006-05-30 20:04:18 +00:00
parent f662133a9a
commit 185da3d90d
6 changed files with 455 additions and 637 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/compiler/info.ss
View File

@ -9,4 +9,4 @@
(define mred-launcher-names (list "gmzc")) (define mred-launcher-names (list "gmzc"))
(define compile-omit-files (define compile-omit-files
'("mrspidey.ss" "mrspideyf.ss" "mrspideyi.ss" "embedr.ss"))) '("embedr.ss")))

25
collects/frtime/etc.ss
View File

@ -1,7 +1,6 @@
(module etc (lib "frtime.ss" "frtime") (module etc (lib "frtime.ss" "frtime")
(require (lib "spidey.ss") (require (lib "main-collects.ss" "setup"))
(lib "main-collects.ss" "setup"))
(require-for-syntax (lib "kerncase.ss" "syntax") (require-for-syntax (lib "kerncase.ss" "syntax")
(lib "stx.ss" "syntax") (lib "stx.ss" "syntax")
(lib "name.ss" "syntax") (lib "name.ss" "syntax")
@ -39,11 +38,10 @@
(define true #t) (define true #t)
(define false #f) (define false #f)
(define identity (polymorphic (lambda (x) x))) (define identity (lambda (x) x))
(define compose (define compose
(polymorphic (case-lambda
(case-lambda
[(f) (if (procedure? f) f (raise-type-error 'compose "procedure" f))] [(f) (if (procedure? f) f (raise-type-error 'compose "procedure" f))]
[(f g) [(f g)
(let ([f (compose f)] (let ([f (compose f)]
@ -63,7 +61,7 @@
f)))))] f)))))]
[(f . more) [(f . more)
(let ([m (apply compose more)]) (let ([m (apply compose more)])
(compose f m))]))) (compose f m))]))
#| #|
@ -88,8 +86,7 @@
#| #|
(define build-vector (define build-vector
(polymorphic (lambda (n fcn)
(lambda (n fcn)
(unless (and (integer? n) (exact? n) (>= n 0)) (unless (and (integer? n) (exact? n) (>= n 0))
(error 'build-vector "~s must be an exact integer >= 0" n)) (error 'build-vector "~s must be an exact integer >= 0" n))
(unless (procedure? fcn) (unless (procedure? fcn)
@ -99,11 +96,10 @@
(if (= i n) vec (if (= i n) vec
(begin (begin
(vector-set! vec i (fcn i)) (vector-set! vec i (fcn i))
(loop (add1 i))))))))) (loop (add1 i))))))))
|# |#
(define build-list (define build-list
(polymorphic (lambda (n fcn)
(lambda (n fcn)
(unless (and (integer? n) (exact? n) (>= n 0)) (unless (and (integer? n) (exact? n) (>= n 0))
(error 'build-list "~s must be an exact integer >= 0" n)) (error 'build-list "~s must be an exact integer >= 0" n))
(unless (procedure? fcn) (unless (procedure? fcn)
@ -111,15 +107,14 @@
(let loop ([i (sub1 n)] [p '()]) (let loop ([i (sub1 n)] [p '()])
(if (>= i 0) (if (>= i 0)
(loop (sub1 i) (cons (fcn i) p)) (loop (sub1 i) (cons (fcn i) p))
p))))) p))))
(define loop-until (define loop-until
(polymorphic (lambda (start done? next body)
(lambda (start done? next body)
(let loop ([i start]) (let loop ([i start])
(unless (done? i) (unless (done? i)
(body i) (body i)
(loop (next i))))))) (loop (next i))))))
(define boolean=? (define boolean=?
(lambda (x y) (lambda (x y)

613
collects/mzlib/etc.ss
View File

@ -1,15 +1,13 @@
(module etc mzscheme (module etc mzscheme
(require "spidey.ss" (require (lib "main-collects.ss" "setup"))
(lib "main-collects.ss" "setup"))
(require-for-syntax (lib "kerncase.ss" "syntax") (require-for-syntax (lib "kerncase.ss" "syntax")
(lib "stx.ss" "syntax") (lib "stx.ss" "syntax")
(lib "name.ss" "syntax") (lib "name.ss" "syntax")
(lib "context.ss" "syntax") (lib "context.ss" "syntax")
(lib "main-collects.ss" "setup") (lib "main-collects.ss" "setup")
"list.ss"
"private/stxset.ss") "private/stxset.ss")
@ -48,11 +46,10 @@
(define true #t) (define true #t)
(define false #f) (define false #f)
(define identity (polymorphic (lambda (x) x))) (define identity (lambda (x) x))
(define compose (define compose
(polymorphic (case-lambda
(case-lambda
[(f) (if (procedure? f) f (raise-type-error 'compose "procedure" f))] [(f) (if (procedure? f) f (raise-type-error 'compose "procedure" f))]
[(f g) [(f g)
(let ([f (compose f)] (let ([f (compose f)]
@ -72,379 +69,299 @@
f)))))] f)))))]
[(f . more) [(f . more)
(let ([m (apply compose more)]) (let ([m (apply compose more)])
(compose f m))]))) (compose f m))]))
(define build-string (define (build-string n fcn)
(lambda (n fcn) (unless (and (integer? n) (exact? n) (>= n 0))
(unless (and (integer? n) (exact? n) (>= n 0)) (error 'build-string "~s must be an exact integer >= 0" n))
(error 'build-string "~s must be an exact integer >= 0" n)) (unless (procedure? fcn)
(unless (procedure? fcn) (error 'build-string "~s must be a procedure" fcn))
(error 'build-string "~s must be a procedure" fcn)) (let ([str (make-string n)])
(let ((str (make-string n))) (let loop ((i 0))
(let loop ((i 0))
(if (= i n) (if (= i n)
str str
(begin (begin (string-set! str i (fcn i)) (loop (add1 i)))))))
(string-set! str i (fcn i))
(loop (add1 i))))))))
;; (build-vector n f) returns a vector 0..n-1 where the ith element is (f i). ;; (build-vector n f) returns a vector 0..n-1 where the ith element is (f i).
;; The eval order is guaranteed to be: 0, 1, 2, ..., n-1. ;; The eval order is guaranteed to be: 0, 1, 2, ..., n-1.
;; eg: (build-vector 4 (lambda (i) i)) ==> #4(0 1 2 3) ;; eg: (build-vector 4 (lambda (i) i)) ==> #4(0 1 2 3)
(define build-vector (define (build-vector n fcn)
(polymorphic (unless (and (integer? n) (exact? n) (>= n 0))
(lambda (n fcn) (error 'build-vector "~s must be an exact integer >= 0" n))
(unless (and (integer? n) (exact? n) (>= n 0)) (unless (procedure? fcn)
(error 'build-vector "~s must be an exact integer >= 0" n)) (error 'build-vector "~s must be a procedure" fcn))
(unless (procedure? fcn) (let ([vec (make-vector n)])
(error 'build-vector "~s must be a procedure" fcn)) (let loop ((i 0))
(let ((vec (make-vector n))) (if (= i n)
(let loop ((i 0)) vec
(if (= i n) vec (begin (vector-set! vec i (fcn i)) (loop (add1 i)))))))
(begin
(vector-set! vec i (fcn i))
(loop (add1 i)))))))))
(define build-list (define (build-list n fcn)
(polymorphic (unless (and (integer? n) (exact? n) (>= n 0))
(lambda (n fcn) (error 'build-list "~s must be an exact integer >= 0" n))
(unless (and (integer? n) (exact? n) (>= n 0)) (unless (procedure? fcn)
(error 'build-list "~s must be an exact integer >= 0" n)) (error 'build-list "~s must be a procedure" fcn))
(unless (procedure? fcn) (if (zero? n)
(error 'build-list "~s must be a procedure" fcn)) '()
(if (zero? n) '() (let ([head (list (fcn 0))])
(let ([head (list (fcn 0))]) (let loop ([i 1] [p head])
(let loop ([i 1] [p head]) (if (= i n)
(if (= i n) head head
(begin (begin (set-cdr! p (list (fcn i)))
(set-cdr! p (list (fcn i))) (loop (add1 i) (cdr p))))))))
(loop (add1 i) (cdr p))))))))))
(define loop-until (define (loop-until start done? next body)
(polymorphic (let loop ([i start])
(lambda (start done? next body) (unless (done? i)
(let loop ([i start]) (body i)
(unless (done? i) (loop (next i)))))
(body i)
(loop (next i)))))))
(define boolean=? (define (boolean=? x y)
(lambda (x y) (unless (and (boolean? x) (boolean? y))
(unless (and (boolean? x) (raise-type-error 'boolean=? "boolean" (if (boolean? x) y x)))
(boolean? y))
(raise-type-error 'boolean=?
"boolean"
(if (boolean? x) y x)))
(eq? x y)))
(define (symbol=? x y)
(unless (and (symbol? x)
(symbol? y))
(raise-type-error 'symbol=? "symbol"
(if (symbol? x) y x)))
(eq? x y)) (eq? x y))
(define-syntax opt-lambda (define (symbol=? x y)
(lambda (stx) (unless (and (symbol? x) (symbol? y))
(with-syntax ([name (or (syntax-local-infer-name stx) (raise-type-error 'symbol=? "symbol" (if (symbol? x) y x)))
(quote-syntax opt-lambda-proc))]) (eq? x y))
(syntax-case stx ()
[(_ args body1 body ...)
(let ([clauses (let loop ([pre-args null]
[args (syntax args)]
[needs-default? #f])
(syntax-case args ()
[id
(identifier? (syntax id))
(with-syntax ([(pre-arg ...) pre-args])
(syntax ([(pre-arg ... . id)
body1 body ...])))]
[()
(with-syntax ([(pre-arg ...) pre-args])
(syntax ([(pre-arg ...)
body1 body ...])))]
[(id . rest)
(identifier? (syntax id))
(begin
(when needs-default?
(raise-syntax-error
#f
"default value missing"
stx
(syntax id)))
(loop (append pre-args (list (syntax id)))
(syntax rest)
#f))]
[([id default] . rest)
(identifier? (syntax id))
(with-syntax ([rest (loop (append pre-args (list (syntax id)))
(syntax rest)
#t)]
[(pre-arg ...) pre-args])
(syntax ([(pre-arg ...) (name pre-arg ... default)]
. rest)))]
[(bad . rest)
(raise-syntax-error
#f
"not an identifier or identifier with default"
stx
(syntax bad))]
[else
(raise-syntax-error
#f
"bad identifier sequence"
stx
(syntax args))]))])
(with-syntax ([clauses clauses])
(syntax/loc stx
(letrec ([name
(case-lambda
. clauses)])
name))))]))))
(define-syntax local (define-syntax (opt-lambda stx)
(lambda (stx) (with-syntax ([name (or (syntax-local-infer-name stx)
(quote-syntax opt-lambda-proc))])
(syntax-case stx () (syntax-case stx ()
[(_ (defn ...) body1 body ...) [(_ args body1 body ...)
(let ([defs (let ([expand-context (generate-expand-context)]) (let ([clauses (let loop ([pre-args null]
(let loop ([defns (syntax->list (syntax (defn ...)))]) [args (syntax args)]
(apply [needs-default? #f])
append (syntax-case args ()
(map [id
(lambda (defn) (identifier? (syntax id))
(let ([d (local-expand (with-syntax ([(pre-arg ...) pre-args])
defn (syntax ([(pre-arg ... . id)
expand-context body1 body ...])))]
(kernel-form-identifier-list [()
(quote-syntax here)))] (with-syntax ([(pre-arg ...) pre-args])
[check-ids (lambda (ids) (syntax ([(pre-arg ...)
(for-each body1 body ...])))]
(lambda (id) [(id . rest)
(unless (identifier? id) (identifier? (syntax id))
(raise-syntax-error (begin
#f (when needs-default?
"not an identifier for definition" (raise-syntax-error
stx #f "default value missing" stx (syntax id)))
id))) (loop (append pre-args (list (syntax id)))
ids))]) (syntax rest)
(syntax-case d (define-values define-syntaxes begin) #f))]
[(begin defn ...) [([id default] . rest)
(loop (syntax->list (syntax (defn ...))))] (identifier? (syntax id))
[(define-values (id ...) body) (with-syntax ([rest (loop (append pre-args (list (syntax id)))
(begin (syntax rest)
(check-ids (syntax->list (syntax (id ...)))) #t)]
(list d))] [(pre-arg ...) pre-args])
[(define-values . rest) (syntax ([(pre-arg ...) (name pre-arg ... default)]
(raise-syntax-error . rest)))]
#f [(bad . rest)
"ill-formed definition" (raise-syntax-error
stx #f
d)] "not an identifier or identifier with default"
[(define-syntaxes (id ...) body) stx
(begin (syntax bad))]
(check-ids (syntax->list (syntax (id ...)))) [else
(list d))] (raise-syntax-error
[(define-syntaxes . rest) #f "bad identifier sequence" stx (syntax args))]))])
(raise-syntax-error (with-syntax ([clauses clauses])
#f (syntax/loc stx
"ill-formed definition" (letrec ([name (case-lambda . clauses)]) name))))])))
stx
d)] (define-syntax (local stx)
[_else (syntax-case stx ()
(raise-syntax-error [(_ (defn ...) body1 body ...)
#f (let ([defs (let ([expand-context (generate-expand-context)])
"not a definition" (let loop ([defns (syntax->list (syntax (defn ...)))])
stx (apply
defn)]))) append
defns))))]) (map
(let ([ids (apply append (lambda (defn)
(map (let ([d (local-expand
(lambda (d) defn
(syntax-case d () expand-context
[(_ ids . __) (kernel-form-identifier-list
(syntax->list (syntax ids))])) (quote-syntax here)))]
defs))]) [check-ids (lambda (ids)
(let ([dup (check-duplicate-identifier ids)]) (for-each
(when dup (lambda (id)
(raise-syntax-error (unless (identifier? id)
#f (raise-syntax-error
"duplicate identifier" #f
stx "not an identifier for definition"
dup))) stx
(with-syntax ([(def ...) defs]) id)))
(syntax/loc ids))])
stx (syntax-case d (define-values define-syntaxes begin)
(let () [(begin defn ...)
def ... (loop (syntax->list (syntax (defn ...))))]
(let () [(define-values (id ...) body)
body1 (begin
body ...))))))] (check-ids (syntax->list (syntax (id ...))))
[(_ x body1 body ...) (list d))]
(raise-syntax-error [(define-values . rest)
#f (raise-syntax-error
"not a definition sequence" #f "ill-formed definition" stx d)]
stx [(define-syntaxes (id ...) body)
(syntax x))]))) (begin
(check-ids (syntax->list (syntax (id ...))))
(list d))]
[(define-syntaxes . rest)
(raise-syntax-error
#f "ill-formed definition" stx d)]
[_else
(raise-syntax-error
#f "not a definition" stx defn)])))
defns))))])
(let ([ids (apply append
(map
(lambda (d)
(syntax-case d ()
[(_ ids . __) (syntax->list (syntax ids))]))
defs))])
(let ([dup (check-duplicate-identifier ids)])
(when dup
(raise-syntax-error #f "duplicate identifier" stx dup)))
(with-syntax ([(def ...) defs])
(syntax/loc stx
(let () def ... (let () body1 body ...))))))]
[(_ x body1 body ...)
(raise-syntax-error #f "not a definition sequence" stx (syntax x))]))
;; recur is another name for 'let' in a named let ;; recur is another name for 'let' in a named let
(define-syntax recur (define-syntax (recur stx)
(lambda (stx) (syntax-case stx ()
(syntax-case stx () [(_ . rest) (syntax/loc stx (let . rest))]))
[(_ . rest)
(syntax/loc stx (let . rest))])))
;; define a recursive value ;; define a recursive value
(define-syntax rec (define-syntax (rec stx)
(lambda (stx) (syntax-case stx ()
(syntax-case stx () [(_ name expr)
[(_ name expr) (begin (unless (identifier? (syntax name))
(begin (raise-syntax-error #f "not an identifier" stx (syntax name)))
(unless (identifier? (syntax name)) (syntax/loc stx (letrec ([name expr]) name)))]))
(raise-syntax-error
#f
"not an identifier"
stx
(syntax name)))
(syntax/loc stx
(letrec ([name expr])
name)))])))
(define-syntax evcase (define-syntax (evcase stx)
(lambda (stx) (syntax-case stx ()
(syntax-case stx () [(_ val [test body ...] ...)
[(_ val [test body ...] ...) (let ([tests (syntax->list (syntax (test ...)))])
(let ([tests (syntax->list (syntax (test ...)))]) (with-syntax ([(a-test ...)
(with-syntax ([(a-test ...) (map (lambda (t)
(map (syntax-case t (else)
(lambda (t) [else (syntax #t)]
(syntax-case t (else) [_else (with-syntax ([t t])
[else (syntax #t)] (syntax (eqv? evcase-v t)))]))
[_else (with-syntax ([t t]) tests)])
(syntax (eqv? evcase-v t)))])) ;; Make sure else is last:
tests)]) (unless (null? tests)
;; Make sure else is last: (let loop ([tests tests])
(unless (null? tests) (unless (null? (cdr tests))
(let loop ([tests tests]) (when (and (identifier? (car tests))
(unless (null? (cdr tests)) (module-identifier=? (quote-syntax else) (car tests)))
(when (and (identifier? (car tests)) (raise-syntax-error
(module-identifier=? (quote-syntax else) (car tests))) #f "else is not in last clause" stx (car tests)))
(raise-syntax-error (loop (cdr tests)))))
#f (syntax/loc stx
"else is not in last clause" (let ([evcase-v val])
stx (cond [a-test (begin body ...)]
(car tests))) ...)))))]
(loop (cdr tests))))) [(_ val something ...)
(syntax/loc stx ;; Provide a good error message:
(let ([evcase-v val]) (for-each
(cond (lambda (s)
[a-test (syntax-case s ()
(begin body ...)] [(t a ...) (raise-syntax-error #f "invalid clause" stx s)]))
...)))))] (syntax->list (syntax (something ...))))]))
[(_ val something ...)
;; Provide a good error message:
(for-each
(lambda (s)
(syntax-case s ()
[(t a ...)
(raise-syntax-error
#f
"invalid clause"
stx
s)]))
(syntax->list (syntax (something ...))))])))
(define-syntax nor (define-syntax (nor stx)
(lambda (stx) (syntax-case stx ()
(syntax-case stx () [(_ expr ...) (syntax/loc stx (not (or expr ...)))]))
[(_ expr ...)
(syntax/loc stx (not (or expr ...)))])))
(define-syntax nand (define-syntax (nand stx)
(lambda (stx) (syntax-case stx ()
(syntax-case stx () [(_ expr ...) (syntax/loc stx (not (and expr ...)))]))
[(_ expr ...)
(syntax/loc stx (not (and expr ...)))])))
(define-syntax let+ (define-syntax (let+ stx)
(lambda (stx) (syntax-case stx ()
(syntax-case stx () [(_ [clause ...] body1 body ...)
[(_ [clause ...] body1 body ...) (let ([clauses (syntax->list (syntax (clause ...)))]
(let ([clauses (syntax->list (syntax (clause ...)))] [bad (lambda (c n)
[bad (lambda (c n) (raise-syntax-error
(raise-syntax-error #f (format "illegal use of ~a for a clause" n) stx c))]
#f [var? (lambda (x)
(format "illegal use of ~a for a clause" n) (or (identifier? x)
stx (let ([l (syntax->list x)])
c))] (and l
[var? (lambda (x) (pair? l)
(or (identifier? x) (eq? (syntax-e (car l)) 'values)
(let ([l (syntax->list x)]) (andmap identifier? (cdr l))))))]
(and l [normal-var (lambda (x)
(pair? l) (if (identifier? x)
(eq? (syntax-e (car l)) 'values) (list x)
(andmap identifier? (cdr l))))))] (cdr (syntax-e x))))])
[normal-var (lambda (x) ;; syntax checks
(if (identifier? x) (for-each
(list x) (lambda (clause)
(cdr (syntax-e x))))]) (syntax-case* clause (val rec vals recs _)
;; syntax checks (lambda (a b) (eq? (syntax-e b) (syntax-e a)))
(for-each [(val var expr)
(lambda (clause) (var? (syntax var))
(syntax-case* clause (val rec vals recs _) (lambda (a b) 'ok]
(eq? (syntax-e b) [(rec var expr)
(syntax-e a))) (var? (syntax var))
[(val var expr) 'ok]
(var? (syntax var)) [(vals (var expr) ...)
'ok] (andmap var? (syntax->list (syntax (var ...))))
[(rec var expr) 'ok]
(var? (syntax var)) [(recs (var expr) ...)
'ok] (andmap var? (syntax->list (syntax (var ...))))
[(vals (var expr) ...) 'ok]
(andmap var? (syntax->list (syntax (var ...)))) [(_ expr0 expr ...)
'ok] 'ok]
[(recs (var expr) ...) [(val . __) (bad clause "val")]
(andmap var? (syntax->list (syntax (var ...)))) [(rec . __) (bad clause "rec")]
'ok] [(vals . __) (bad clause "vals")]
[(_ expr0 expr ...) [(recs . __) (bad clause"recs")]
'ok] [(_ . __) (bad clause "_")]
[(val . __) (bad clause "val")] [_else (raise-syntax-error #f "bad clause" stx clause)]))
[(rec . __) (bad clause "rec")] clauses)
[(vals . __) (bad clause "vals")] ;; result
[(recs . __) (bad clause"recs")]
[(_ . __) (bad clause "_")]
[_else (raise-syntax-error #f "bad clause" stx clause)]))
clauses)
;; result
(let loop ([clauses clauses]) (let loop ([clauses clauses])
(if (null? clauses) (if (null? clauses)
(syntax (let () body1 body ...)) (syntax (let () body1 body ...))
(with-syntax ([rest (loop (cdr clauses))]) (with-syntax ([rest (loop (cdr clauses))])
(syntax-case* (car clauses) (val rec vals recs _) (lambda (a b) (syntax-case* (car clauses) (val rec vals recs _)
(eq? (syntax-e b) (lambda (a b) (eq? (syntax-e b) (syntax-e a)))
(syntax-e a))) [(val var expr)
[(val var expr) (with-syntax ([vars (normal-var (syntax var))])
(with-syntax ([vars (normal-var (syntax var))]) (syntax (let-values ([vars expr]) rest)))]
(syntax (let-values ([vars expr]) rest)))] [(rec var expr)
[(rec var expr) (with-syntax ([vars (normal-var (syntax var))])
(with-syntax ([vars (normal-var (syntax var))]) (syntax (letrec-values ([vars expr]) rest)))]
(syntax (letrec-values ([vars expr]) rest)))] [(vals (var expr) ...)
[(vals (var expr) ...) (with-syntax ([(vars ...) (map normal-var (syntax->list (syntax (var ...))))])
(with-syntax ([(vars ...) (map normal-var (syntax->list (syntax (var ...))))]) (syntax (let-values ([vars expr] ...) rest)))]
(syntax (let-values ([vars expr] ...) rest)))] [(recs (var expr) ...)
[(recs (var expr) ...) (with-syntax ([(vars ...) (map normal-var (syntax->list (syntax (var ...))))])
(with-syntax ([(vars ...) (map normal-var (syntax->list (syntax (var ...))))]) (syntax (letrec-values ([vars expr] ...) rest)))]
(syntax (letrec-values ([vars expr] ...) rest)))] [(_ expr0 expr ...)
[(_ expr0 expr ...) (syntax (begin expr0 expr ... rest))])))))]))
(syntax (begin expr0 expr ... rest))])))))])))
(define ns-undefined (gensym)) (define ns-undefined (gensym))
(define (namespace-defined? n) (define (namespace-defined? n)
(unless (symbol? n) (unless (symbol? n)
(raise-type-error 'namespace-defined? "symbol" n)) (raise-type-error 'namespace-defined? "symbol" n))
(not (eq? (namespace-variable-value n #t (lambda () ns-undefined)) ns-undefined))) (not (eq? (namespace-variable-value n #t (lambda () ns-undefined))
ns-undefined)))
(define-syntax (this-expression-source-directory stx) (define-syntax (this-expression-source-directory stx)
(syntax-case stx () (syntax-case stx ()

361
collects/mzlib/list.ss
View File

@ -1,6 +1,5 @@
(module list mzscheme (module list mzscheme
(require "spidey.ss")
(provide set-first! (provide set-first!
first first
@ -148,64 +147,51 @@
(sort-internal lst less? #t 'sort)) (sort-internal lst less? #t 'sort))
;; deprecated! ;; deprecated!
(define quicksort (define (quicksort l less-than)
(polymorphic (unless (list? l)
(lambda (l less-than) (raise-type-error 'quicksort "proper list" l))
(unless (list? l) (unless (procedure-arity-includes? less-than 2)
(raise-type-error 'quicksort "proper list" l)) (raise-type-error 'quicksort "procedure of arity 2" less-than))
(unless (procedure-arity-includes? less-than 2) (let* ([v (list->vector l)]
(raise-type-error 'quicksort "procedure of arity 2" less-than)) [count (vector-length v)])
(let* ([v (list->vector l)] (let loop ([min 0][max count])
[count (vector-length v)]) (if (< min (sub1 max))
(let loop ([min 0][max count]) (let ([pval (vector-ref v min)])
(if (< min (sub1 max)) (let pivot-loop ([pivot min] [pos (add1 min)])
(let ([pval (vector-ref v min)]) (if (< pos max)
(let pivot-loop ([pivot min] (let ([cval (vector-ref v pos)])
[pos (add1 min)]) (if (less-than cval pval)
(if (< pos max) (begin (vector-set! v pos (vector-ref v pivot))
(let ([cval (vector-ref v pos)]) (vector-set! v pivot cval)
(if (less-than cval pval) (pivot-loop (add1 pivot) (add1 pos)))
(begin (pivot-loop pivot (add1 pos))))
(vector-set! v pos (vector-ref v pivot)) (if (= min pivot)
(vector-set! v pivot cval) (loop (add1 pivot) max)
(pivot-loop (add1 pivot) (add1 pos))) (begin (loop min pivot)
(pivot-loop pivot (add1 pos)))) (loop pivot max))))))))
(if (= min pivot) (vector->list v)))
(loop (add1 pivot) max)
(begin
(loop min pivot)
(loop pivot max))))))))
(vector->list v)))))
;; deprecated! ;; deprecated!
(define mergesort sort) (define mergesort sort)
(define remove (define remove
(polymorphic (letrec ([rm (case-lambda
(letrec ([rm (case-lambda [(item list) (rm item list equal?)]
[(item list) (rm item list equal?)] [(item list equal?)
[(item list equal?) (let loop ([list list])
(let loop ([list list]) (cond [(null? list) ()]
(cond [(equal? item (car list)) (cdr list)]
[(null? list) ()] [else (cons (car list) (loop (cdr list)))]))])])
[(equal? item (car list)) (cdr list)] rm))
[else (cons (car list)
(loop (cdr list)))]))])])
rm)))
(define remq (define (remq item list)
(polymorphic (remove item list eq?))
(lambda (item list)
(remove item list eq?))))
(define remv (define (remv item list)
(polymorphic (remove item list eqv?))
(lambda (item list)
(remove item list eqv?))))
(define remove* (define remove*
(polymorphic (case-lambda
(case-lambda
[(l r equal?) [(l r equal?)
(cond (cond
[(null? r) null] [(null? r) null]
@ -215,17 +201,13 @@
[(null? l-rest) (cons first-r (remove* l (cdr r) equal?))] [(null? l-rest) (cons first-r (remove* l (cdr r) equal?))]
[(equal? (car l-rest) first-r) (remove* l (cdr r) equal?)] [(equal? (car l-rest) first-r) (remove* l (cdr r) equal?)]
[else (loop (cdr l-rest))])))])] [else (loop (cdr l-rest))])))])]
[(l r) (remove* l r equal?)]))) [(l r) (remove* l r equal?)]))
(define remq* (define (remq* l r)
(polymorphic (remove* l r eq?))
(lambda (l r)
(remove* l r eq?))))
(define remv* (define (remv* l r)
(polymorphic (remove* l r eqv?))
(lambda (l r)
(remove* l r eqv?))))
;; fold : ((A B -> B) B (listof A) -> B) ;; fold : ((A B -> B) B (listof A) -> B)
;; fold : ((A1 ... An B -> B) B (listof A1) ... (listof An) -> B) ;; fold : ((A1 ... An B -> B) B (listof A1) ... (listof An) -> B)
@ -234,185 +216,142 @@
;; list and foldr builds the "B" from the end of the list to the ;; list and foldr builds the "B" from the end of the list to the
;; beginning of the list. ;; beginning of the list.
(define mapadd (define (mapadd f l last)
(polymorphic (letrec ((helper
(lambda (f l last) (lambda (l)
(letrec ((helper (cond [(null? l) (list last)]
(lambda (l) [else (cons (f (car l)) (helper (cdr l)))]))))
(cond (helper l)))
[(null? l) (list last)]
[else (cons (f (car l)) (helper (cdr l)))]))))
(helper l)))))
(define foldl (define foldl
(polymorphic (letrec ([fold-one
(letrec ((fold-one (lambda (f init l)
(lambda (f init l) (letrec ((helper
(letrec ((helper (lambda (init l)
(lambda (init l) (cond [(null? l) init]
(cond [else (helper (f (car l) init) (cdr l))]))))
[(null? l) init] (helper init l)))]
[else (helper (f (car l) init) (cdr l))])))) [fold-n
(helper init l)))) (lambda (f init l)
(fold-n (cond
(lambda (f init l) [(ormap null? l)
(cond (if (andmap null? l)
[(ormap null? l) init
(if (andmap null? l) (error 'foldl "received non-equal length input lists"))]
init [else (fold-n f (apply f (mapadd car l init)) (map cdr l))]))])
(error 'foldl "received non-equal length input lists"))] (case-lambda
[else (fold-n [(f init l) (fold-one f init l)]
f [(f init l . ls) (fold-n f init (cons l ls))])))
(apply f (mapadd car l init))
(map cdr l))]))))
(case-lambda
[(f init l) (fold-one f init l)]
[(f init l . ls) (fold-n f init (cons l ls))]))))
(define foldr (define foldr
(polymorphic (letrec ([fold-one
(letrec ((fold-one (lambda (f init l)
(lambda (f init l) (letrec ((helper
(letrec ((helper (lambda (init l)
(lambda (init l) (cond [(null? l) init]
(cond [else (f (car l) (helper init (cdr l)))]))))
[(null? l) init] (helper init l)))]
[else (f (car l) (helper init (cdr l)))])))) [fold-n
(helper init l)))) (lambda (f init l)
(fold-n (cond
(lambda (f init l) [(ormap null? l)
(cond (if (andmap null? l)
[(ormap null? l) init
(if (andmap null? l) (error 'foldr "received non-equal length input lists"))]
init [else (apply f (mapadd car l (fold-n f init (map cdr l))))]))])
(error 'foldr "received non-equal length input lists"))] (case-lambda
[else (apply f [(f init l) (fold-one f init l)]
(mapadd car l [(f init l . ls) (fold-n f init (cons l ls))])))
(fold-n f init (map cdr l))))]))))
(case-lambda
[(f init l) (fold-one f init l)]
[(f init l . ls) (fold-n f init (cons l ls))]))))
(define make-find (define (make-find name whole-list?)
(lambda (name whole-list?) (lambda (f list)
(polymorphic (unless (and (procedure? f) (procedure-arity-includes? f 1))
(lambda (f list) (raise-type-error name "procedure (arity 1)" f))
(unless (and (procedure? f) (let loop ([l list])
(procedure-arity-includes? f 1)) (cond [(null? l) #f]
(raise-type-error name "procedure (arity 1)" f)) [(not (pair? l))
(let loop ([l list]) (raise (make-exn:fail:contract
(cond (format "~a: second argument must be a (proper) list; given ~e" name list)
[(null? l) #f] (current-continuation-marks)))]
[(not (pair? l)) [else (let ([a (car l)])
(raise (make-exn:fail:contract (if whole-list?
(format "~a: second argument must be a (proper) list; given ~e" name list) (if (f a) l (loop (cdr l)))
(current-continuation-marks)))] (if (pair? a)
[else (let ([a (car l)]) (if (f (car a)) a (loop (cdr l)))
(if whole-list? (raise-mismatch-error
(if (f a) name "found a non-pair in the list: " a))))]))))
l
(loop (cdr l)))
(if (pair? a)
(if (f (car a))
a
(loop (cdr l)))
(raise-mismatch-error
name
"found a non-pair in the list: "
a))))]))))))
(define assf (define assf
(let ([a (make-find 'assf #f)]) (let ([a (make-find 'assf #f)])
(polymorphic (lambda (f l) (a f l))))
(lambda (f l)
(a f l)))))
(define memf (define memf
(let ([a (make-find 'memf #t)]) (let ([a (make-find 'memf #t)])
(polymorphic (lambda (f l) (a f l))))
(lambda (f l)
(a f l)))))
(define filter (define (filter f list)
(polymorphic (unless (and (procedure? f)
(lambda (f list) (procedure-arity-includes? f 1))
(unless (and (procedure? f) (raise-type-error 'filter "procedure (arity 1)" f))
(procedure-arity-includes? f 1)) ;; We use the reverse! trick because it's too easy to
(raise-type-error 'filter "procedure (arity 1)" f)) ;; overflow the internal stack using natural recursion.
;; We use the reverse! trick because it's too easy to ;; It's too bad that our Scheme system is so bad, but
;; overflow the internal stack using natural recursion. ;; until someone fixes it...
;; It's too bad that our Scheme system is so bad, but (let loop ([l list] [result null])
;; until someone fixes it... (cond
(let loop ([l list][result null]) [(null? l) (reverse! result)]
(cond [(pair? l) (loop (cdr l) (if (f (car l)) (cons (car l) result) result))]
[(null? l) (reverse! result)] [else (raise-mismatch-error
[(pair? l) 'filter "expects a proper list: " list)])))
(loop (cdr l) (if (f (car l))
(cons (car l) result)
result))]
[else (raise-mismatch-error
'filter
"expects a proper list: "
list)])))))
(define first (polymorphic (lambda (x) (define (first x)
(unless (pair? x) (unless (pair? x) (raise-type-error 'first "non-empty list" x))
(raise-type-error 'first "non-empty list" x)) (car x))
(car x)))) (define (set-first! x v)
(define set-first! (unless (pair? x) (raise-type-error 'set-first! "non-empty list" x))
(polymorphic (lambda (x v) (set-car! x v))
(unless (pair? x)
(raise-type-error 'set-first! "non-empty list" x))
(set-car! x v))))
(define (lget name npos) (define (lget name npos)
(lambda (x) (lambda (x)
(let loop ([l x][pos npos]) (let loop ([l x][pos npos])
(cond (cond
[(and (= pos 1) (pair? l)) [(and (= pos 1) (pair? l)) (car l)]
(car l)] [(pair? l) (loop (cdr l) (sub1 pos))]
[(pair? l) [else (raise-type-error
(loop (cdr l) (sub1 pos))] name (format "list with ~a or more items" npos) x)]))))
[else
(raise-type-error name
(format "list with ~a or more items" npos)
x)]))))
;; Gives the function a name: ;; Gives the function a name:
(define-syntax (mk-lget stx) (define-syntax (mk-lget stx)
(syntax-case stx () (syntax-case stx ()
[(_ name pos) [(_ name pos)
(syntax (polymorphic (let ([g (lget 'name pos)]) (syntax (let ([g (lget 'name pos)]) (lambda (x) (g x))))]))
(lambda (x) (g x)))))]))
(define second (mk-lget second 2)) (define second (mk-lget second 2))
(define third (mk-lget third 3)) (define third (mk-lget third 3))
(define fourth (mk-lget fourth 4)) (define fourth (mk-lget fourth 4))
(define fifth (mk-lget fifth 5)) (define fifth (mk-lget fifth 5))
(define sixth (mk-lget sixth 6)) (define sixth (mk-lget sixth 6))
(define seventh (mk-lget seventh 7)) (define seventh (mk-lget seventh 7))
(define eighth (mk-lget eighth 8)) (define eighth (mk-lget eighth 8))
(define rest (polymorphic (lambda (x) (define (rest x)
(unless (pair? x) (unless (pair? x)
(raise-type-error 'rest "non-empty list" x)) (raise-type-error 'rest "non-empty list" x))
(cdr x)))) (cdr x))
(define set-rest! (polymorphic (lambda (x v) (define (set-rest! x v)
(unless (pair? x) (unless (pair? x)
(raise-type-error 'set-rest! "non-empty list" x)) (raise-type-error 'set-rest! "non-empty list" x))
(unless (or (null? v) (pair? v)) (unless (or (null? v) (pair? v))
(raise-type-error 'set-rest! "second argument must be a list" v)) (raise-type-error 'set-rest! "second argument must be a list" v))
(set-cdr! x v)))) (set-cdr! x v))
(define last-pair (define (last-pair l)
(polymorphic (if (pair? l)
(lambda (l) (let loop ([l l] [x (cdr l)])
(if (pair? l) (if (pair? x)
(let loop ((l l) (x (cdr l))) (loop x (cdr x))
(if (pair? x) l))
(loop x (cdr x)) (raise-type-error 'last-pair "pair" l)))
l))
(raise-type-error 'last-pair "pair" l)))))
(define cons? (lambda (x) (pair? x))) (define cons? (lambda (x) (pair? x)))
(define empty? (lambda (x) (null? x))) (define empty? (lambda (x) (null? x)))

31
collects/mzlib/spidey.ss
View File

@ -1,31 +0,0 @@
(module spidey mzscheme
(provide define-constructor
define-type
:
mrspidey:control
polymorphic
type:)
(define-syntax define-constructor
(lambda (stx) (syntax (void))))
(define-syntax define-type
(lambda (stx) (syntax (void))))
(define-syntax :
(lambda (stx)
(syntax-case stx ()
[(_ v t) (syntax v)])))
(define-syntax mrspidey:control
(lambda (stx) (syntax (void))))
(define-syntax polymorphic
(lambda (stx)
(syntax-case stx ()
[(_ e) (syntax e)])))
(define-syntax type:
(lambda (stx) (syntax (void)))))

4
collects/mzlib/thread.ss
View File

@ -1,8 +1,6 @@
(module thread mzscheme (module thread mzscheme
(require "spidey.ss" (require "etc.ss" "contract.ss")
"etc.ss"
"contract.ss")
(provide run-server (provide run-server
consumer-thread) consumer-thread)