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")))

17
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,10 +38,9 @@
(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)
@ -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,7 +86,6 @@
#| #|
(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))
@ -99,10 +96,9 @@
(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))
@ -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)

215
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,10 +46,9 @@
(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)
@ -72,82 +69,66 @@
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
(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)
(error 'build-vector "~s must be a procedure" fcn)) (error 'build-vector "~s must be a procedure" fcn))
(let ((vec (make-vector n))) (let ([vec (make-vector n)])
(let loop ((i 0)) (let loop ((i 0))
(if (= i n) vec (if (= i n)
(begin vec
(vector-set! vec i (fcn i)) (begin (vector-set! vec i (fcn i)) (loop (add1 i)))))))
(loop (add1 i)))))))))
(define build-list (define (build-list n fcn)
(polymorphic
(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)
(error 'build-list "~s must be a procedure" fcn)) (error 'build-list "~s must be a procedure" fcn))
(if (zero? n) '() (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) head (if (= i n)
(begin head
(set-cdr! p (list (fcn i))) (begin (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
(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=? 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))
(raise-type-error 'symbol=? "symbol" (if (symbol? x) y x)))
(eq? x y))
(define-syntax (opt-lambda stx)
(with-syntax ([name (or (syntax-local-infer-name stx) (with-syntax ([name (or (syntax-local-infer-name stx)
(quote-syntax opt-lambda-proc))]) (quote-syntax opt-lambda-proc))])
(syntax-case stx () (syntax-case stx ()
@ -170,10 +151,7 @@
(begin (begin
(when needs-default? (when needs-default?
(raise-syntax-error (raise-syntax-error
#f #f "default value missing" stx (syntax id)))
"default value missing"
stx
(syntax id)))
(loop (append pre-args (list (syntax id))) (loop (append pre-args (list (syntax id)))
(syntax rest) (syntax rest)
#f))] #f))]
@ -193,19 +171,12 @@
(syntax bad))] (syntax bad))]
[else [else
(raise-syntax-error (raise-syntax-error
#f #f "bad identifier sequence" stx (syntax args))]))])
"bad identifier sequence"
stx
(syntax args))]))])
(with-syntax ([clauses clauses]) (with-syntax ([clauses clauses])
(syntax/loc stx (syntax/loc stx
(letrec ([name (letrec ([name (case-lambda . clauses)]) name))))])))
(case-lambda
. clauses)])
name))))]))))
(define-syntax local (define-syntax (local stx)
(lambda (stx)
(syntax-case stx () (syntax-case stx ()
[(_ (defn ...) body1 body ...) [(_ (defn ...) body1 body ...)
(let ([defs (let ([expand-context (generate-expand-context)]) (let ([defs (let ([expand-context (generate-expand-context)])
@ -238,87 +209,52 @@
(list d))] (list d))]
[(define-values . rest) [(define-values . rest)
(raise-syntax-error (raise-syntax-error
#f #f "ill-formed definition" stx d)]
"ill-formed definition"
stx
d)]
[(define-syntaxes (id ...) body) [(define-syntaxes (id ...) body)
(begin (begin
(check-ids (syntax->list (syntax (id ...)))) (check-ids (syntax->list (syntax (id ...))))
(list d))] (list d))]
[(define-syntaxes . rest) [(define-syntaxes . rest)
(raise-syntax-error (raise-syntax-error
#f #f "ill-formed definition" stx d)]
"ill-formed definition"
stx
d)]
[_else [_else
(raise-syntax-error (raise-syntax-error
#f #f "not a definition" stx defn)])))
"not a definition"
stx
defn)])))
defns))))]) defns))))])
(let ([ids (apply append (let ([ids (apply append
(map (map
(lambda (d) (lambda (d)
(syntax-case d () (syntax-case d ()
[(_ ids . __) [(_ ids . __) (syntax->list (syntax ids))]))
(syntax->list (syntax ids))]))
defs))]) defs))])
(let ([dup (check-duplicate-identifier ids)]) (let ([dup (check-duplicate-identifier ids)])
(when dup (when dup
(raise-syntax-error (raise-syntax-error #f "duplicate identifier" stx dup)))
#f
"duplicate identifier"
stx
dup)))
(with-syntax ([(def ...) defs]) (with-syntax ([(def ...) defs])
(syntax/loc (syntax/loc stx
stx (let () def ... (let () body1 body ...))))))]
(let ()
def ...
(let ()
body1
body ...))))))]
[(_ x body1 body ...) [(_ x body1 body ...)
(raise-syntax-error (raise-syntax-error #f "not a definition sequence" stx (syntax x))]))
#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) [(_ . rest) (syntax/loc stx (let . 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 (begin (unless (identifier? (syntax name))
(unless (identifier? (syntax name)) (raise-syntax-error #f "not an identifier" stx (syntax name)))
(raise-syntax-error (syntax/loc stx (letrec ([name expr]) name)))]))
#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 (map (lambda (t)
(lambda (t)
(syntax-case t (else) (syntax-case t (else)
[else (syntax #t)] [else (syntax #t)]
[_else (with-syntax ([t t]) [_else (with-syntax ([t t])
@ -331,53 +267,35 @@
(when (and (identifier? (car tests)) (when (and (identifier? (car tests))
(module-identifier=? (quote-syntax else) (car tests))) (module-identifier=? (quote-syntax else) (car tests)))
(raise-syntax-error (raise-syntax-error
#f #f "else is not in last clause" stx (car tests)))
"else is not in last clause"
stx
(car tests)))
(loop (cdr tests))))) (loop (cdr tests)))))
(syntax/loc stx (syntax/loc stx
(let ([evcase-v val]) (let ([evcase-v val])
(cond (cond [a-test (begin body ...)]
[a-test
(begin body ...)]
...)))))] ...)))))]
[(_ val something ...) [(_ val something ...)
;; Provide a good error message: ;; Provide a good error message:
(for-each (for-each
(lambda (s) (lambda (s)
(syntax-case s () (syntax-case s ()
[(t a ...) [(t a ...) (raise-syntax-error #f "invalid clause" stx s)]))
(raise-syntax-error (syntax->list (syntax (something ...))))]))
#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 ...) [(_ expr ...) (syntax/loc stx (not (or expr ...)))]))
(syntax/loc stx (not (or expr ...)))])))
(define-syntax nand (define-syntax (nand stx)
(lambda (stx)
(syntax-case stx () (syntax-case stx ()
[(_ expr ...) [(_ expr ...) (syntax/loc stx (not (and 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 #f (format "illegal use of ~a for a clause" n) stx c))]
(format "illegal use of ~a for a clause" n)
stx
c))]
[var? (lambda (x) [var? (lambda (x)
(or (identifier? x) (or (identifier? x)
(let ([l (syntax->list x)]) (let ([l (syntax->list x)])
@ -392,9 +310,8 @@
;; syntax checks ;; syntax checks
(for-each (for-each
(lambda (clause) (lambda (clause)
(syntax-case* clause (val rec vals recs _) (lambda (a b) (syntax-case* clause (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)
(var? (syntax var)) (var? (syntax var))
'ok] 'ok]
@ -421,9 +338,8 @@
(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)))]
@ -437,14 +353,15 @@
(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 ()

183
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,9 +147,7 @@
(sort-internal lst less? #t 'sort)) (sort-internal lst less? #t 'sort))
;; deprecated! ;; deprecated!
(define quicksort (define (quicksort l less-than)
(polymorphic
(lambda (l less-than)
(unless (list? l) (unless (list? l)
(raise-type-error 'quicksort "proper list" l)) (raise-type-error 'quicksort "proper list" l))
(unless (procedure-arity-includes? less-than 2) (unless (procedure-arity-includes? less-than 2)
@ -160,51 +157,40 @@
(let loop ([min 0][max count]) (let loop ([min 0][max count])
(if (< min (sub1 max)) (if (< min (sub1 max))
(let ([pval (vector-ref v min)]) (let ([pval (vector-ref v min)])
(let pivot-loop ([pivot min] (let pivot-loop ([pivot min] [pos (add1 min)])
[pos (add1 min)])
(if (< pos max) (if (< pos max)
(let ([cval (vector-ref v pos)]) (let ([cval (vector-ref v pos)])
(if (less-than cval pval) (if (less-than cval pval)
(begin (begin (vector-set! v pos (vector-ref v pivot))
(vector-set! v pos (vector-ref v pivot))
(vector-set! v pivot cval) (vector-set! v pivot cval)
(pivot-loop (add1 pivot) (add1 pos))) (pivot-loop (add1 pivot) (add1 pos)))
(pivot-loop pivot (add1 pos)))) (pivot-loop pivot (add1 pos))))
(if (= min pivot) (if (= min pivot)
(loop (add1 pivot) max) (loop (add1 pivot) max)
(begin (begin (loop min pivot)
(loop min pivot)
(loop pivot max)))))))) (loop pivot max))))))))
(vector->list v))))) (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 (cond [(null? list) ()]
[(null? list) ()]
[(equal? item (car list)) (cdr list)] [(equal? item (car list)) (cdr list)]
[else (cons (car list) [else (cons (car list) (loop (cdr list)))]))])])
(loop (cdr list)))]))])]) rm))
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
@ -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,108 +216,80 @@
;; 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
(lambda (f l last)
(letrec ((helper (letrec ((helper
(lambda (l) (lambda (l)
(cond (cond [(null? l) (list last)]
[(null? l) (list last)]
[else (cons (f (car l)) (helper (cdr l)))])))) [else (cons (f (car l)) (helper (cdr l)))]))))
(helper 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 (cond [(null? l) init]
[(null? l) init]
[else (helper (f (car l) init) (cdr l))])))) [else (helper (f (car l) init) (cdr l))]))))
(helper init l)))) (helper init l)))]
(fold-n [fold-n
(lambda (f init l) (lambda (f init l)
(cond (cond
[(ormap null? l) [(ormap null? l)
(if (andmap null? l) (if (andmap null? l)
init init
(error 'foldl "received non-equal length input lists"))] (error 'foldl "received non-equal length input lists"))]
[else (fold-n [else (fold-n f (apply f (mapadd car l init)) (map cdr l))]))])
f
(apply f (mapadd car l init))
(map cdr l))]))))
(case-lambda (case-lambda
[(f init l) (fold-one f init l)] [(f init l) (fold-one f init l)]
[(f init l . ls) (fold-n f init (cons l ls))])))) [(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 (cond [(null? l) init]
[(null? l) init]
[else (f (car l) (helper init (cdr l)))])))) [else (f (car l) (helper init (cdr l)))]))))
(helper init l)))) (helper init l)))]
(fold-n [fold-n
(lambda (f init l) (lambda (f init l)
(cond (cond
[(ormap null? l) [(ormap null? l)
(if (andmap null? l) (if (andmap null? l)
init init
(error 'foldr "received non-equal length input lists"))] (error 'foldr "received non-equal length input lists"))]
[else (apply f [else (apply f (mapadd car l (fold-n f init (map cdr l))))]))])
(mapadd car l
(fold-n f init (map cdr l))))]))))
(case-lambda (case-lambda
[(f init l) (fold-one f init l)] [(f init l) (fold-one f init l)]
[(f init l . ls) (fold-n f init (cons l ls))])))) [(f init l . ls) (fold-n f init (cons l ls))])))
(define make-find (define (make-find name whole-list?)
(lambda (name whole-list?)
(polymorphic
(lambda (f list) (lambda (f list)
(unless (and (procedure? f) (unless (and (procedure? f) (procedure-arity-includes? f 1))
(procedure-arity-includes? f 1))
(raise-type-error name "procedure (arity 1)" f)) (raise-type-error name "procedure (arity 1)" f))
(let loop ([l list]) (let loop ([l list])
(cond (cond [(null? l) #f]
[(null? l) #f]
[(not (pair? l)) [(not (pair? l))
(raise (make-exn:fail:contract (raise (make-exn:fail:contract
(format "~a: second argument must be a (proper) list; given ~e" name list) (format "~a: second argument must be a (proper) list; given ~e" name list)
(current-continuation-marks)))] (current-continuation-marks)))]
[else (let ([a (car l)]) [else (let ([a (car l)])
(if whole-list? (if whole-list?
(if (f a) (if (f a) l (loop (cdr l)))
l
(loop (cdr l)))
(if (pair? a) (if (pair? a)
(if (f (car a)) (if (f (car a)) a (loop (cdr l)))
a
(loop (cdr l)))
(raise-mismatch-error (raise-mismatch-error
name name "found a non-pair in the list: " a))))]))))
"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
(lambda (f list)
(unless (and (procedure? f) (unless (and (procedure? f)
(procedure-arity-includes? f 1)) (procedure-arity-includes? f 1))
(raise-type-error 'filter "procedure (arity 1)" f)) (raise-type-error 'filter "procedure (arity 1)" f))
@ -346,43 +300,30 @@
(let loop ([l list] [result null]) (let loop ([l list] [result null])
(cond (cond
[(null? l) (reverse! result)] [(null? l) (reverse! result)]
[(pair? l) [(pair? l) (loop (cdr l) (if (f (car l)) (cons (car l) result) result))]
(loop (cdr l) (if (f (car l))
(cons (car l) result)
result))]
[else (raise-mismatch-error [else (raise-mismatch-error
'filter 'filter "expects a proper list: " list)])))
"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))
@ -392,27 +333,25 @@
(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
(lambda (l)
(if (pair? l) (if (pair? l)
(let loop ((l l) (x (cdr l))) (let loop ([l l] [x (cdr l)])
(if (pair? x) (if (pair? x)
(loop x (cdr x)) (loop x (cdr x))
l)) l))
(raise-type-error 'last-pair "pair" 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)